From d2c0186e7ba8333ae4cf1db62bbe4091a0f6d607 Mon Sep 17 00:00:00 2001 From: Ryan Scott Date: Mon, 10 Jan 2022 14:16:56 -0500 Subject: [PATCH] Remove crucible-server `crucible-server` is no longer being maintained, and much of its reason for existence has been superseded by projects like `saw-remote-api`. Let's go ahead and remove `crucible-server` from version control, with the understanding that it will continue to exist in the `git` history should we need it again at some point in the future. --- README.md | 20 - cabal.project | 1 - crucible-server/.gitignore | 1 - crucible-server/LICENSE | 30 - crucible-server/README | 2 - crucible-server/Setup.hs | 83 -- crucible-server/crucible-server.cabal | 107 -- .../crucible-server/Main_crucible.hs | 107 -- crucible-server/java_api/.gitignore | 1 - crucible-server/java_api/Makefile | 17 - crucible-server/java_api/pom.xml | 135 -- .../com/galois/crucible/BitvectorValue.java | 60 - .../java/com/galois/crucible/BoolValue.java | 70 - .../com/galois/crucible/FunctionHandle.java | 90 -- .../com/galois/crucible/IntegerValue.java | 64 - .../com/galois/crucible/MessageConsumer.java | 5 - .../java/com/galois/crucible/NatValue.java | 54 - .../galois/crucible/NonFunctionMessage.java | 19 - .../com/galois/crucible/RationalValue.java | 169 --- .../crucible/ReadBeforeWriteMessage.java | 18 - .../com/galois/crucible/ReferenceValue.java | 40 - .../com/galois/crucible/SAWSimulator.java | 143 -- .../com/galois/crucible/SimpleSimulator.java | 214 --- .../java/com/galois/crucible/Simulator.java | 991 -------------- .../crucible/SimulatorAbortedException.java | 21 - .../crucible/SimulatorFailedException.java | 18 - .../galois/crucible/SimulatorFunction.java | 5 - .../com/galois/crucible/SimulatorMessage.java | 70 - .../com/galois/crucible/SimulatorValue.java | 13 - .../java/com/galois/crucible/StringValue.java | 32 - .../main/java/com/galois/crucible/Type.java | 420 ------ .../main/java/com/galois/crucible/Typed.java | 12 - .../java/com/galois/crucible/UnitValue.java | 36 - .../crucible/UserAssertFailureMessage.java | 19 - .../main/java/com/galois/crucible/Utils.java | 60 - .../com/galois/crucible/ValueCreator.java | 845 ------------ .../java/com/galois/crucible/VarType.java | 111 -- .../galois/crucible/VerificationHarness.java | 127 -- .../galois/crucible/VerificationOptions.java | 73 - .../galois/crucible/cfg/BinaryPosition.java | 31 - .../java/com/galois/crucible/cfg/Block.java | 31 - .../java/com/galois/crucible/cfg/Expr.java | 17 - .../com/galois/crucible/cfg/FunctionArg.java | 30 - .../galois/crucible/cfg/InternalPosition.java | 26 - .../com/galois/crucible/cfg/LambdaArg.java | 29 - .../com/galois/crucible/cfg/LambdaBlock.java | 52 - .../com/galois/crucible/cfg/Position.java | 28 - .../com/galois/crucible/cfg/Procedure.java | 166 --- .../java/com/galois/crucible/cfg/Reg.java | 34 - .../com/galois/crucible/cfg/SomeBlock.java | 353 ----- .../galois/crucible/cfg/SourcePosition.java | 33 - .../galois/crucible/cfg/StatementResult.java | 36 - .../com/galois/crucible/cfg/package-info.java | 11 - .../com/galois/crucible/examples/Test.java | 110 -- .../com/galois/crucible/package-info.java | 11 - .../com/galois/crucible/TestSAWSimulator.java | 57 - .../com/galois/crucible/TestValueCreator.java | 182 --- .../crucible/TestVerificationHarness.java | 89 -- crucible-server/proto/crucible.proto | 1206 ----------------- .../src/Lang/Crucible/Proto.hproto | 0 .../Crucible/Server/CallbackOutputHandle.hs | 77 -- .../src/Lang/Crucible/Server/CryptolEnv.hs | 568 -------- .../src/Lang/Crucible/Server/Encoding.hs | 135 -- .../Crucible/Server/MultipartOperations.hs | 193 --- .../src/Lang/Crucible/Server/Requests.hs | 625 --------- .../src/Lang/Crucible/Server/SAWOverrides.hs | 344 ----- .../Lang/Crucible/Server/SimpleOverrides.hs | 216 --- .../src/Lang/Crucible/Server/Simulator.hs | 351 ----- .../src/Lang/Crucible/Server/Translation.hs | 525 ------- .../src/Lang/Crucible/Server/TypeConv.hs | 286 ---- .../src/Lang/Crucible/Server/TypedTerm.hs | 66 - .../src/Lang/Crucible/Server/ValueConv.hs | 665 --------- .../Crucible/Server/Verification/Harness.hs | 760 ----------- .../Crucible/Server/Verification/Override.hs | 923 ------------- scripts/stack-test-coverage.sh | 2 +- 75 files changed, 1 insertion(+), 12570 deletions(-) delete mode 100644 crucible-server/.gitignore delete mode 100644 crucible-server/LICENSE delete mode 100644 crucible-server/README delete mode 100644 crucible-server/Setup.hs delete mode 100644 crucible-server/crucible-server.cabal delete mode 100644 crucible-server/crucible-server/Main_crucible.hs delete mode 100644 crucible-server/java_api/.gitignore delete mode 100644 crucible-server/java_api/Makefile delete mode 100644 crucible-server/java_api/pom.xml delete mode 100644 crucible-server/java_api/src/main/java/com/galois/crucible/BitvectorValue.java delete mode 100644 crucible-server/java_api/src/main/java/com/galois/crucible/BoolValue.java delete mode 100644 crucible-server/java_api/src/main/java/com/galois/crucible/FunctionHandle.java delete mode 100644 crucible-server/java_api/src/main/java/com/galois/crucible/IntegerValue.java delete mode 100644 crucible-server/java_api/src/main/java/com/galois/crucible/MessageConsumer.java delete mode 100644 crucible-server/java_api/src/main/java/com/galois/crucible/NatValue.java delete mode 100644 crucible-server/java_api/src/main/java/com/galois/crucible/NonFunctionMessage.java delete mode 100644 crucible-server/java_api/src/main/java/com/galois/crucible/RationalValue.java delete mode 100644 crucible-server/java_api/src/main/java/com/galois/crucible/ReadBeforeWriteMessage.java delete mode 100644 crucible-server/java_api/src/main/java/com/galois/crucible/ReferenceValue.java delete mode 100644 crucible-server/java_api/src/main/java/com/galois/crucible/SAWSimulator.java delete mode 100644 crucible-server/java_api/src/main/java/com/galois/crucible/SimpleSimulator.java delete mode 100644 crucible-server/java_api/src/main/java/com/galois/crucible/Simulator.java delete mode 100644 crucible-server/java_api/src/main/java/com/galois/crucible/SimulatorAbortedException.java delete mode 100644 crucible-server/java_api/src/main/java/com/galois/crucible/SimulatorFailedException.java delete mode 100644 crucible-server/java_api/src/main/java/com/galois/crucible/SimulatorFunction.java delete mode 100644 crucible-server/java_api/src/main/java/com/galois/crucible/SimulatorMessage.java delete mode 100644 crucible-server/java_api/src/main/java/com/galois/crucible/SimulatorValue.java delete mode 100644 crucible-server/java_api/src/main/java/com/galois/crucible/StringValue.java delete mode 100644 crucible-server/java_api/src/main/java/com/galois/crucible/Type.java delete mode 100644 crucible-server/java_api/src/main/java/com/galois/crucible/Typed.java delete mode 100644 crucible-server/java_api/src/main/java/com/galois/crucible/UnitValue.java delete mode 100644 crucible-server/java_api/src/main/java/com/galois/crucible/UserAssertFailureMessage.java delete mode 100644 crucible-server/java_api/src/main/java/com/galois/crucible/Utils.java delete mode 100644 crucible-server/java_api/src/main/java/com/galois/crucible/ValueCreator.java delete mode 100644 crucible-server/java_api/src/main/java/com/galois/crucible/VarType.java delete mode 100644 crucible-server/java_api/src/main/java/com/galois/crucible/VerificationHarness.java delete mode 100644 crucible-server/java_api/src/main/java/com/galois/crucible/VerificationOptions.java delete mode 100644 crucible-server/java_api/src/main/java/com/galois/crucible/cfg/BinaryPosition.java delete mode 100644 crucible-server/java_api/src/main/java/com/galois/crucible/cfg/Block.java delete mode 100644 crucible-server/java_api/src/main/java/com/galois/crucible/cfg/Expr.java delete mode 100644 crucible-server/java_api/src/main/java/com/galois/crucible/cfg/FunctionArg.java delete mode 100644 crucible-server/java_api/src/main/java/com/galois/crucible/cfg/InternalPosition.java delete mode 100644 crucible-server/java_api/src/main/java/com/galois/crucible/cfg/LambdaArg.java delete mode 100644 crucible-server/java_api/src/main/java/com/galois/crucible/cfg/LambdaBlock.java delete mode 100644 crucible-server/java_api/src/main/java/com/galois/crucible/cfg/Position.java delete mode 100644 crucible-server/java_api/src/main/java/com/galois/crucible/cfg/Procedure.java delete mode 100644 crucible-server/java_api/src/main/java/com/galois/crucible/cfg/Reg.java delete mode 100644 crucible-server/java_api/src/main/java/com/galois/crucible/cfg/SomeBlock.java delete mode 100644 crucible-server/java_api/src/main/java/com/galois/crucible/cfg/SourcePosition.java delete mode 100644 crucible-server/java_api/src/main/java/com/galois/crucible/cfg/StatementResult.java delete mode 100644 crucible-server/java_api/src/main/java/com/galois/crucible/cfg/package-info.java delete mode 100644 crucible-server/java_api/src/main/java/com/galois/crucible/examples/Test.java delete mode 100644 crucible-server/java_api/src/main/java/com/galois/crucible/package-info.java delete mode 100644 crucible-server/java_api/src/test/java/com/galois/crucible/TestSAWSimulator.java delete mode 100644 crucible-server/java_api/src/test/java/com/galois/crucible/TestValueCreator.java delete mode 100644 crucible-server/java_api/src/test/java/com/galois/crucible/TestVerificationHarness.java delete mode 100644 crucible-server/proto/crucible.proto delete mode 100644 crucible-server/src/Lang/Crucible/Proto.hproto delete mode 100644 crucible-server/src/Lang/Crucible/Server/CallbackOutputHandle.hs delete mode 100644 crucible-server/src/Lang/Crucible/Server/CryptolEnv.hs delete mode 100644 crucible-server/src/Lang/Crucible/Server/Encoding.hs delete mode 100644 crucible-server/src/Lang/Crucible/Server/MultipartOperations.hs delete mode 100644 crucible-server/src/Lang/Crucible/Server/Requests.hs delete mode 100644 crucible-server/src/Lang/Crucible/Server/SAWOverrides.hs delete mode 100644 crucible-server/src/Lang/Crucible/Server/SimpleOverrides.hs delete mode 100644 crucible-server/src/Lang/Crucible/Server/Simulator.hs delete mode 100644 crucible-server/src/Lang/Crucible/Server/Translation.hs delete mode 100644 crucible-server/src/Lang/Crucible/Server/TypeConv.hs delete mode 100644 crucible-server/src/Lang/Crucible/Server/TypedTerm.hs delete mode 100644 crucible-server/src/Lang/Crucible/Server/ValueConv.hs delete mode 100644 crucible-server/src/Lang/Crucible/Server/Verification/Harness.hs delete mode 100644 crucible-server/src/Lang/Crucible/Server/Verification/Override.hs diff --git a/README.md b/README.md index 52aa8741c..85a193ec9 100644 --- a/README.md +++ b/README.md @@ -62,13 +62,6 @@ In addition, there are the following library/executable packages: simulator. This is the backend for the `cargo crux-test` command provided by `mir-json`. See the [`crux-mir` README](crux-mir/README.md) for details. - * **`crucible-server`**, a standalone process that allows constructing - and symbolically executing Crucible programs via [Protocol Buffers][pb]. - The crucible-server directory also contains a Java API for - connecting to and working with the `crucible-server`. - -[pb]: https://developers.google.com/protocol-buffers/ "Protocol Buffers" - * **`uc-crux-llvm`**, another standalone frontend for executing C and C++ programs in the Crucible symbolic simulator, using "under-constrained" symbolic execution. Essentially, this technique can start at any function in @@ -115,19 +108,6 @@ cabal new-build all Alternately, you can target a more specific sub-package instead of `all`. -If you wish to build `crucible-server` (which will be built if you -build all packages, as above), then the build depends on having `hpb` -in your path. After fetching the dependencies, this can be arranged by -entering `dependencies/hpb/` and running the following commands: - -``` -cabal sandbox init -cabal install --dependencies-only -cabal install -cp ./cabal-sandbox/bin/hpb ⟨EXE_PATH⟩ -``` -where `⟨EXE_PATH⟩` is a directory on your `$PATH`. - Testing and Coverage -------------------- diff --git a/cabal.project b/cabal.project index fa6d9ceef..f00f857a9 100644 --- a/cabal.project +++ b/cabal.project @@ -26,7 +26,6 @@ optional-packages: dependencies/golang/ dependencies/jvm-parser/ dependencies/haskell-wasm/ - dependencies/hpb/ dependencies/llvm-pretty/ dependencies/llvm-pretty-bc-parser/ dependencies/what4/what4/ diff --git a/crucible-server/.gitignore b/crucible-server/.gitignore deleted file mode 100644 index c1d9b4c9b..000000000 --- a/crucible-server/.gitignore +++ /dev/null @@ -1 +0,0 @@ -.stack-work \ No newline at end of file diff --git a/crucible-server/LICENSE b/crucible-server/LICENSE deleted file mode 100644 index 0b558b495..000000000 --- a/crucible-server/LICENSE +++ /dev/null @@ -1,30 +0,0 @@ -Copyright (c) 2013-2018 Galois Inc. -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions -are met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in - the documentation and/or other materials provided with the - distribution. - - * Neither the name of Galois, Inc. nor the names of its contributors - may be used to endorse or promote products derived from this - software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS -IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A -PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER -OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, -EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR -PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF -LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING -NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/crucible-server/README b/crucible-server/README deleted file mode 100644 index 86a0e563c..000000000 --- a/crucible-server/README +++ /dev/null @@ -1,2 +0,0 @@ -This directory contains the crucible-server binary and the Java API for working with -it. diff --git a/crucible-server/Setup.hs b/crucible-server/Setup.hs deleted file mode 100644 index 4d3b7be78..000000000 --- a/crucible-server/Setup.hs +++ /dev/null @@ -1,83 +0,0 @@ -module Main (main) where - -import Control.Exception -import Control.Monad (when) -import Distribution.PackageDescription - ( BuildInfo - , GenericPackageDescription - , HookedBuildInfo - ) -import Distribution.Simple -import Distribution.Simple.LocalBuildInfo -import Distribution.Simple.PreProcess -import Distribution.Simple.Program.Types -import Distribution.Simple.Setup -import System.Directory -import System.FilePath -import System.IO.Error -import System.Process - -import Distribution.Simple.Utils -import Distribution.PackageDescription hiding (Flag) - --- | Path to Protocol buffer file. -pbPath :: FilePath -pbPath = "proto" "crucible.proto" - --- | Module name for protocol buffer file. -protoModule :: String -protoModule = "Lang.Crucible.Proto" - --- | Path to protocol buffer file. -protoOutPath :: FilePath -protoOutPath = "Lang" "Crucible" "Proto.hs" - -needsRebuild :: FilePath -> FilePath -> IO Bool -needsRebuild src_path tgt_path = do - let h e | isPermissionError e = return True - | isDoesNotExistError e = return True - | otherwise = throwIO e - handle h $ do - src_time <- getModificationTime src_path - tgt_time <- getModificationTime tgt_path - return (tgt_time < src_time) - -runHPB :: Args -> BuildFlags -> IO HookedBuildInfo -runHPB args flags = do - putStrLn "Running preBuild" - case buildDistPref flags of - NoFlag -> do - fail "Path not specified." - Flag distPath -> do - let out_dir = distPath "build" - mkProto out_dir - preBuild simpleUserHooks args flags - --- | Write out a file to the protocol buffe to given directory. -mkProto :: FilePath -> IO () -mkProto out_dir = do - let hpb_path = "hpb" - let outPath = out_dir protoOutPath - b <- needsRebuild pbPath outPath - when b $ do - callProcess hpb_path [ pbPath - , "--out=" ++ out_dir - , "--module=" ++ protoModule - ] - -dummyPreprocessor :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor -dummyPreprocessor build local _clbi = PreProcessor { - platformIndependent = True, - runPreProcessor = - mkSimplePreProcessor $ \inFile outFile verbosity -> do - notice verbosity (inFile ++ " is being preprocessed to " ++ outFile) - return () - } - -main :: IO () -main = do - defaultMainWithHooks simpleUserHooks - { hookedPrograms = [ simpleProgram "hpb" ] - , preBuild = runHPB - , hookedPreProcessors = [("hproto", dummyPreprocessor)] - } diff --git a/crucible-server/crucible-server.cabal b/crucible-server/crucible-server.cabal deleted file mode 100644 index ba6e2e0f7..000000000 --- a/crucible-server/crucible-server.cabal +++ /dev/null @@ -1,107 +0,0 @@ -Name: crucible-server -Version: 0.1 -Author: Galois Inc. -Maintainer: rdockins@galois.com -Build-type: Custom -License: BSD3 -License-file: LICENSE -Cabal-version: >= 1.9.2 -Category: Language -Synopsis: IPC server designed for interlanguage Crucible support -Description: - The Crucible server provides a host-language-agnostic interface to a - subset of the Crucible library functionality. This API is exposed via - protocol buffer messages. - -extra-source-files: - proto/crucible.proto - -custom-setup - setup-depends: - base >= 4.7 && < 5, - Cabal >= 1.24, - directory, - filepath, - process - -library - build-depends: - abcBridge, - base >= 4.7, - bv-sized >= 1.0.0, - bytestring >= 0.10.2, - containers, - what4, - what4-abc, - crucible >= 0.1, - crucible-saw, - cryptol, - cryptol-saw-core, - directory, - exceptions, - executable-path, - filepath, - GraphSCC, - hashable, - hashtables, - hpb >= 0.1.1, - lens, - mtl, - parameterized-utils >= 0.1.7, - prettyprinter >= 1.7.0, - saw-core, - saw-core-sbv, - sbv, - text, - transformers, - vector - - hs-source-dirs: src - - build-tools: - hpb - - exposed-modules: - Lang.Crucible.Proto - Lang.Crucible.Server.CallbackOutputHandle - Lang.Crucible.Server.CryptolEnv - Lang.Crucible.Server.Encoding - Lang.Crucible.Server.MultipartOperations - Lang.Crucible.Server.Requests - Lang.Crucible.Server.SAWOverrides - Lang.Crucible.Server.SimpleOverrides - Lang.Crucible.Server.Simulator - Lang.Crucible.Server.Translation - Lang.Crucible.Server.TypeConv - Lang.Crucible.Server.TypedTerm - Lang.Crucible.Server.ValueConv - Lang.Crucible.Server.Verification.Harness - Lang.Crucible.Server.Verification.Override - - autogen-modules: Lang.Crucible.Proto - - ghc-options: -Wall -Werror=incomplete-patterns -Werror=missing-methods -Werror=overlapping-patterns - ghc-prof-options: -O2 -fprof-auto-top - - -executable crucible-server - build-depends: - base >= 4.7 && < 4.15, - abcBridge, - what4, - what4-abc, - crucible, - crucible-saw, - crucible-server, - cryptol-saw-core, - hpb >= 0.1.1, - lens, - parameterized-utils >= 0.1.7, - saw-core, - text - - ghc-options: -Wall -Werror=incomplete-patterns -Werror=missing-methods -Werror=overlapping-patterns - - main-is: Main_crucible.hs - hs-source-dirs: - crucible-server diff --git a/crucible-server/crucible-server/Main_crucible.hs b/crucible-server/crucible-server/Main_crucible.hs deleted file mode 100644 index 93371243b..000000000 --- a/crucible-server/crucible-server/Main_crucible.hs +++ /dev/null @@ -1,107 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ViewPatterns #-} -module Main (main) where - -import Control.Exception -import Control.Lens -import Control.Monad -import qualified Data.Text as Text -import GHC.IO.Handle -import System.Exit -import System.IO - -import Data.HPB - -import Data.Parameterized.Nonce - -import Lang.Crucible.Backend.Simple -import qualified Lang.Crucible.Backend.SAWCore as SAW -import Lang.Crucible.Simulator.PathSatisfiability - -import qualified Lang.Crucible.Proto as P -import Lang.Crucible.Server.Requests -import Lang.Crucible.Server.Simulator -import Lang.Crucible.Server.SAWOverrides -import Lang.Crucible.Server.Verification.Override(SAWBack) -import Lang.Crucible.Server.SimpleOverrides - -import qualified Verifier.SAW.SharedTerm as SAW -import qualified Verifier.SAW.Prelude as SAW -import qualified Verifier.SAW.Cryptol.Prelude as CryptolSAW - -main :: IO () -main = do - -- Check that standard input and output are not terminals. - stdInputIsTerm <- hIsTerminalDevice stdin - stdOutputIsTerm <- hIsTerminalDevice stdout - when (stdInputIsTerm || stdOutputIsTerm) $ do - logMsg $ - "crucible-server is not intended to be run directly, but rather\n" - ++ "called by another process." - exitFailure - logMsg "Starting crucible-server" - hSetBinaryMode stdout True - hSetBuffering stdout (BlockBuffering Nothing) - runSimulator stdin stdout - hFlush stdout - --- | No interesting state needs to be threaded through --- the crucible server... -data CrucibleServerPersonality sym = CrucibleServerPersonality - -runSimulator :: Handle -> Handle -> IO () -runSimulator hin hout = do - handshake <- getDelimited hin - let backend = handshake^.P.handShakeRequest_backend - catch - (case backend of - P.SAWBackend -> do - logMsg $ "Starting SAW server..." - runSAWSimulator hin hout - P.SimpleBackend -> do - logMsg $ "Starting Simple server..." - runSimpleSimulator hin hout - ) - (\(ex::SomeException) -> - do let msg = Text.pack $ displayException ex - let err_resp = mempty - & P.handShakeResponse_code .~ P.HandShakeError - & P.handShakeResponse_message .~ msg - putDelimited hout err_resp - ) - -runSAWSimulator :: Handle -> Handle -> IO () -runSAWSimulator hin hout = - do let ok_resp = mempty - & P.handShakeResponse_code .~ P.HandShakeOK - withIONonceGenerator $ \gen -> do - sc <- SAW.mkSharedContext - SAW.scLoadPreludeModule sc - CryptolSAW.scLoadCryptolModule sc - (sym :: SAWBack n) <- SAW.newSAWCoreBackend FloatRealRepr sc gen - sawState <- initSAWServerPersonality sym - pathSatFeat <- pathSatisfiabilityFeature sym (SAW.considerSatisfiability sym) - s <- newSimulator sym sawServerOptions sawState [pathSatFeat] sawServerOverrides hin hout - putDelimited hout ok_resp - -- Enter loop to start reading commands. - fulfillRequests s sawBackendRequests - -runSimpleSimulator :: Handle -> Handle -> IO () -runSimpleSimulator hin hout = do - withIONonceGenerator $ \gen -> do - let ok_resp = mempty - & P.handShakeResponse_code .~ P.HandShakeOK - sym <- newSimpleBackend FloatRealRepr gen - s <- newSimulator sym simpleServerOptions CrucibleServerPersonality [] simpleServerOverrides hin hout - -- Enter loop to start reading commands. - putDelimited hout ok_resp - fulfillRequests s simpleBackendRequests diff --git a/crucible-server/java_api/.gitignore b/crucible-server/java_api/.gitignore deleted file mode 100644 index eb5a316cb..000000000 --- a/crucible-server/java_api/.gitignore +++ /dev/null @@ -1 +0,0 @@ -target diff --git a/crucible-server/java_api/Makefile b/crucible-server/java_api/Makefile deleted file mode 100644 index 88a098014..000000000 --- a/crucible-server/java_api/Makefile +++ /dev/null @@ -1,17 +0,0 @@ -ifndef JAVA_HOME -export JAVA_HOME=$(shell /usr/libexec/java_home) -endif - -all : - mvn install javadoc:javadoc - -build : - mvn install - -doc : - mvn javadoc:javadoc - -clean : - mvn clean - -.PHONY : all clean build doc diff --git a/crucible-server/java_api/pom.xml b/crucible-server/java_api/pom.xml deleted file mode 100644 index 6c237ac56..000000000 --- a/crucible-server/java_api/pom.xml +++ /dev/null @@ -1,135 +0,0 @@ - - - 4.0.0 - - com.galois - crucible-api - jar - 0.2 - - Crucible Java API - - - UTF-8 - ${project.basedir}/../../build - ${stagedir} - ${defaultCrucibleHome} - ${crucibleHome}/bin/crucible-server - - - - - com.google.protobuf - protobuf-java - 3.4.0 - - - - junit - junit - 4.13.1 - test - - - - - - - - - org.apache.maven.plugins - maven-compiler-plugin - 3.2 - - 1.6 - 1.6 - - - - - - org.apache.maven.plugins - maven-surefire-plugin - 2.18.1 - - - - ${cruciblePath} - - - - - - - org.codehaus.mojo - appassembler-maven-plugin - 1.9 - - - - package - - assemble - - - - - - - windows - unix - - ${stagedir} - - - com.galois.crucible.examples.Test - test-crucible-server - - "${cruciblePath}" - - - - - - - - - org.apache.maven.plugins - maven-javadoc-plugin - 2.10.1 - - com.galois.crucible.examples - ${stagedir} - javadocs - - - - - - org.xolstice.maven.plugins - protobuf-maven-plugin - 0.5.0 - - - ${project.basedir}/../proto - - **/*.proto - - - - true - - - - - compile - test-compile - - - - - - - - diff --git a/crucible-server/java_api/src/main/java/com/galois/crucible/BitvectorValue.java b/crucible-server/java_api/src/main/java/com/galois/crucible/BitvectorValue.java deleted file mode 100644 index e72419f28..000000000 --- a/crucible-server/java_api/src/main/java/com/galois/crucible/BitvectorValue.java +++ /dev/null @@ -1,60 +0,0 @@ -package com.galois.crucible; - -import java.math.BigInteger; -import com.google.protobuf.ByteString; - -import com.galois.crucible.proto.Protos; -import com.galois.crucible.cfg.Expr; - -/** This represents an integer literal. */ -public final class BitvectorValue implements Expr, SimulatorValue { - private final long width; - private final BigInteger v; - - public BitvectorValue(long width, BigInteger v) { - if (v == null) throw new NullPointerException("v"); - this.width = width; - this.v = v; - } - - public Type type() { - return Type.bitvector(width); - } - - public BigInteger getValue() { - return v; - } - - public Protos.Expr getExprRep() { - return - Protos.Expr.newBuilder() - .setCode(Protos.ExprCode.BitvectorExpr) - .setWidth(width) - .setData(ByteString.copyFrom(v.toByteArray())) - .build(); - } - - public Protos.Value getValueRep() { - return - Protos.Value.newBuilder() - .setCode(Protos.ValueCode.BitvectorValue) - .setWidth(width) - .setData(ByteString.copyFrom(v.toByteArray())) - .build(); - } - - public String toString() { - return "0x" + v.toString(16) + ":[" + String.valueOf(width) + "]"; - } - - public boolean equals(Object o) { - if (!(o instanceof BitvectorValue)) return false; - BitvectorValue r = (BitvectorValue) o; - return (width == r.width) && v.equals(r.v); - } - - public int hashCode() { - return ((int) width) ^ v.hashCode(); - } - -} diff --git a/crucible-server/java_api/src/main/java/com/galois/crucible/BoolValue.java b/crucible-server/java_api/src/main/java/com/galois/crucible/BoolValue.java deleted file mode 100644 index 0da0a9e23..000000000 --- a/crucible-server/java_api/src/main/java/com/galois/crucible/BoolValue.java +++ /dev/null @@ -1,70 +0,0 @@ -package com.galois.crucible; -import com.galois.crucible.cfg.Expr; -import com.galois.crucible.proto.Protos; - -/** A Boolean literal as a simulator value. */ -public final class BoolValue implements Expr, SimulatorValue { - boolean bool; - - public static BoolValue TRUE = new BoolValue(true); - public static BoolValue FALSE = new BoolValue(false); - - - /** Create a new value. */ - private BoolValue(boolean bool) { - this.bool = bool; - } - - /** - * Return the type associated with this value. - * @return the type of the Boolean value. - */ - public Type type() { - return Type.BOOL; - } - - /** - * Return the representation of a crucible expression. - */ - public Protos.Expr getExprRep() { - return - Protos.Expr.newBuilder() - .setCode(bool ? Protos.ExprCode.TrueExpr : Protos.ExprCode.FalseExpr) - .build(); - } - - /** - * Return the protocol buffer representation of this value. - * - * @return the protocol buffer representation. - */ - public Protos.Value getValueRep() { - return - Protos.Value.newBuilder() - .setCode(bool ? Protos.ValueCode.TrueValue : Protos.ValueCode.FalseValue) - .build(); - } - - /** - * Return Boolean value. - * - * @return the value - */ - public boolean getValue() { - return bool; - } - - /** - * Return string "True" or "False" based on value. - * - * @return string representation. - */ - public String toString() { - return bool ? "True" : "False"; - } - - public boolean equals(Object o) { - if (!(o instanceof BoolValue)) return false; - return bool == ((BoolValue) o).bool; - } -} diff --git a/crucible-server/java_api/src/main/java/com/galois/crucible/FunctionHandle.java b/crucible-server/java_api/src/main/java/com/galois/crucible/FunctionHandle.java deleted file mode 100644 index 1fbfff801..000000000 --- a/crucible-server/java_api/src/main/java/com/galois/crucible/FunctionHandle.java +++ /dev/null @@ -1,90 +0,0 @@ -package com.galois.crucible; -import java.io.ByteArrayOutputStream; -import java.io.IOException; -import java.io.OutputStream; -import java.util.Arrays; - -import com.galois.crucible.cfg.Expr; -import com.galois.crucible.proto.Protos; - -/** - * Represents handles to functions. - */ -public final class FunctionHandle implements SimulatorValue, Expr { - private final long handleId; - private final String displayName; - private final Type[] argTypes; - private final Type returnType; - - /** - * Internal method for creating a new handle, see @Simulator.newHandle@ - * for the public interface. This does the work of talking to the C code - * to get a new unique ID for the simulator. - */ - FunctionHandle(long handleId, - String displayName, - Type[] argTypes, - Type returnType) { - - this.handleId = handleId; - this.displayName = displayName; - this.argTypes = argTypes.clone(); - this.returnType = returnType; - } - - /** - * Create a handle from a handle info. - */ - FunctionHandle(long handleId, Protos.HandleInfo h) { - this(handleId, - h.getDisplayName(), - Type.typeArrayFromProtoList(h.getArgTypeList()), - new Type(h.getReturnType())); - } - - public long getUniqueId() { - return handleId; - } - - public String getDisplayName() { - return displayName; - } - - public int getArgCount() { - return argTypes.length; - } - - /** - * Return type at given index. - */ - public Type getArgType(int i) { - assert 0 <= i && i < argTypes.length; - return argTypes[i]; - } - - public Type getReturnType() { - return returnType; - } - - public Type type() { - return Type.functionHandle(argTypes, returnType); - } - - /** Generate protocol repersentation. */ - public Protos.Expr getExprRep() { - return - Protos.Expr.newBuilder() - .setCode(Protos.ExprCode.FnHandleExpr) - .setIndex(handleId) - .build(); - } - - /** Generate protocol repersentation. */ - public Protos.Value getValueRep() { - return - Protos.Value.newBuilder() - .setCode(Protos.ValueCode.FnHandleValue) - .setIndex(handleId) - .build(); - } -} diff --git a/crucible-server/java_api/src/main/java/com/galois/crucible/IntegerValue.java b/crucible-server/java_api/src/main/java/com/galois/crucible/IntegerValue.java deleted file mode 100644 index 5c8b7328d..000000000 --- a/crucible-server/java_api/src/main/java/com/galois/crucible/IntegerValue.java +++ /dev/null @@ -1,64 +0,0 @@ -package com.galois.crucible; -import java.math.BigInteger; -import com.google.protobuf.ByteString; -import com.galois.crucible.cfg.Expr; -import com.galois.crucible.proto.Protos; - -/** - * A specific integer simulator value. - */ -public final class IntegerValue implements SimulatorValue, Expr { - private final BigInteger v; - - public IntegerValue(long i) { - this.v = BigInteger.valueOf(i); - } - - public IntegerValue(BigInteger i) { - if (i == null) throw new NullPointerException("i"); - this.v = i; - } - - public Type type() { - return Type.INTEGER; - } - - private ByteString getDataRep() { - return ByteString.copyFrom(v.toByteArray()); - } - - public Protos.Expr getExprRep() { - return - Protos.Expr.newBuilder() - .setCode(Protos.ExprCode.IntegerExpr) - .setData(getDataRep()) - .build(); - } - - public Protos.Value getValueRep() { - return - Protos.Value.newBuilder() - .setCode(Protos.ValueCode.IntegerValue) - .setData(getDataRep()) - .build(); - } - - public boolean equals(Object o) { - if (!(o instanceof IntegerValue)) return false; - return v.equals(((IntegerValue) o).v); - } - - /** - * Returns hash code of integer. - */ - public int hashCode() { - return v.hashCode(); - } - - /** - * Returns decimal representation of string. - */ - public String toString() { - return v.toString(); - } -} diff --git a/crucible-server/java_api/src/main/java/com/galois/crucible/MessageConsumer.java b/crucible-server/java_api/src/main/java/com/galois/crucible/MessageConsumer.java deleted file mode 100644 index 4c5ba1577..000000000 --- a/crucible-server/java_api/src/main/java/com/galois/crucible/MessageConsumer.java +++ /dev/null @@ -1,5 +0,0 @@ -package com.galois.crucible; - -public interface MessageConsumer { - public void acceptMessage(SimulatorMessage msg); -} diff --git a/crucible-server/java_api/src/main/java/com/galois/crucible/NatValue.java b/crucible-server/java_api/src/main/java/com/galois/crucible/NatValue.java deleted file mode 100644 index b0308ce6d..000000000 --- a/crucible-server/java_api/src/main/java/com/galois/crucible/NatValue.java +++ /dev/null @@ -1,54 +0,0 @@ -package com.galois.crucible; -import java.math.BigInteger; -import com.google.protobuf.ByteString; -import com.galois.crucible.cfg.Expr; -import com.galois.crucible.proto.Protos; - -/** A constant natural number in the simulator. */ -public final class NatValue implements SimulatorValue, Expr { - private final BigInteger v; - - public NatValue(BigInteger i) { - if (i == null) throw new NullPointerException("i"); - if (i.signum() == -1) - throw new IllegalArgumentException("Natural numbers cannot be negative."); - this.v = i; - } - - public Type type() { - return Type.NAT; - } - - private ByteString getDataRep() { - return ByteString.copyFrom(v.toByteArray()); - } - - public Protos.Expr getExprRep() { - return - Protos.Expr.newBuilder() - .setCode(Protos.ExprCode.NatExpr) - .setData(getDataRep()) - .build(); - } - - public Protos.Value getValueRep() { - return - Protos.Value.newBuilder() - .setCode(Protos.ValueCode.NatValue) - .setData(getDataRep()) - .build(); - } - - public boolean equals(Object o) { - if (!(o instanceof NatValue)) return false; - return v.equals(((NatValue) o).v); - } - - public int hashCode() { - return v.hashCode(); - } - - public String toString() { - return v.toString(); - } -} diff --git a/crucible-server/java_api/src/main/java/com/galois/crucible/NonFunctionMessage.java b/crucible-server/java_api/src/main/java/com/galois/crucible/NonFunctionMessage.java deleted file mode 100644 index d2b2f1e95..000000000 --- a/crucible-server/java_api/src/main/java/com/galois/crucible/NonFunctionMessage.java +++ /dev/null @@ -1,19 +0,0 @@ -package com.galois.crucible; - -import java.util.*; -import com.galois.crucible.cfg.Position; -import com.galois.crucible.proto.Protos; - -/** - This path aborted message is returned when a SimulatorValue that is not a function - handle is passed to the runCall() method. -*/ -public class NonFunctionMessage extends SimulatorMessage { - public NonFunctionMessage( String message, List proto_backtrace ) { - super(message, proto_backtrace); - } - public NonFunctionMessage( String message ) { - super(message); - } -} - diff --git a/crucible-server/java_api/src/main/java/com/galois/crucible/RationalValue.java b/crucible-server/java_api/src/main/java/com/galois/crucible/RationalValue.java deleted file mode 100644 index cc7e1545d..000000000 --- a/crucible-server/java_api/src/main/java/com/galois/crucible/RationalValue.java +++ /dev/null @@ -1,169 +0,0 @@ -package com.galois.crucible; -import java.io.ByteArrayInputStream; -import java.io.ByteArrayOutputStream; -import java.math.BigInteger; -import com.google.protobuf.ByteString; -import com.galois.crucible.cfg.Expr; -import com.galois.crucible.proto.Protos; - -/** A simulator value containing a rational constant. */ -public final class RationalValue implements SimulatorValue, Expr { - private final BigInteger numerator; - private final BigInteger denominator; - - /** - * Create a value from an integer. - * @param n the numerator - */ - public RationalValue(BigInteger n) { - if (n == null) throw new NullPointerException("n"); - this.numerator = n; - this.denominator = BigInteger.valueOf(1); - } - - /** - * Create a value from an rational. - * @param n the numerator - * @param d the denominator - */ - public RationalValue(BigInteger n, BigInteger d) { - if (n == null) throw new NullPointerException("n"); - if (d == null) throw new NullPointerException("d"); - if (d.signum() == 0) - throw new IllegalArgumentException("d must be non-zero."); - // Negate numerator and denominator if d is negative. - if (d.signum() == -1) { - n = n.negate(); - d = d.negate(); - } - - // Compute gcd to normalize coefficients. - BigInteger g = n.gcd(d); - this.numerator = n.divide(g); - this.denominator = d.divide(g); - } - - public RationalValue(byte[] bytes) { - // Create stream. - ByteArrayInputStream s = new ByteArrayInputStream(bytes); - - // Read unsigned varint for denominator. - BigInteger d = readUVarint(s); - - // Get remaining bytes. - byte[] remaining = new byte[s.available()]; - s.read(remaining, 0, s.available()); - - BigInteger n = new BigInteger(remaining); - - // Compute gcd. - BigInteger g = n.gcd(d); - if (!g.equals(BigInteger.valueOf(1))) { - throw new IllegalArgumentException( - "BigInteger(byte[]) expected values in reduced form."); - } - this.numerator = n; - this.denominator = d; - } - - public Type type() { - return Type.REAL; - } - - /** Return numerator of rational. */ - public BigInteger numerator() { - return numerator; - } - - /** Return denominator of rational. */ - public BigInteger denominator() { - return denominator; - } - - private static BigInteger readUVarint(ByteArrayInputStream s) { - BigInteger r = BigInteger.valueOf(0); - int shift = 0; - - // Read bytes until we reach end. - while (true) { - int next = s.read(); - r = r.or(BigInteger.valueOf(next & 0x7f).shiftLeft(shift)); - shift += 7; - if ((next & 0x80) == 0) break; - } - - // Return result. - return r; - } - - private static void writeUVarint(ByteArrayOutputStream s, BigInteger r) { - if (r.signum() == -1) { - throw new IllegalArgumentException("writeUVarint given negative number."); - } - // Handle special case of zero to simplify rest of code. - if (r.signum() == 0) { - s.write(0); - return; - } - // Get number of bytes needed to store r. - int cnt = (r.bitLength() + 6) / 7; - // Write non-terminal bytes. - while (cnt > 1) { - --cnt; - // Get 7 bits at current offset. - int val = r.shiftRight(7*cnt).intValue() & 0x7f; - // Write 7 bits with extra bit to denote continuation. - s.write(val | 0x80); - } - // Get 7 bits at current offset. - s.write(r.intValue() & 0x7f); - } - - private ByteString getDataRep() { - ByteArrayOutputStream s = new ByteArrayOutputStream(); - // Write denominator first. - writeUVarint(s, denominator); - // Now write numerator. - byte[] bytes = numerator.toByteArray(); - // We use this function to avoid spurious IOException - s.write(bytes, 0, bytes.length); - return ByteString.copyFrom(s.toByteArray()); - } - - public Protos.Expr getExprRep() { - return Protos.Expr.newBuilder() - .setCode(Protos.ExprCode.RationalExpr) - .setData(getDataRep()) - .build(); - } - - public Protos.Value getValueRep() { - return Protos.Value.newBuilder() - .setCode(Protos.ValueCode.RationalValue) - .setData(getDataRep()) - .build(); - } - - /** Check if two rationals are equal. */ - public boolean equals(Object o) { - if (!(o instanceof RationalValue)) return false; - RationalValue r = (RationalValue) o; - // Rationals are stored in reduced form, so equality is quick. - return numerator.equals(r.numerator) - && denominator.equals(r.denominator); - } - - /** Get hashcode for rational. */ - public int hashCode() { - return numerator.hashCode() ^ denominator.hashCode(); - } - - /** Print rational as a numerator over divisor. */ - public String toString() { - if (denominator.equals(BigInteger.valueOf(1))) { - return numerator.toString(); - } else { - return numerator.toString() + "/" + denominator.toString(); - } - } -} diff --git a/crucible-server/java_api/src/main/java/com/galois/crucible/ReadBeforeWriteMessage.java b/crucible-server/java_api/src/main/java/com/galois/crucible/ReadBeforeWriteMessage.java deleted file mode 100644 index 543f476cd..000000000 --- a/crucible-server/java_api/src/main/java/com/galois/crucible/ReadBeforeWriteMessage.java +++ /dev/null @@ -1,18 +0,0 @@ -package com.galois.crucible; - -import java.util.*; -import com.galois.crucible.cfg.Position; -import com.galois.crucible.proto.Protos; - -/** - This path aborted message is returned when a simulated branch of execution - reads from a word map at a location not initalized. -*/ -public class ReadBeforeWriteMessage extends SimulatorMessage { - public ReadBeforeWriteMessage( String message, List proto_backtrace ) { - super(message, proto_backtrace); - } - public ReadBeforeWriteMessage( String message ) { - super(message); - } -} diff --git a/crucible-server/java_api/src/main/java/com/galois/crucible/ReferenceValue.java b/crucible-server/java_api/src/main/java/com/galois/crucible/ReferenceValue.java deleted file mode 100644 index d0e85bf33..000000000 --- a/crucible-server/java_api/src/main/java/com/galois/crucible/ReferenceValue.java +++ /dev/null @@ -1,40 +0,0 @@ -package com.galois.crucible; -import com.galois.crucible.proto.Protos; - -/** - * A simulator value that is stored in the server. - */ -public final class ReferenceValue implements SimulatorValue { - private final Type type; - private final long idx; - - ReferenceValue(Type type, long idx) { - if (type == null) throw new NullPointerException("type"); - this.type = type; - this.idx = idx; - } - - public Type type() { - return type; - } - - public Protos.Value getValueRep() { - return Protos.Value.newBuilder() - .setCode(Protos.ValueCode.ReferenceValue) - .setIndex(idx) - .build(); - } - - public String toString() { - return "??"; - } - - public boolean equals(Object o) { - if (!(o instanceof ReferenceValue)) return false; - return idx == ((ReferenceValue) o).idx; - } - - public int hashCode() { - return (int)(idx^(idx>>>32)); - } -} diff --git a/crucible-server/java_api/src/main/java/com/galois/crucible/SAWSimulator.java b/crucible-server/java_api/src/main/java/com/galois/crucible/SAWSimulator.java deleted file mode 100644 index 51bc3415e..000000000 --- a/crucible-server/java_api/src/main/java/com/galois/crucible/SAWSimulator.java +++ /dev/null @@ -1,143 +0,0 @@ -package com.galois.crucible; - -import java.io.BufferedReader; -import java.io.InputStream; -import java.io.InputStreamReader; -import java.io.IOException; -import java.io.OutputStream; -import java.io.PrintStream; -import java.math.BigInteger; -import java.util.Arrays; -import java.util.HashMap; -import java.util.LinkedList; -import java.util.List; -import java.util.Set; -import java.util.concurrent.BlockingDeque; -import java.util.concurrent.LinkedBlockingDeque; - -import com.galois.crucible.cfg.Procedure; -import com.google.protobuf.MessageLite; -import com.galois.crucible.proto.Protos; -import com.galois.crucible.MessageConsumer; - -/** - * Main interface to symbolic simulator, using the SAW backend. - */ -public final class SAWSimulator extends Simulator { - private SAWSimulator() {} - - /** - * Launch a local connection to the simulator. - * - * @param command The command to run. - * @throws SecurityException If a security manager exists and its - * {@link java.lang.SecurityManager#checkExec checkExec} method doesn't allow - * creation of the subprocess - * @throws IOException If an I/O error occurs - * @throws NullPointerException If command is null - * @throws IllegalArgumentException If command is empty - * @return A freshly created symbolic simulator interface. - */ - public static SAWSimulator launchLocal(String command) throws IOException { - Process p = Simulator.launchLocalProcess(command); - SAWSimulator sim = new SAWSimulator(); - sim.setupSimulator(p.getOutputStream(), p.getInputStream(), Protos.Backend.SAWBackend); - - return sim; - } - - /** - * Set whether path satisfiablity checking is enabled in the symbolic simulator. - * - * @param pathSat The new setting value - * @throws IOException If an I/O error occurs while communicating with the crucible server. - */ - public synchronized void setPathSatChecking( boolean pathSat ) throws IOException { - SimulatorValue pathSatVal = pathSat ? BoolValue.TRUE : BoolValue.FALSE; - - issueRequest( Protos.Request.newBuilder() - .setCode( Protos.RequestCode.SetConfigValue ) - .setConfigSettingName( "checkPathSat" ) - .addArg( pathSatVal.getValueRep() ) ); - - getNextAckResponse(); - } - - /** - * Get whether path satisfiablity checking is currently enabled in the symbolic simulator. - * - * @returns The current setting of the path satisfiability configuration value. - * @throws IOException If an I/O error occurs while communicating with the crucible server. - * @throws SimulatorFailedException if an unexpected (non-boolean) value is returned by the server. - */ - public synchronized boolean getPathSatChecking() throws IOException { - issueRequest( Protos.Request.newBuilder() - .setCode(Protos.RequestCode.GetConfigValue) - .setConfigSettingName( "checkPathSat" ) ); - - Protos.SimulatorValueResponse r = getNextSimulatorValueResponse(); - - if (!r.getSuccessful()) { - String msg = "Could not create simulator value"; - String err = r.getErrorMsg(); - if( !(err == null) ) { msg = msg + ": " + err; } - throw new SimulatorFailedException(msg); - } - - // Parse value back. - SimulatorValue v = fromProtosValue(r.getValue(), Type.BOOL); - if( v instanceof BoolValue ) { - BoolValue bv = (BoolValue) v; - return bv.getValue(); - } else { - String msg = "Expected boolean value response from simulator when retrieving path sat checking configuration value"; - throw new SimulatorFailedException(msg); - } - } - - public synchronized - FunctionHandle compileHarness( VerificationHarness harness ) throws IOException { - issueRequest( Protos.Request.newBuilder() - .setCode(Protos.RequestCode.CompileVerificationOverride) - .setVerificationHarness( harness.getRep() )); - - return predefinedHandleInfoResponse(); - } - - - public synchronized void produceVerificationGoals( VerificationHarness harness, VerificationOptions verifOpts ) - throws IOException - { - issueRequest( Protos.Request.newBuilder() - .setCode(Protos.RequestCode.SimulateVerificationHarness) - .setVerificationHarness(harness.getRep()) - .setVerificationSimOptions(verifOpts.getRep()) ); - - // Wait for the server to finish - getNextAckResponse(); - } - - - /** - * This writes a SAWCore file representing the given sequence of - * symbolic values. - */ - public synchronized void writeSAW( String path, SimulatorValue ... vals ) - throws IOException { - - Protos.Request.Builder b - = Protos.Request.newBuilder() - .setCode(Protos.RequestCode.ExportModel) - .setExportFormat(Protos.ExportFormat.ExportSAW) - .setExportPath(path); - - for( SimulatorValue v : vals ) { - b.addArg(v.getValueRep()); - } - - issueRequest(b); - - // Wait for the server to finish - getNextAckResponse(); - } -} diff --git a/crucible-server/java_api/src/main/java/com/galois/crucible/SimpleSimulator.java b/crucible-server/java_api/src/main/java/com/galois/crucible/SimpleSimulator.java deleted file mode 100644 index 29dc1608c..000000000 --- a/crucible-server/java_api/src/main/java/com/galois/crucible/SimpleSimulator.java +++ /dev/null @@ -1,214 +0,0 @@ -package com.galois.crucible; - -import java.io.BufferedReader; -import java.io.InputStream; -import java.io.InputStreamReader; -import java.io.IOException; -import java.io.OutputStream; -import java.io.PrintStream; -import java.math.BigInteger; -import java.util.Arrays; -import java.util.HashMap; -import java.util.LinkedList; -import java.util.List; -import java.util.Set; -import java.util.concurrent.BlockingDeque; -import java.util.concurrent.LinkedBlockingDeque; - -import com.galois.crucible.cfg.Procedure; -import com.google.protobuf.MessageLite; -import com.galois.crucible.proto.Protos; -import com.galois.crucible.MessageConsumer; - -/** - * Main interface to symbolic simulator, using the simple backend. - */ -public final class SimpleSimulator extends Simulator { - private SimpleSimulator() {} - - /** - * Launch a local connection to the simulator. - * - * @param command The command to run. - * @throws SecurityException If a security manager exists and its - * {@link java.lang.SecurityManager#checkExec checkExec} method doesn't allow - * creation of the subprocess - * @throws IOException If an I/O error occurs - * @throws NullPointerException If command is null - * @throws IllegalArgumentException If command is empty - * @return A freshly created symbolic simulator interface. - */ - public static SimpleSimulator launchLocal(String command) throws IOException { - Process p = Simulator.launchLocalProcess(command); - SimpleSimulator sim = new SimpleSimulator(); - sim.setupSimulator(p.getOutputStream(), p.getInputStream(), Protos.Backend.SimpleBackend); - - return sim; - } - - /** - * This writes an SMTLib2 file to check if x is a satisfiable - * boolean expression. - */ - public void writeSmtlib2(String path, SimulatorValue x) throws IOException { - // Get predefined handle for checkSat. - FunctionHandle h = getWriteSmtlib2Handle(); - - // call function. - try { - SimulatorValue res = runCall(h, new StringValue(path), x); - if (!(res instanceof UnitValue)) { - throw new Error("writeSmtlib2 did not return a unit variable."); - } - - } catch (SimulatorFailedException e) { - throw new Error("Failed to run writeSmtlib2.", e); - } - } - - - /** - * This writes a Yices file to check if x is a satisfiable - * boolean expression. - */ - public void writeYices(String path, SimulatorValue x) throws IOException { - // Get predefined handle for checkSat. - FunctionHandle h = getWriteYicesHandle(); - - // call function. - try { - SimulatorValue res = runCall(h, new StringValue(path), x); - if (!(res instanceof UnitValue)) { - throw new Error("writeYices did not return a unit variable."); - } - - } catch (SimulatorFailedException e) { - throw new Error("Failed to run writeYices.", e); - } - } - - - /** - * This performs a satisfiability check to determine if x is satisfiable. - * - * @return True if value is satisfiable. - */ - public boolean checkSatWithAbc(SimulatorValue x) throws IOException { - // Get predefined handle for checkSat. - FunctionHandle h = getCheckSatWithAbcHandle(); - - // call function. - try { - SimulatorValue res = runCall(h, x); - if (!(res instanceof BoolValue)) { - throw new Error("Check sat did not return a Boolean variable."); - } - - // Get return value - return ((BoolValue) res).getValue(); - } catch (SimulatorFailedException e) { - throw new Error("Failed to run checkSat.", e); - } - } - - /** - * Returns handle associated with checking whether a predicate is - * true. - * - * @throws IOException When there was an error when interacting with - * the server. - * @return the handle - */ - public FunctionHandle getCheckSatWithAbcHandle() throws IOException { - return getHandleByName("checkSatWithAbc"); - } - - - /** - * This performs a satisfiability check to determine if x is satisfiable. - * - * @return True if value is satisfiable. - */ - public boolean checkSatWithYices(SimulatorValue x) throws IOException { - // Get predefined handle for checkSat. - FunctionHandle h = getCheckSatWithYicesHandle(); - - // call function. - try { - SimulatorValue res = runCall(h, x); - if (!(res instanceof BoolValue)) { - throw new Error("Check sat did not return a Boolean variable."); - } - - // Get return value - return ((BoolValue) res).getValue(); - } catch (SimulatorFailedException e) { - throw new Error("Failed to run checkSat.", e); - } - } - - /** - * Returns handle associated with checking whether a predicate is - * true. - * - * @throws IOException When there was an error when interacting with - * the server. - * @return the handle - */ - public FunctionHandle getCheckSatWithYicesHandle() throws IOException { - return getHandleByName("checkSatWithYices"); - } - - /** - * Returns handle associated with writing an SMTLib2 file that asserts - * a given predicate is true. - * - * The function returned expects two arguments. The first is a - * string containing the filename to write to. The second is a - * Boolean predicate. - * - * @return the handle - */ - public FunctionHandle getWriteSmtlib2Handle() throws IOException { - return getHandleByName("write_SMTLIB2"); - } - - /** - * Returns handle associated with writing a Yices file that asserts - * a given predicate is true. - * - * The function returned expects two arguments. The first is a - * string containing the filename to write to. The second is a - * Boolean predicate. - * - * @return the handle - */ - public FunctionHandle getWriteYicesHandle() throws IOException { - return getHandleByName("write_yices"); - } - - /** - * This writes an AIGER file representing the given sequence of - * symbolic values, each of which should be either a boolean - * or a bitvector. Bitvectors are encoded into the AIGER in - * most-significant-bit first order. - */ - public synchronized void writeAIGER( String path, SimulatorValue ... vals ) - throws IOException { - - Protos.Request.Builder b - = Protos.Request.newBuilder() - .setCode(Protos.RequestCode.ExportModel) - .setExportFormat(Protos.ExportFormat.ExportAIGER) - .setExportPath(path); - - for( SimulatorValue v : vals ) { - b.addArg(v.getValueRep()); - } - - issueRequest(b); - - // Wait for the server to finish - getNextAckResponse(); - } -} diff --git a/crucible-server/java_api/src/main/java/com/galois/crucible/Simulator.java b/crucible-server/java_api/src/main/java/com/galois/crucible/Simulator.java deleted file mode 100644 index c2e62b340..000000000 --- a/crucible-server/java_api/src/main/java/com/galois/crucible/Simulator.java +++ /dev/null @@ -1,991 +0,0 @@ -package com.galois.crucible; -import java.io.BufferedReader; -import java.io.InputStream; -import java.io.InputStreamReader; -import java.io.IOException; -import java.io.OutputStream; -import java.io.PrintStream; -import java.math.BigInteger; -import java.util.Arrays; -import java.util.HashMap; -import java.util.LinkedList; -import java.util.List; -import java.util.Set; -import java.util.concurrent.BlockingDeque; -import java.util.concurrent.LinkedBlockingDeque; - -import com.galois.crucible.cfg.Position; -import com.galois.crucible.cfg.Procedure; -import com.google.protobuf.MessageLite; -import com.galois.crucible.proto.Protos; -import com.galois.crucible.MessageConsumer; - -/** - * Main interface to symbolic simulator. - * - *

- * Implementation note: Simulator values may be a reference to a value in the - * server. The number of values is not expected to be large, but enable - * server resources to be garbage collected, simulator values containing - * references use the finalizer to release their resources. To avoid thread - * contention, one should synchornize on the Simulator object when - * sending and receiving messages to the server. - */ -public abstract class Simulator extends ValueCreator { - - /** Event listeners for listening when print is called. */ - private List printMessageListeners = new LinkedList(); - - /** Event listeners for listening when path is aborted. */ - private List pathAbortedListeners = new LinkedList(); - - /** Responses that have been queued up by the dedicated call response thread */ - private BlockingDeque queuedResponses = - new LinkedBlockingDeque(); - // FIXME, should this be capacity limited? - - /** - * The dedicated thread that reads responses from the server and queues them - * for subsequent proessing - */ - private Thread responseListenerThread; - - /** Are we in the process of shutting down the connection to the crucible server? */ - private boolean closing = false; - - /** Stream to write any status messages to. Null indicates no logging */ - private PrintStream statusStream = null; - - /** - * Set the stream to write logging messages to. - * @param s The stream. - */ - public void setStatusStream(PrintStream s) { - statusStream = s; - } - - - /** Get the next queued server response. Will block until a response is avaliable. */ - protected Protos.GenericResponse getNextResponse() throws IOException { - Protos.GenericResponse resp = null; - - // Retry if we get interrupted - while (true) { - try { - resp = queuedResponses.takeFirst(); - - switch(resp.getCode()) { - case ExceptionGenResp: - // If the response is an exception, raise a corresponging - // exception. - String msg = resp.getMessage(); - throw new IOException( msg ); - default: - // Otherwise, return the response - return resp; - } - } catch (InterruptedException ex) { - } - } - } - - protected void getNextAckResponse() throws IOException { - Protos.GenericResponse r = getNextResponse(); - - switch(r.getCode()) { - case AcknowledgementResp: - return; - } - - throw new IOException( "Expected simulator ACK response!\n" + r.toString() ); - } - - protected Protos.SimulatorValueResponse getNextSimulatorValueResponse() throws IOException { - Protos.GenericResponse r = getNextResponse(); - Protos.SimulatorValueResponse svr = r.getSimValResponse(); - - switch(r.getCode()) { - case SimulatorValueGenResp: - if( svr != null ) { - return svr; - } - } - - throw new IOException( "Expected simulator value response!" + r.toString() ); - } - - protected Protos.RegisterHandleResponse getNextRegisterHandleResponse() throws IOException { - Protos.GenericResponse r = getNextResponse(); - Protos.RegisterHandleResponse hr = r.getRegHandleResponse(); - - switch(r.getCode()) { - case RegisterHandleGenResp: - if( hr != null ) { - return hr; - } - } - - throw new IOException( "Expected register handle response!" + r.toString() ); - } - - protected Protos.PredefinedHandleInfo getNextPredefHandleResponse() throws IOException { - Protos.GenericResponse r = getNextResponse(); - Protos.PredefinedHandleInfo hi = r.getPredefHandleResponse(); - - switch(r.getCode()) { - case PredefHandleGenResp: - if( hi != null ) { - return hi; - } - } - - throw new IOException( "Expected predefined handle info!" + r.toString() ); - } - - protected Protos.CallResponse getNextCallResponse() throws IOException { - Protos.GenericResponse r = getNextResponse(); - Protos.CallResponse cr = r.getCallResponse(); - - switch(r.getCode()) { - case CallGenResp: - if( cr != null ) { - return cr; - } - } - - throw new IOException( "Expected call response!" + r.toString() ); - } - - /** - * Start a dedicated thread to read responses from the crucible server. - * Responses that print values are immediately handed off to the printMessageListeners, - * and other responses are queued into the queuedResponses list. - * - * This thread exits when the associated stream is closed. If the closing - * flag is not set, this will cause a message to be printed and an immediate JVM exit. - */ - private void startResponseListenerThread() { - final Simulator sim = this; - responseListenerThread = new Thread() { - public void run() { - try { - while(true) { - Protos.GenericResponse r = - Protos.GenericResponse.parseDelimitedFrom(response); - - // null return generally indicates the input stream was closed - if( r == null ) { break; } - - switch (r.getCode()) { - case PrintGenResp: - SimulatorMessage msg = new SimulatorMessage( r.getMessage() ); - - synchronized(printMessageListeners) { - for (MessageConsumer p : printMessageListeners) { - p.acceptMessage(msg); - } - } - break; - default: - queuedResponses.putLast(r); - } - } - } catch (InterruptedException ex) { - } catch (Exception ex) { - ex.printStackTrace(); - } - System.err.println("response listener thread exiting"); - - synchronized(sim) { - if(!sim.closing) { - System.err.println("response stream closed unexpectedly!"); - System.exit(1); - } - } - } - }; - - responseListenerThread.start(); - } - - private static class OverrideEntry { - OverrideEntry(FunctionHandle h, SimulatorFunction fn) { - this.h = h; - this.fn = fn; - } - - final FunctionHandle h; - final SimulatorFunction fn; - } - - /** - * Maps handle indices that are overriden to the function - * implementing their behavior. - */ - private HashMap overrideMap - = new HashMap(); - - /** - * Flag to indicates that requests are suspended. This is only set to - * true when the simulator is running a potentially long-running computation - * that it expects a response from before sending a new request. - * - * When this is true, the thread should wait until it is ready. - * Invariants: - * When request is null, this should be true. - */ - private boolean requestSuspended; - - /** - * This indicates the number of overrides that we are inside of - * when executing functions. - * - * It should be 0 when we are not currently executing a call. - */ - private long callHeight; - - /** - * Output stream for issuing requests to simulator. - */ - private OutputStream request; - - /** - * Input stream for receiving information to simulator. - */ - private InputStream response; - - /** - * The list of symbolic value references that need to be released once - * the current method is complete. - */ - private List releasedReferences = new LinkedList(); - - /** - * This is an inputstream attached to a process that will throw an exception if - * an attempt is made to read from it and the process has terminated. - */ - // FIXME, this class seems unneeded now... - private static class ProcessInputStream extends InputStream { - Process p; - ProcessInputStream(Process p ) { - this.p = p; - } - public int read() throws IOException { - int r = p.getInputStream().read(); - if (r == -1) { - String msg = String.format("Server process terminated prematurely (exit code %d)", - p.exitValue()); - throw new IOException(msg); - } - return r; - } - } - - public static List extraLocalCommandArguments = null; - - /** - * Launch a local connection to the simulator. - * - * @param command The command to run. - * @throws SecurityException If a security manager exists and its - * {@link java.lang.SecurityManager#checkExec checkExec} method doesn't allow - * creation of the subprocess - * @throws IOException If an I/O error occurs - * @throws NullPointerException If command is null - * @throws IllegalArgumentException If command is empty - * @return A freshly created symbolic simulator interface. - */ - protected static Process launchLocalProcess(String command) throws IOException { - if (command == null) - throw new NullPointerException("command"); - if (command == "") - throw new IllegalArgumentException("command"); - - List commandList = new LinkedList(); - commandList.add(command); - if( extraLocalCommandArguments != null ) { - commandList.addAll( extraLocalCommandArguments ); - } - final Process p = new ProcessBuilder(commandList).start(); - - Runnable err_task = new Runnable(){ - public void run(){ - try { - - InputStreamReader isr = new InputStreamReader(p.getErrorStream(), "UTF-8"); - BufferedReader r = new BufferedReader(isr); - while (true) { - String s = r.readLine(); - if (s == null) { - System.err.format("crucible-server terminated\n"); - return; - } - System.err.format("crucible-server: %s%n", s); - } - } catch (IOException e) { - System.err.format("crucible-server error: %s%n", e.getMessage()); - } - } - }; - new Thread(err_task).start(); - - return p; - } - - /** - * Create a connection to the simulator that will transmit requests - * over the request stream, and receive responses to - * the response stream. - * - * The simulator requires exclusive access to the streams during - * execution, and the server must be in an idle state. - * - * @param request Stream to use sending requests to crucible-server. - * @param response Stream to use for receiving responses from crucible-server. - */ - protected void setupSimulator(OutputStream request, InputStream response, Protos.Backend backend) - throws java.io.IOException - { - synchronized (this) { - this.requestSuspended = false; - this.callHeight = 0; - this.request = request; - this.response = response; - - Protos.HandShakeRequest.newBuilder() - .setBackend(backend) - .build() - .writeDelimitedTo(request); - request.flush(); - - Protos.HandShakeResponse r = - Protos.HandShakeResponse.parseDelimitedFrom(response); - - if( r != null && r.getCode() != null && - r.getCode().equals( Protos.HandShakeCode.HandShakeOK ) ) { - - // start the listener thread that will parses and queues server responses - startResponseListenerThread(); - } else { - String msg = null; - if( r != null ) { msg = r.getMessage(); } - if( msg != null ) { - msg = "Failed to start simulator: " + msg; - } else { - msg = "Failed to start simulator"; - } - throw new IOException( msg ); - } - } - } - - /** - * Forcibly terminate a connection. - */ - private synchronized void forceTerminateConnection() { - request = null; - releasedReferences = null; - } - - private void logStatus(String msg) { - if (statusStream != null) { - statusStream.printf("crucible-client: %s\n", msg); - statusStream.flush(); - } - } - - /** - * Close the connection to crucible-server so that no more requests will be sent. - * @throws InterruptedException If thread is interrupted before closing. - */ - public void close() throws InterruptedException, IOException { - synchronized(this) { - // Wait until we can send a request. - while (requestSuspended) { - this.wait(); - } - - closing = true; - - if (request != null) { - try { - logStatus("Sending KillSimulator message."); - // Send notice to simulator to end. - Protos.Request.newBuilder() - .setCode(Protos.RequestCode.KillSimulator) - .build() - .writeDelimitedTo(request); - request.flush(); - } finally { - forceTerminateConnection(); - } - } - } - - // ask the response listener to shut down - responseListenerThread.interrupt(); - - // wait a short while for the response listener thread - responseListenerThread.join(100); - } - - /** - * Build message and write it to crucible-server. - * The simulator should own a lock to this when issueRequest is called. - */ - protected void issueRequest(Protos.Request.Builder msg) { - // Wait until we can send a request. - while (requestSuspended) { - try { - this.wait(); - } catch (InterruptedException e) { - throw new SimulatorFailedException(e); - } - } - - if (request == null) - throw new UnsupportedOperationException("Simulator has been closed."); - try { - logStatus("Sending request: " + msg.getCode().toString()); - msg.build().writeDelimitedTo(request); - request.flush(); - } catch (IOException e) { - forceTerminateConnection(); - throw new SimulatorFailedException(e); - } - } - - /** - * Release a reference value, or schedule it to be released. - */ - synchronized void releaseReferenceValue(long index) - throws IOException { - if (request == null) return; - - if (requestSuspended) { - releasedReferences.add(new Long(index)); - } else { - Protos.Request.newBuilder() - .setCode(Protos.RequestCode.ReleaseValue) - .setIndex(index) - .build() - .writeDelimitedTo(request); - request.flush(); - } - } - - /** - * Start call. - */ - private synchronized void startCall(SimulatorValue f, SimulatorValue[] args) - throws IOException { - if (request == null) - throw new UnsupportedOperationException("Simulator has been finalized."); - - // Disable requests until call is complete. - requestSuspended = true; - - - Protos.Request.Builder b - = Protos.Request.newBuilder() - .setCode(Protos.RequestCode.RunCall) - .addArg(f.getValueRep()); - for (SimulatorValue v : args) { - b.addArg(v.getValueRep()); - } - b.build() - .writeDelimitedTo(request); - request.flush(); - } - - /** - * End call - */ - private synchronized void endCall() throws IOException { - if (request != null) { - requestSuspended = false; - // wake up the threads blocked waiting for requests to resume - this.notifyAll(); - - // Release any references that were queued up during call. - while (releasedReferences.size() > 0) { - Long ref = releasedReferences.remove(0); - Protos.Request.newBuilder() - .setCode(Protos.RequestCode.ReleaseValue) - .setIndex(ref.longValue()) - .build() - .writeDelimitedTo(request); - } - request.flush(); - } - } - - private - void respondToOverrideCalled(long handle_index, List args) { - OverrideEntry e = overrideMap.get(new Long(handle_index)); - if (e == null) - throw new IllegalStateException("Simulator asked to respond to undefined override."); - FunctionHandle h = e.h; - if (h.getArgCount() != args.size()) { - throw new IllegalStateException("Override given incorrect number of arguments."); - } - - SimulatorValue[] argArray = new SimulatorValue[args.size()]; - for (int i = 0; i != args.size(); ++i) { - Type tp = h.getArgType(i); - argArray[i] = fromProtosValue(args.get(i), tp); - } - - ++callHeight; - SimulatorValue r = e.fn.run(argArray); - --callHeight; - - // Tell simulator to resume execution. - synchronized (this) { - issueRequest(Protos.Request.newBuilder() - .setCode(Protos.RequestCode.ResumeSimulation) - .setReturnValue(r.getValueRep())); - } - } - - /** - * Runs a procedure call. - * @throws SimulatorFailedException When simulation fails on all execution paths. - */ - public SimulatorValue runCall(SimulatorValue f, SimulatorValue ... args) { - Type f_type = f.type(); - if (!f_type.isFunctionHandle()) { - throw new IllegalArgumentException("runCall expects a function."); - } - - if (f_type.getFunctionArgumentCount() != args.length) { - throw new IllegalArgumentException("runCall given incorrect number of arguments."); - } - - // Check function arguments. - for (int i = 0; i != args.length; ++i) { - Type arg_type = args[i].type(); - Type expected_type = f_type.getFunctionArgumentType(i); - if (!arg_type.equals(expected_type)) { - String msg = String.format("runCall argument $1 has incorrect type.", i); - throw new IllegalArgumentException(msg); - } - } - - Type return_type = f_type.getFunctionReturnType(); - - List abortedMessages = new LinkedList(); - - try { - try { - startCall(f, args); - while (true) { - Protos.CallResponse r = getNextCallResponse(); - - switch (r.getCode()) { - case CallOverrideCalled: - respondToOverrideCalled(r.getHandleIndex(), r.getArgList()); - break; - case CallPathAborted: - SimulatorMessage msg = - SimulatorMessage.parsePathAbortedMessage( r.getMessage() ); - - abortedMessages.add( msg ); - for (MessageConsumer p : pathAbortedListeners) { - p.acceptMessage(msg); - } - break; - case CallReturnValue: - return fromProtosValue(r.getReturnVal(), return_type); - case CallAllAborted: - throw new SimulatorAbortedException( abortedMessages ); - default: - // Kill request since we can't expect to parse results again. - forceTerminateConnection(); - throw new SimulatorFailedException("Could not parse simulator response: " + r.toString() ); - } - } - } finally { - endCall(); - } - } catch (IOException e) { - forceTerminateConnection(); - throw new SimulatorFailedException(e); - } - - } - - - public SimulatorValue boolLiteral( boolean val ) - { - if( val ) { - return BoolValue.TRUE; - } else { - return BoolValue.FALSE; - } - } - - public SimulatorValue bvLiteral( long width, BigInteger val ) - { - return new BitvectorValue( width, val ); - } - - public SimulatorValue natLiteral( BigInteger val ) - { - return new NatValue( val ); - } - - public SimulatorValue callHandle( FunctionHandle hdl, Object... args ) { - return runCall( hdl, Arrays.copyOf( args, args.length, SimulatorValue[].class ) ); - } - - protected - synchronized - SimulatorValue applyPrimitive(Type type, - Protos.PrimitiveOp op, - Object... args) { - - Protos.Request.Builder b - = Protos.Request.newBuilder() - .setCode(Protos.RequestCode.ApplyPrimitive) - .setPrimOp(op) - .setResultType(type.getTypeRep()); - for (Object v : args) { - b.addArg(((SimulatorValue) v) .getValueRep()); - } - issueRequest(b); - - try { - Protos.SimulatorValueResponse r = getNextSimulatorValueResponse(); - - if (!r.getSuccessful()) { - String msg = "Could not create simulator value"; - String err = r.getErrorMsg(); - if( !(err == null) ) { msg = msg + ": " + err; } - throw new SimulatorFailedException(msg); - } - - // Parse value back. - return fromProtosValue(r.getValue(), type); - } catch (IOException e) { - throw new SimulatorFailedException(e); - } - } - - /** - * Tell the simulator to use the given procedure when calling - * functions with the handle associated to the procedure. - * - * @param p procedure to use - */ - public synchronized void useCfg(Procedure p) throws IOException { - issueRequest(Protos.Request.newBuilder() - .setCode(Protos.RequestCode.UseCFG) - .setCfg(p.getCfgRep())); - getNextAckResponse(); - } - - /** - * Tell the simulator to unpack and print the given CFG. - * - * @param p procedure to use - */ - public synchronized void printCFG(Procedure p) throws IOException { - issueRequest(Protos.Request.newBuilder() - .setCode(Protos.RequestCode.PrintCFG) - .setCfg(p.getCfgRep())); - getNextAckResponse(); - } - - /** - * Tell the simulator to call Java code when the function - * h is called. - * This replaces any current binding to the handle. - * - * @param h The handle to attach the override to. - * @param f The Java function to run when the function is called. - */ - public synchronized - void useOverride(FunctionHandle h, SimulatorFunction f ) { - - issueRequest(Protos.Request.newBuilder() - .setCode(Protos.RequestCode.UseOverride) - .setIndex(h.getUniqueId())); - // Add override to map for later lookup. - overrideMap.put(h.getUniqueId(), new OverrideEntry(h, f)); - } - - /** - * Add listener that receives evens when message is printed during symbolic execution. - */ - public void addPrintMessageListener(MessageConsumer listener) { - synchronized(printMessageListeners) { - printMessageListeners.add(listener); - } - } - - /** - * Add listener that receives evens when path is aborted during symbolic execution. - */ - public synchronized void addPathAbortedListener(MessageConsumer listener) { - pathAbortedListeners.add(listener); - } - - /** Read a simulator value from the protocol buffer format. */ - protected static - SimulatorValue fromProtosValue(Protos.Value v, Type expectedType) { - // Declare local variables so intance variables are assigned once. - switch (v.getCode()) { - case ReferenceValue: - return new ReferenceValue(expectedType, v.getIndex()); - case TrueValue: - if (!expectedType.equals(Type.BOOL)) - throw new IllegalArgumentException("Expected bool value."); - return BoolValue.TRUE; - case FalseValue: - if (!expectedType.equals(Type.BOOL)) - throw new IllegalArgumentException("Expected bool value."); - return BoolValue.FALSE; - case NatValue: - // Use big-endian encoding without sign-bit. - return new NatValue(new BigInteger(1, v.getData().toByteArray())); - case IntegerValue: - return new IntegerValue(new BigInteger(v.getData().toByteArray())); - case RationalValue: - return new RationalValue(v.getData().toByteArray()); - case BitvectorValue: - // valueRef stores the width when this is a bitvector. - return new BitvectorValue(v.getWidth(), new BigInteger(1, v.getData().toByteArray())); - case StringValue: - return new StringValue(v.getStringLit()); - case UnitValue: - if (!expectedType.equals(Type.UNIT)) - throw new IllegalArgumentException("Expected unit value."); - return new UnitValue(); - case FnHandleValue: - return new FunctionHandle(v.getIndex(), v.getHandleInfo()); - default: - throw new IllegalArgumentException("Cannot parse Value kind."); - } - } - - /** method for registering a Handle with the simulator. */ - public synchronized - FunctionHandle - newHandle(String displayName, Type[] argTypes, Type returnType) throws IOException { - Protos.HandleInfo.Builder b - = Protos.HandleInfo.newBuilder() - .setDisplayName(displayName) - .setReturnType(returnType.getTypeRep()); - for (Type argType : argTypes) { - b.addArgType(argType.getTypeRep()); - } - Protos.HandleInfo h = b.build(); - - // Issue request to register handle. - issueRequest(Protos.Request.newBuilder() - .setCode(Protos.RequestCode.RegisterHandle) - .setHandle(h)); - long handleId = getNextRegisterHandleResponse().getIndex(); - return new FunctionHandle(handleId, displayName, argTypes, returnType); - } - - protected FunctionHandle predefinedHandleInfoResponse() throws IOException { - - Protos.PredefinedHandleInfo pinfo = getNextPredefHandleResponse(); - - long handleId = pinfo.getRef(); - Protos.HandleInfo h = pinfo.getInfo(); - // Return handle - return new FunctionHandle(handleId, h); - } - - - /** - * Set the verbosity level of the simulator. Higher verbosity levels - * generate more informational and debugging messages. - * - * @param v The verbosity level. Valid values are in the range 0..10 - */ - public synchronized void setVerbosity(int v) throws IOException { - issueRequest(Protos.Request.newBuilder() - .setCode(Protos.RequestCode.SetVerbosity) - .addArg(this.natLiteral(v).getValueRep())); - getNextAckResponse(); - } - - /** - * Returns handle associated with getting a symbolic variable of the - * given type. If a list of dimensions are provided, the returned handle - * will generate a fresh array of the given base type with the given dimensions. - * - * @throws IOException When there was an error when interacting with - * the server. - * @return the handle - */ - public synchronized FunctionHandle getSymbolicHandle(VarType type) - throws IOException { - - Protos.Request.Builder b = Protos.Request.newBuilder() - .setCode(Protos.RequestCode.SymbolicHandle) - .setVarType(type.getProtosRep()); - - issueRequest(b); - return predefinedHandleInfoResponse(); - } - - /** - * This creates a new uninterpreted constant with the type - * type. - * - * @param type the type of fresh constants. - * @return the new constant. - */ - public SimulatorValue freshConstant(VarType type) throws IOException { - try { - return runCall(getSymbolicHandle(type)); - } catch (SimulatorFailedException e) { - throw new Error("Failed to create symbolic variable.", e); - } - } - - - /** - * Returns a predefined function handle with the given name. - * - * @throws IOException When there was an error when interacting with - * the server. In particular, if a function with the given - * name is not found, an exception will be thrown. - * @return the handle - */ - public synchronized FunctionHandle getHandleByName( String name ) throws IOException { - Protos.HandleInfo h = - Protos.HandleInfo.newBuilder() - .setDisplayName(name) - .build(); - - issueRequest(Protos.Request.newBuilder() - .setCode(Protos.RequestCode.GetHandleByName) - .setHandle(h) ); - - return predefinedHandleInfoResponse(); - } - - public synchronized FunctionHandle getMultipartStoreHandle( long addrWidth, long cellWidth, long parts ) - throws IOException { - - Type[] argTypes = { - Type.BOOL, - Type.bitvector( addrWidth ), - Type.bitvector( cellWidth * parts ), - Type.wordMap( addrWidth, Type.bitvector( cellWidth ) ), - }; - Type returnType = Type.wordMap( addrWidth, Type.bitvector( cellWidth ) ); - - Protos.HandleInfo.Builder h - = Protos.HandleInfo.newBuilder() - .setReturnType(returnType.getTypeRep()); - for (Type tp : argTypes) { - h.addArgType(tp.getTypeRep()); - } - issueRequest(Protos.Request.newBuilder() - .setCode(Protos.RequestCode.MultipartStoreHandle) - .setHandle(h.build()) ); - - return predefinedHandleInfoResponse(); - } - - public synchronized FunctionHandle getMultipartLoadHandle( long addrWidth, long cellWidth, long parts ) - throws IOException { - - Type[] argTypes = { - Type.BOOL, - Type.bitvector( addrWidth ), - Type.wordMap( addrWidth, Type.bitvector( cellWidth ) ), - Type.maybe( Type.bitvector( cellWidth ) ) - }; - Type returnType = Type.bitvector( cellWidth * parts ); - - Protos.HandleInfo.Builder h = - Protos.HandleInfo.newBuilder() - .setReturnType(returnType.getTypeRep()); - for (Type tp : argTypes) { - h.addArgType(tp.getTypeRep()); - } - - issueRequest(Protos.Request.newBuilder() - .setCode(Protos.RequestCode.MultipartLoadHandle) - .setHandle(h.build()) ); - - return predefinedHandleInfoResponse(); - } - - public SimulatorValue multipartStore( SimulatorValue isBigEndian, - SimulatorValue addr, - SimulatorValue val, - SimulatorValue map ) - throws IOException { - - long addrWidth = addr.type().width(); - long cellWidth = map.type().wordMapRangeType().width(); - long parts = val.type().width() / cellWidth; - - FunctionHandle storeHandle = getMultipartStoreHandle( addrWidth, cellWidth, parts ); - - return runCall( storeHandle, isBigEndian, addr, val, map ); - } - - public SimulatorValue multipartLoad( SimulatorValue isBigEndian, - SimulatorValue addr, - int parts, - SimulatorValue map ) - throws IOException { - - long addrWidth = addr.type().width(); - long cellWidth = map.type().wordMapRangeType().width(); - - FunctionHandle loadHandle = getMultipartLoadHandle( addrWidth, cellWidth, parts ); - - return runCall( loadHandle, isBigEndian, addr, map, nothingValue(map.type().wordMapRangeType()) ); - } - - public SimulatorValue multipartLoadWithDefault( SimulatorValue isBigEndian, - SimulatorValue addr, - int parts, - SimulatorValue map, - SimulatorValue def ) - throws IOException { - - long addrWidth = addr.type().width(); - long cellWidth = map.type().wordMapRangeType().width(); - - FunctionHandle loadHandle = getMultipartLoadHandle( addrWidth, cellWidth, parts ); - - return runCall( loadHandle, isBigEndian, addr, map, justValue(def) ); - } - - /** - * Returns a predefined function handle for printing terms of the given type. - * @throws IOException When there was an error when interacting with - * the server. In particular, if the given type cannot be printed, - * an exception will be thrown. - * @return the handle - */ - public synchronized FunctionHandle getPrintTermHandle( Type tp ) throws IOException { - issueRequest(Protos.Request.newBuilder() - .setCode(Protos.RequestCode.PrintTermHandle) - .setType( tp.getTypeRep() )); - - return predefinedHandleInfoResponse(); - } - - /** - * Causes the crucible simulator to print the given value. - * @throws IOException If the value cannot be printed. - */ - public void printTerm( SimulatorValue value ) throws IOException { - FunctionHandle printTerm = getPrintTermHandle( value.type() ); - runCall( printTerm, value ); - } - -} diff --git a/crucible-server/java_api/src/main/java/com/galois/crucible/SimulatorAbortedException.java b/crucible-server/java_api/src/main/java/com/galois/crucible/SimulatorAbortedException.java deleted file mode 100644 index 9f397df48..000000000 --- a/crucible-server/java_api/src/main/java/com/galois/crucible/SimulatorAbortedException.java +++ /dev/null @@ -1,21 +0,0 @@ -package com.galois.crucible; - -import java.util.*; - -/** - * SimulatorAbortedException is an exception thrown when calling a simulator - * function failed along all simulator paths. - */ -public class SimulatorAbortedException extends SimulatorFailedException { - final List simMessages; - - SimulatorAbortedException(List simMessages ) { - super("Simulation failed along all paths"); - this.simMessages = simMessages; - } - - public List getMessages() - { - return simMessages; - } -} diff --git a/crucible-server/java_api/src/main/java/com/galois/crucible/SimulatorFailedException.java b/crucible-server/java_api/src/main/java/com/galois/crucible/SimulatorFailedException.java deleted file mode 100644 index 35f501e53..000000000 --- a/crucible-server/java_api/src/main/java/com/galois/crucible/SimulatorFailedException.java +++ /dev/null @@ -1,18 +0,0 @@ -package com.galois.crucible; - -import java.util.*; - -/** - * SimulatorFailedException is an exception called when the simulator fails - * to execute simulated something. - */ -public class SimulatorFailedException extends RuntimeException { - SimulatorFailedException(String message) { - super(message); - } - - SimulatorFailedException(Throwable cause) { - super(cause); - } - -} diff --git a/crucible-server/java_api/src/main/java/com/galois/crucible/SimulatorFunction.java b/crucible-server/java_api/src/main/java/com/galois/crucible/SimulatorFunction.java deleted file mode 100644 index 8df652444..000000000 --- a/crucible-server/java_api/src/main/java/com/galois/crucible/SimulatorFunction.java +++ /dev/null @@ -1,5 +0,0 @@ -package com.galois.crucible; - -public interface SimulatorFunction { - public SimulatorValue run(SimulatorValue[] args); -} diff --git a/crucible-server/java_api/src/main/java/com/galois/crucible/SimulatorMessage.java b/crucible-server/java_api/src/main/java/com/galois/crucible/SimulatorMessage.java deleted file mode 100644 index a439fe37c..000000000 --- a/crucible-server/java_api/src/main/java/com/galois/crucible/SimulatorMessage.java +++ /dev/null @@ -1,70 +0,0 @@ -package com.galois.crucible; - -import java.util.*; -import com.galois.crucible.cfg.Position; -import com.galois.crucible.proto.Protos; - -public class SimulatorMessage { - String message; - List backtrace; - - public SimulatorMessage( String message ) { - this.message = message; - } - - protected SimulatorMessage( String message, List proto_backtrace ) { - this.message = message; - this.backtrace = new LinkedList(); - - for( Protos.Position pp : proto_backtrace ) { - backtrace.add( Position.fromProto( pp ) ); - } - } - - public static SimulatorMessage parsePathAbortedMessage( Protos.PathAbortedMessage msg ) { - String s = msg.getMessage(); - List bt = msg.getBacktraceList(); - - switch( msg.getCode() ) { - case AbortedReadBeforeWrite: - return new ReadBeforeWriteMessage( s, bt ); - case AbortedNonFunction: - return new NonFunctionMessage( s, bt ); - case AbortedUserAssertFailure: - return new UserAssertFailureMessage( s, bt ); - default: - return new SimulatorMessage( s, bt ); - } - } - - - public String getMessage() - { - return message; - } - - public List getBacktrace() - { - if( backtrace == null ) { - backtrace = new LinkedList(); - } - - return backtrace; - } - - public String toString() - { - StringBuilder b = new StringBuilder(); - b.append( this.getClass().getName() ); - b.append( ": "); - b.append( message ); - if( backtrace != null ) { - for( Position p : backtrace ) { - b.append( "\n at " ); - b.append( p.toString() ); - } - } - - return b.toString(); - } -} diff --git a/crucible-server/java_api/src/main/java/com/galois/crucible/SimulatorValue.java b/crucible-server/java_api/src/main/java/com/galois/crucible/SimulatorValue.java deleted file mode 100644 index 8940d54fd..000000000 --- a/crucible-server/java_api/src/main/java/com/galois/crucible/SimulatorValue.java +++ /dev/null @@ -1,13 +0,0 @@ -package com.galois.crucible; -import com.galois.crucible.proto.Protos; - -/** - * Interface that all values in simulator must implement. - */ -public interface SimulatorValue extends Typed { - /** - * Return the Protocol Buffer representation of a simulator value. - * @return the representation - */ - Protos.Value getValueRep(); -} diff --git a/crucible-server/java_api/src/main/java/com/galois/crucible/StringValue.java b/crucible-server/java_api/src/main/java/com/galois/crucible/StringValue.java deleted file mode 100644 index 511b14681..000000000 --- a/crucible-server/java_api/src/main/java/com/galois/crucible/StringValue.java +++ /dev/null @@ -1,32 +0,0 @@ -package com.galois.crucible; -import com.galois.crucible.cfg.Expr; -import com.galois.crucible.proto.Protos; - -/** A constant string in the simulator. */ -public final class StringValue implements Expr, SimulatorValue { - private final String v; - - public StringValue(String v) { - this.v = v; - } - - - /** Returns string type. */ - public Type type() { - return Type.STRING; - } - - public Protos.Expr getExprRep() { - return Protos.Expr.newBuilder() - .setCode(Protos.ExprCode.StringExpr) - .setStringLit(v) - .build(); - } - - public Protos.Value getValueRep() { - return Protos.Value.newBuilder() - .setCode(Protos.ValueCode.StringValue) - .setStringLit(v) - .build(); - } -} diff --git a/crucible-server/java_api/src/main/java/com/galois/crucible/Type.java b/crucible-server/java_api/src/main/java/com/galois/crucible/Type.java deleted file mode 100644 index 99f65dd13..000000000 --- a/crucible-server/java_api/src/main/java/com/galois/crucible/Type.java +++ /dev/null @@ -1,420 +0,0 @@ -package com.galois.crucible; -import java.util.Arrays; -import java.util.ArrayList; -import java.util.HashMap; -import java.util.List; -import java.util.Map; - -import com.galois.crucible.proto.Protos; - -/** - * Crucible expression types - */ -public final class Type { - final Protos.CrucibleTypeId id; - final long width; - final Type[] params; - - /** - * Returns whether simulator supports creating constants with this type. - */ - boolean supportSymbolicConstants() { - return id == Protos.CrucibleTypeId.BoolType - || id == Protos.CrucibleTypeId.NatType - || id == Protos.CrucibleTypeId.BitvectorType; - } - - /** - * Create an array of types from a list of protocol buffer types. - */ - static - Type[] typeArrayFromProtoList(List l) { - Type[] r = new Type[l.size()]; - int cnt=0; - for (Protos.CrucibleType tp : l) { - r[cnt++] = new Type(tp); - } - return r; - } - - - /** A package internal method for creating types from a stream. */ - Type(Protos.CrucibleType type) { - this.id = type.getId(); - this.width = type.getWidth(); - this.params = typeArrayFromProtoList(type.getParamList()); - } - - /** A private method for creating a type with the given args. */ - private Type(Protos.CrucibleTypeId id, long width, Type[] params) { - this.id = id; - this.width = width; - this.params = params; - } - - private Type(Protos.CrucibleTypeId id, Type ... args) { - this.id = id; - this.width = 0; - this.params = args; - } - - public String toString() { - return getTypeRep().toString(); - } - - /** - * The type of unit, which contains a single value. - */ - public static final Type UNIT = new Type(Protos.CrucibleTypeId.UnitType); - - /** - * Type for Boolean values (true or false) - */ - public static final Type BOOL = new Type(Protos.CrucibleTypeId.BoolType); - - /** - * Type for natural numbers. - */ - public static final Type NAT = new Type(Protos.CrucibleTypeId.NatType); - - /** - * Type for positive natural numbers. - */ - public static final Type POS_NAT = new Type(Protos.CrucibleTypeId.PosNatType); - - /** - * Type for integers - */ - public static final Type INTEGER = new Type(Protos.CrucibleTypeId.IntegerType); - - /** - * Type for real numbers - */ - public static final Type REAL = new Type(Protos.CrucibleTypeId.RealType); - - /** - * Type for complex real values. - */ - public static final Type COMPLEX = new Type(Protos.CrucibleTypeId.ComplexType); - - // Cache used for bitvector types. - private static Map bitvectorTypes = new HashMap(); - - /** - * Return a parameter for this type. - * - * @param i Index of parameter. - * @return the parameter - */ - public Type typeParam(int i) { - if (!(0 <= i && i < params.length)) { - throw new IllegalArgumentException("Invalid type parameter."); - } - - return params[i]; - } - - /** - * Returns the type of a bitvector with width bits. - * - * @param width The number of bits in bitvector. - * @return The given type. - */ - public static Type bitvector(long width) { - synchronized (bitvectorTypes) { - Type r = bitvectorTypes.get(width); - if (r == null) { - r = new Type(Protos.CrucibleTypeId.BitvectorType, width, new Type[0]); - bitvectorTypes.put(width, r); - } - return r; - } - } - - /** - * Returns the type of a word map, which maps width bit wide addresses and - * to values of type range. - */ - public static Type wordMap(long width, Type range) { - return new Type( Protos.CrucibleTypeId.WordMapType, width, new Type[] { range } ); - } - - - /** - * Check if this type is a WordMap. - * @return true if this type is WordMap - */ - public boolean isWordMap() { - return id == Protos.CrucibleTypeId.WordMapType; - } - - /** - * Return the range type of a wordmap type. - * @return The range type of this wordmap type. - */ - public Type wordMapRangeType() { - if( id != Protos.CrucibleTypeId.WordMapType ) { - throw new UnsupportedOperationException("Expected wordmap type"); - } - - if( params.length < 1 || params[0] == null ) { - throw new UnsupportedOperationException("Ill-formed wordmap type; no parameter type"); - } - - return params[0]; - } - - /** - * Check if this type is a Struct type - * @return true if this is a Struct type - */ - public boolean isStruct() { - return id == Protos.CrucibleTypeId.StructType; - } - - /** - * Check if this type is Vector(t) for some t. - * @return true if this is a vector type - */ - public boolean isVector() { - return id == Protos.CrucibleTypeId.VectorType; - } - - /** - * Return the element type of a vector type. - * @return The element type of this vector type. - */ - public Type vectorElementType() { - if( id != Protos.CrucibleTypeId.VectorType ) { - throw new UnsupportedOperationException("Expected vector type"); - } - - if( params.length < 1 || params[0] == null ) { - throw new UnsupportedOperationException("Ill-formed vector type; no parameter type"); - } - - return params[0]; - } - - - /** - * Check if this is a bitvector type. - * @return Whether this is a bitvector type. - */ - public boolean isBitvector() { - return id == Protos.CrucibleTypeId.BitvectorType; - } - - /** - * Return width of this type if it is a bitvector, and 0 otherwise. - * @return The width - */ - public long width() { - return width; - } - - /** - * Type for 16-bit IEEE754 floats. - */ - public static final Type HALF_FLOAT = new Type(Protos.CrucibleTypeId.HalfFloatType); - - /** - * Type for 32-bit IEEE754 floats. - */ - public static final Type SINGLE_FLOAT = new Type(Protos.CrucibleTypeId.SingleFloatType); - - /** - * Type for 64-bit IEEE754 floats. - */ - public static final Type DOUBLE_FLOAT = new Type(Protos.CrucibleTypeId.DoubleFloatType); - - /** - * Type for 128-bit IEEE754 floats. - */ - public static final Type QUAD_FLOAT = new Type(Protos.CrucibleTypeId.QuadFloatType); - - /** - * Type for 80-bit x87 extended double floating pount. - */ - public static final Type x86_80_FLOAT = new Type(Protos.CrucibleTypeId.X86_80FloatType); - - /** - * Type for pair of 64-bit floats that are summed together. - */ - public static final Type DOUBLE_DOUBLE_FLOAT = - new Type(Protos.CrucibleTypeId.DoubleDoubleFloatType); - - /** - * Type for single Unicode character. - */ - public static final Type CHAR = new Type(Protos.CrucibleTypeId.CharType); - - /** - * Type for strings of Unicode characters. - */ - public static final Type STRING = new Type(Protos.CrucibleTypeId.StringType); - - // Cache used for function handle types. - private static Map,Type> functionHandleTypes = - new HashMap,Type>(); - - /** - * Type for function handle with given type. - * - * @param args Types of function arguments. - * @param ret Return type of fucntion - * @return Return type - */ - public static final Type functionHandle(Type[] args, Type ret) { - synchronized (functionHandleTypes) { - ArrayList params = new ArrayList(); - params.addAll(Arrays.asList(args)); - params.add(ret); - Type r = functionHandleTypes.get(params); - // If we haven't seen this function handle then replace it. - if (r == null) { - Type[] params_array = params.toArray(new Type[0]); - r = new Type(Protos.CrucibleTypeId.FunctionHandleType, 0, params_array); - functionHandleTypes.put(params, r); - } - return r; - } - } - - /** - * Return whether this is a function handle. - * @return whether this is a handle - */ - public boolean isFunctionHandle() { - return id == Protos.CrucibleTypeId.FunctionHandleType; - } - - /** - * Return the number of arguments expected by function if this - * is a function handle. - * @return the number of arguments. - */ - public int getFunctionArgumentCount() { - assert isFunctionHandle(); - return params.length - 1; - } - - /** - * Return the type of a function at a given 0-based index. - * @param i index of argument - * @return the type - */ - public Type getFunctionArgumentType(int i) { - assert isFunctionHandle(); - if (i < 0 || i >= params.length - 1) { - throw new IllegalArgumentException("Function argument is out of bounds."); - } - return params[i]; - } - - /** - * Return function return type. - * @return the return type - */ - public Type getFunctionReturnType() { - assert isFunctionHandle(); - return params[params.length - 1]; - } - - /** Cache for maybeType */ - private static Map maybeTypes = new HashMap(); - - /** - * Returns type that may contain an element of type e. - * - * @param e The type of that may be contained. - * @return The maybe type. - */ - public static Type maybe(Type e) { - synchronized (maybeTypes) { - Type r = maybeTypes.get(e); - if (r == null) { - r = new Type(Protos.CrucibleTypeId.MaybeType, e); - maybeTypes.put(e, r); - } - return r; - } - } - - public boolean isMaybe() { - return id == Protos.CrucibleTypeId.MaybeType; - } - - private static Map vectorTypes = new HashMap(); - - /** - * A vector whose elements are of type e. - * - * @param e The type of the elements of the vector. - * @return The vector type. - */ - public static Type vector(Type e) { - synchronized (vectorTypes) { - Type r = vectorTypes.get(e); - if (r == null) { - r = new Type(Protos.CrucibleTypeId.VectorType, e); - vectorTypes.put(e, r); - } - return r; - } - } - - private static Map, Type> structTypes = - new HashMap, Type>(); - - /** - * Type for a struct with elements of the given types. - * - * @param fields The types of fields in the struct. - * @return The resulting type. - */ - public static Type struct(Type[] fields) { - synchronized (structTypes) { - List fieldsList = Arrays.asList(fields); - - Type r = structTypes.get(fieldsList); - if (r == null) { - r = new Type(Protos.CrucibleTypeId.StructType, 0, fields); - structTypes.put(fieldsList, r); - } - return r; - } - } - - /** - * Return protocol buffer representation for type. - * @return the representation - */ - public Protos.CrucibleType getTypeRep() { - Protos.CrucibleType.Builder b - = Protos.CrucibleType.newBuilder() - .setId(id) - .setWidth(width); - for (Type param : params) { - b.addParam(param.getTypeRep()); - } - return b.build(); - } - - /** - * Returns true if this and o are the same type. - * @param o the other type. - * @return whether the types are the same. - */ - public boolean equals(Object o) { - if (!(o instanceof Type)) return false; - Type other = (Type) o; - return this.id.equals(other.id) - && this.width == other.width - && Arrays.equals(this.params, other.params); - } - - public int hashCode() { - return Arrays.hashCode(new Object[] { id, width, params }); - } -} diff --git a/crucible-server/java_api/src/main/java/com/galois/crucible/Typed.java b/crucible-server/java_api/src/main/java/com/galois/crucible/Typed.java deleted file mode 100644 index 579b202eb..000000000 --- a/crucible-server/java_api/src/main/java/com/galois/crucible/Typed.java +++ /dev/null @@ -1,12 +0,0 @@ -package com.galois.crucible; - -/** - * An object with a Crucible type associated. - */ -public interface Typed { - /** - * Return type of object. - * @return the type - */ - Type type(); -} diff --git a/crucible-server/java_api/src/main/java/com/galois/crucible/UnitValue.java b/crucible-server/java_api/src/main/java/com/galois/crucible/UnitValue.java deleted file mode 100644 index 97e232b8b..000000000 --- a/crucible-server/java_api/src/main/java/com/galois/crucible/UnitValue.java +++ /dev/null @@ -1,36 +0,0 @@ -package com.galois.crucible; -import com.galois.crucible.cfg.Expr; -import com.galois.crucible.proto.Protos; - -/** This represents the unit value. */ -public final class UnitValue implements Expr, SimulatorValue { - public UnitValue() {} - - public Type type() { - return Type.UNIT; - } - - public Protos.Expr getExprRep() { - return Protos.Expr.newBuilder() - .setCode(Protos.ExprCode.UnitExpr) - .build(); - } - - public Protos.Value getValueRep() { - return Protos.Value.newBuilder() - .setCode(Protos.ValueCode.UnitValue) - .build(); - } - - public String toString() { - return "()"; - } - - public boolean equals(Object o) { - return (o instanceof UnitValue); - } - - public int hashCode() { - return 0; - } -} diff --git a/crucible-server/java_api/src/main/java/com/galois/crucible/UserAssertFailureMessage.java b/crucible-server/java_api/src/main/java/com/galois/crucible/UserAssertFailureMessage.java deleted file mode 100644 index ad274b971..000000000 --- a/crucible-server/java_api/src/main/java/com/galois/crucible/UserAssertFailureMessage.java +++ /dev/null @@ -1,19 +0,0 @@ -package com.galois.crucible; - -import java.util.*; -import com.galois.crucible.cfg.Position; -import com.galois.crucible.proto.Protos; - -/** - This path aborted message is returned when an explicit assertion (i.e., an assert statement - in a CFG) fails. -*/ -public class UserAssertFailureMessage extends SimulatorMessage { - public UserAssertFailureMessage( String message, List proto_backtrace ) { - super(message, proto_backtrace); - } - public UserAssertFailureMessage( String message ) { - super(message); - } -} - diff --git a/crucible-server/java_api/src/main/java/com/galois/crucible/Utils.java b/crucible-server/java_api/src/main/java/com/galois/crucible/Utils.java deleted file mode 100644 index dd78c68e1..000000000 --- a/crucible-server/java_api/src/main/java/com/galois/crucible/Utils.java +++ /dev/null @@ -1,60 +0,0 @@ -package com.galois.crucible; -import java.io.IOException; -import java.io.OutputStream; -import java.math.BigInteger; -import java.util.Iterator; - -import com.galois.crucible.proto.Protos; - -class Utils { - private Utils() {} - - /* - public static - void writeIterableWithSize(OutputStream s, - int size, - Iterable l) throws IOException { - writeVaruint(s,size); - Iterator i = l.iterator(); - while (size > 0) { - assert i.hasNext(); - T e = i.next(); - e.serialize(s); - --size; - } - } - - public static - void writeArray(OutputStream s, T[] l) throws IOException { - int size = l.length; - writeVaruint(s,size); - for (int i = 0; i != size; ++i) { - l[i].serialize(s); - } - } - */ - - static void writeString(OutputStream s, String v) throws IOException { - s.write(v.getBytes("UTF-8")); - s.write(0); // Add null terminator. - } - - - /** - * Write a varint to stream. - */ - static void writeVaruint(OutputStream s, long i) throws IOException { - assert i >= 0; - - boolean c; - do { - // Get 7 low order bits; - int next = (int) (i & 0x7f); - i = i >>> 7; - // Get whether we should continue - c = i > 0; - // Write byte - s.write((c ? 0x80 : 0) | next); - } while (c); - } -} diff --git a/crucible-server/java_api/src/main/java/com/galois/crucible/ValueCreator.java b/crucible-server/java_api/src/main/java/com/galois/crucible/ValueCreator.java deleted file mode 100644 index dbe37b50a..000000000 --- a/crucible-server/java_api/src/main/java/com/galois/crucible/ValueCreator.java +++ /dev/null @@ -1,845 +0,0 @@ -package com.galois.crucible; -import java.math.BigInteger; -import java.io.IOException; - -import com.galois.crucible.proto.Protos; - -/** - * Provides methods for applying primitive operations to values with - * type T. - * - * It requires subclasses to implement applyPrimitive, - * and then they can automatically inherit a large set of operations. - */ -public abstract class ValueCreator { - /** - * Apply the primitive operation to the given arguments. - * @param res Type of result - */ - protected - abstract - T applyPrimitive(Type res, Protos.PrimitiveOp op, Object... args); - - public abstract T bvLiteral( long width, BigInteger val ); - public abstract T natLiteral( BigInteger val ); - public abstract T boolLiteral( boolean val ); - - public abstract T callHandle( FunctionHandle hdl, Object... args ); - - public T natLiteral( long val ) - { - return natLiteral( BigInteger.valueOf(val) ); - } - - public T bvLiteral( long width, long val ) - { - return bvLiteral( width, BigInteger.valueOf(val) ); - } - - /** Complement Boolean value. */ - public T not(T x) { - if (!x.type().equals(Type.BOOL)) - throw new UnsupportedOperationException("not expects a Boolean argument."); - return applyPrimitive(Type.BOOL, Protos.PrimitiveOp.BoolNot, x); - } - - /** And two Boolean values. */ - public T and(T x, T y) { - if (!x.type().equals(Type.BOOL)) - throw new UnsupportedOperationException("and expects Boolean arguments."); - if (!y.type().equals(Type.BOOL)) - throw new UnsupportedOperationException("and expects Boolean arguments."); - return applyPrimitive(Type.BOOL, Protos.PrimitiveOp.BoolAnd, x, y); - } - - /** Inclusive-or of two Boolean values. */ - public T or(T x, T y) { - if (!x.type().equals(Type.BOOL)) - throw new UnsupportedOperationException("or expects Boolean arguments."); - if (!y.type().equals(Type.BOOL)) - throw new UnsupportedOperationException("or expects Boolean arguments."); - return not(and(not(x), not(y))); - } - - /** Exclusive-or of two Boolean values. */ - public T xor(T x, T y) { - if (!x.type().equals(Type.BOOL)) - throw new UnsupportedOperationException("xor expects Boolean arguments."); - if (!y.type().equals(Type.BOOL)) - throw new UnsupportedOperationException("xor expects Boolean arguments."); - return applyPrimitive(Type.BOOL, Protos.PrimitiveOp.BoolXor, x, y); - } - - /** - * if-then-else applied to values with the same type. - * We currently support Booleans, natural numbers, integers, real - * numbers, and bitvectors. - */ - public T ite(T c, T x, T y) { - if (!c.type().equals(Type.BOOL)) - throw new UnsupportedOperationException("ite expects Boolean condition."); - Type type = x.type(); - if (!type.equals(y.type())) - throw new UnsupportedOperationException("ite expects cases to have same type."); - - Protos.PrimitiveOp op; - if (type.equals(Type.BOOL)) { - op = Protos.PrimitiveOp.BoolIte; - } else if (type.equals(Type.REAL)) { - op = Protos.PrimitiveOp.RealIte; - } else if (type.isBitvector()) { - op = Protos.PrimitiveOp.BVIte; - } else { - throw new UnsupportedOperationException("Unsupported type given to ite."); - } - - return applyPrimitive(type, op, c, x, y); - } - - /** Convert argument to a real. */ - public T convertToReal(T x) { - Type x_type = x.type(); - if (x_type.equals(Type.REAL)) { - return x; - } else if (x_type.equals(Type.INTEGER)) { - return applyPrimitive(Type.REAL, Protos.PrimitiveOp.IntegerToReal, x); - } else if (x_type.equals(Type.NAT)) { - x = applyPrimitive(Type.INTEGER, Protos.PrimitiveOp.NatToInteger, x); - return applyPrimitive(Type.REAL, Protos.PrimitiveOp.IntegerToReal, x); - } else { - throw new UnsupportedOperationException("convertToReal given unsupported type."); - } - } - - /** Convert argument to an integer. */ - public T convertToInteger(T x) { - Type x_type = x.type(); - if (x_type.equals(Type.INTEGER)) { - return x; - } else if (x_type.equals(Type.NAT)) { - return applyPrimitive(Type.INTEGER, Protos.PrimitiveOp.NatToInteger, x); - } else { - throw new UnsupportedOperationException("convertToReal given unsupported type."); - } - } - - /** Return true if type is Nat integer or Real */ - private static boolean isNatIntegerOrReal(Type type) { - return type.equals(Type.NAT) - || type.equals(Type.INTEGER) - || type.equals(Type.REAL); - } - - /** - * Add two values. - * - * This procedure performs some implicit coercisions as follows: - * * If both arguments are natural numbers, integers, and real numbers, then the - * results may be added subject to the following conversions: - * 1. If either argument is a real or integer, then the values are converted - * to reals as needed, and the result is a real. - * 2. Otherwise, both arguments must be natural numbers, and the result is a - * Nat. - * * If both arguments are bitvectors with the same size, then the numbers are - * added. Overflow bits are discarded. - * If neither of these conditions are satisfied, then add throws an - * UnsupportedOperationException. - */ - public T add(T x, T y) { - Type x_type = x.type(); - Type y_type = y.type(); - - if (isNatIntegerOrReal(x_type)) { - if (!isNatIntegerOrReal(y_type)) { - throw new UnsupportedOperationException("add given incompatible types."); - } - if (x_type.equals(Type.REAL) || y_type.equals(Type.REAL)) { - x = convertToReal(x); - y = convertToReal(y); - return applyPrimitive(Type.REAL, Protos.PrimitiveOp.RealAdd, x, y); - } else if (x_type.equals(Type.INTEGER) || y_type.equals(Type.INTEGER)) { - x = convertToInteger(x); - y = convertToInteger(y); - return applyPrimitive(Type.INTEGER, Protos.PrimitiveOp.IntegerAdd, x, y); - } else { // Both should be nats - assert (x_type.equals(Type.NAT)); - assert (y_type.equals(Type.NAT)); - return applyPrimitive(Type.NAT, Protos.PrimitiveOp.NatAdd, x, y); - } - } else if (x_type.isBitvector()) { - if (!y_type.equals(x_type)) { - throw new UnsupportedOperationException("add given incompatible types."); - } - return applyPrimitive(x_type, Protos.PrimitiveOp.BVAdd, x, y); - } else { - throw new UnsupportedOperationException("add given unsupported type."); - } - } - - /** - * Subtract one value from another. - */ - public T sub(T x, T y) { - Type x_type = x.type(); - Type y_type = y.type(); - - if (isNatIntegerOrReal(x_type)) { - if (!isNatIntegerOrReal(y_type)) { - throw new UnsupportedOperationException("sub given incompatible types."); - } - if (x_type.equals(Type.REAL) || y_type.equals(Type.REAL)) { - x = convertToReal(x); - y = convertToReal(y); - return applyPrimitive(Type.REAL, Protos.PrimitiveOp.RealSub, x, y); - } else { - x = convertToInteger(x); - y = convertToInteger(y); - return applyPrimitive(Type.INTEGER, Protos.PrimitiveOp.IntegerSub, x, y); - } - } else if (x_type.isBitvector()) { - if (!y_type.equals(x_type)) { - throw new UnsupportedOperationException("sub given incompatible types."); - } - return applyPrimitive(x_type, Protos.PrimitiveOp.BVSub, x, y); - } else { - throw new UnsupportedOperationException("sub given unsupported type."); - } - } - - /** - * Check if values are equal. - * @param x first value - * @param y second value - * @return boolean value - */ - public T eq(T x, T y) { - Type x_type = x.type(); - Type y_type = x.type(); - if (!x_type.equals(y_type)) { - throw new UnsupportedOperationException("Values to eq must have same type."); - } - - if (x_type.equals(Type.BOOL)) { - return not(xor(x, y)); - } else if (x_type.equals(Type.NAT)) { - return applyPrimitive(Type.BOOL, Protos.PrimitiveOp.NatEq, x, y); - } else if (x_type.equals(Type.INTEGER)) { - return applyPrimitive(Type.BOOL, Protos.PrimitiveOp.IntegerEq, x, y); - } else if (x_type.equals(Type.REAL)) { - return applyPrimitive(Type.BOOL, Protos.PrimitiveOp.RealEq, x, y); - } else if (x_type.isBitvector()) { - return applyPrimitive(Type.BOOL, Protos.PrimitiveOp.BVEq, x, y); - } else { - throw new UnsupportedOperationException("eq given unsupported type."); - } - } - - // ************** Bitvector ops *************** - - - /** - * Apply a binary operation on bitvectors. The two expressions - * must both be of the same bitvector type, and the result is of the same type. - */ - private T bvbinop( Protos.PrimitiveOp op, T x, T y ) - { - Type x_type = x.type(); - Type y_type = y.type(); - - if( !(x_type.isBitvector() && x_type.equals(y_type) ) ) { - throw new UnsupportedOperationException("binary bitvetor operation given unsupported types" + - x_type.toString() + " " + y_type.toString() ); - } - - return applyPrimitive( x_type, op, x, y ); - } - - /** - * Apply a binary comparison operator to bitvectors. The two expressions - * must both be of the same bitvector type. - */ - private T bvcmpop( Protos.PrimitiveOp op, T x, T y ) - { - Type x_type = x.type(); - Type y_type = y.type(); - - if( !(x_type.isBitvector() && x_type.equals(y_type) ) ) { - throw new UnsupportedOperationException("binary bitvector comparison operation given unsupported types" + - x_type.toString() + " " + y_type.toString() ); - } - - return applyPrimitive( Type.BOOL, op, x, y ); - } - - /** - * Apply a _signed_ binary comparison operator to bitvectors. The two expressions - * must both be of the same bitvector type, and must be of nonzero width. - */ - private T bvscmpop( Protos.PrimitiveOp op, T x, T y ) - { - Type x_type = x.type(); - Type y_type = y.type(); - - if( !(x_type.isBitvector() && x_type.width() > 0 && x_type.equals(y_type) ) ) { - throw new UnsupportedOperationException("signed binary bitvector comparison operation given unsupported types" + - x_type.toString() + " " + y_type.toString() ); - } - - return applyPrimitive( Type.BOOL, op, x, y ); - } - - /** - * Bitvector addition. - * @param x - * @param y - */ - public T bvAdd( T x, T y ) { - return bvbinop( Protos.PrimitiveOp.BVAdd, x, y ); - } - - /** - * Bitvector subtraction. - * @param x - * @param y - */ - public T bvSub( T x, T y ) { - return bvbinop( Protos.PrimitiveOp.BVSub, x, y ); - } - - /** - * Bitvector multiplication. - * @param x - * @param y - */ - public T bvMul( T x, T y ) { - return bvbinop( Protos.PrimitiveOp.BVMul, x, y ); - } - - /** - * Bitvector unsigned division - * @param x - * @param y - */ - public T bvUdiv( T x, T y ) { - return bvbinop( Protos.PrimitiveOp.BVUdiv, x, y ); - } - - /** - * Bitvector signed division - * @param x - * @param y - */ - public T bvSdiv( T x, T y ) { - return bvbinop( Protos.PrimitiveOp.BVSdiv, x, y ); - } - - /** - * Bitvector unsigned remainder - * @param x - * @param y - */ - public T bvUrem( T x, T y ) { - return bvbinop( Protos.PrimitiveOp.BVUrem, x, y ); - } - - /** - * Bitvector signed remainder - * @param x - * @param y - */ - public T bvSrem( T x, T y ) { - return bvbinop( Protos.PrimitiveOp.BVSrem, x, y ); - } - - /** - * If-then-else for bitvectors. - * @param c the boolean value to branch on - * @param x the "then" value - * @param y the "else" value - */ - public T bvIte( T c, T x, T y ) { - Type c_type = c.type(); - Type x_type = x.type(); - Type y_type = y.type(); - - if( !(c_type.equals(Type.BOOL)) ) { - throw new UnsupportedOperationException("First argument of bvIte is required to be a boolean, but was in fact " + - c_type.toString() ); - } - - if( !(x_type.isBitvector() && x_type.equals(y_type)) ) { - throw new UnsupportedOperationException("Invalid types passed to bvIte" + - x_type.toString() + " " + x_type.toString() ); - } - - return applyPrimitive( x_type, Protos.PrimitiveOp.BVIte, c, x, y ); - } - - /** - * Compare two bitvectors for equality. - * @param x First parameter - * @param y Second parameter - * @return true iff x is equal to y - */ - public T bvEq( T x, T y ) { - return bvcmpop( Protos.PrimitiveOp.BVEq, x, y ); - } - - /** - * Unsigned less-than-or-equal test. - * @param x - * @param y - * @return true iff x <= y when x and y are interpreted as unsigned values - */ - public T bvUle( T x, T y ) { - return bvcmpop( Protos.PrimitiveOp.BVUle, x, y ); - } - - /** - * Unsigned less-than test. - * @param x - * @param y - * @return true iff x < y when x and y are interpreted as unsigned values - */ - public T bvUlt( T x, T y ) { - return bvcmpop( Protos.PrimitiveOp.BVUlt, x, y ); - } - - /** - * Signed less-than-or-equal test. - * @param x - * @param y - * @return true iff x <= y when x and y are interpreted as 2's complement signed values - */ - public T bvSle( T x, T y ) { - return bvscmpop( Protos.PrimitiveOp.BVSle, x, y ); - } - - /** - * Signed less-than test. - * @param x - * @param y - * @return true iff x < y when x and y are interpreted as 2's complement signed values - */ - public T bvSlt( T x, T y ) { - return bvscmpop( Protos.PrimitiveOp.BVSlt, x, y ); - } - - /** - * Shift left. - * @param x - * @param y - * @return The value x shifted left by y bits. Zeros are shifted into the least significant bits. - */ - public T bvShl( T x, T y ) { - return bvbinop( Protos.PrimitiveOp.BVShl, x, y ); - } - - /** - * Logical shift right. - * @param x - * @param y - * @return The value x shifted right by y bits. Zeros are shifted into the most significant bits. - */ - public T bvLshr( T x, T y ) { - return bvbinop( Protos.PrimitiveOp.BVLshr, x, y ); - } - - /** - * Arithmetic shift right. - * @param x - * @param y - * @return The value x shifted right by y bits. The most significant bit of x is replicated as the value is shifted. - */ - public T bvAshr( T x, T y ) { - return bvbinop( Protos.PrimitiveOp.BVAshr, x, y ); - } - - /** - * Bitwise logical negation. - * @param x - * @return bitvector value with every bit flipped from x - */ - public T bvNot( T x ) { - Type x_type = x.type(); - if( !(x_type.isBitvector()) ) { - throw new UnsupportedOperationException("bvNot operation given unsupported type" + - x_type.toString() ); - } - return applyPrimitive(x_type, Protos.PrimitiveOp.BVNot, x ); - } - - /** - * Bitwise logical conjunction. - * @param x - * @param y - */ - public T bvAnd( T x, T y ) { - return bvbinop(Protos.PrimitiveOp.BVAnd, x, y ); - } - - /** - * Bitwise logical disjunction. - * @param x - * @param y - */ - public T bvOr( T x, T y ) { - return bvbinop(Protos.PrimitiveOp.BVOr, x, y ); - } - - /** - * Bitwise logical exclusive or. - * @param x - * @param y - */ - public T bvXor( T x, T y ) { - return bvbinop(Protos.PrimitiveOp.BVXor, x, y ); - } - - /** - * Truncate a bitvector to the given width. The target width must be - * no more than the width of x. - * @param x the value to truncate - * @param w the target width - * @return x truncated to w bits - */ - public T bvTrunc( T x, long w ) { - Type x_type = x.type(); - if( !(x_type.isBitvector()) ) { - throw new UnsupportedOperationException("bvTrunc given unsupported type " + - x_type.toString() ); - } - - if( !(0 <= w && w <= x_type.width()) ) { - throw new UnsupportedOperationException("invalid trunctaction of type " + - x_type.toString() + " to length " + w ); - } - - return applyPrimitive( Type.bitvector(w), Protos.PrimitiveOp.BVTrunc, x ); - } - - /** - * Zero-extend a bitvector to the given width. The target width must be - * no less than the width of x. - * @param x the value to truncate - * @param w the target width - * @return x zero-extended to w bits - */ - public T bvZext( T x, long w ) { - Type x_type = x.type(); - if( !(x_type.isBitvector()) ) { - throw new UnsupportedOperationException("bvZext given unsupported type " + - x_type.toString() ); - } - - if( !(x_type.width() <= w) ) { - throw new UnsupportedOperationException("invalid zero extension of type " + - x_type.toString() + " to length " + w ); - } - - return applyPrimitive( Type.bitvector(w), Protos.PrimitiveOp.BVZext, x ); - } - - /** - * Sign-extend a bitvector to the given width. The target width must be - * no less than the width of x (which must be at least 1) - * @param x the value to truncate - * @param w the target width - * @return x zero-extended to w bits - */ - public T bvSext( T x, long w ) { - Type x_type = x.type(); - if( !(x_type.isBitvector() && x_type.width() >= 1) ) { - throw new UnsupportedOperationException("bvSext given unsupported type " + - x_type.toString() ); - } - - if( !(x_type.width() <= w) ) { - throw new UnsupportedOperationException("invalid zero extension of type " + - x_type.toString() + " to length " + w ); - } - - return applyPrimitive( Type.bitvector(w), Protos.PrimitiveOp.BVZext, x ); - } - - /** - * Select a subsequence from a bitvector. Take n bits starting at index idx - * (counting from the least-significant bit as 0) from the bitvector x. x must - * be a bitvector with width at least idx + n . - * @param idx the index to begin selecting bits (least significant bit is 0) - * @param n the number of bits to take - * @param x the bitvector from which to select - * @return the n-bit subsequence of x starting at idx - */ - public T bvSelect( int idx, int n, T x ) { - Type x_type = x.type(); - - if( !(x_type.isBitvector()) ) { - throw new UnsupportedOperationException("bvSelect given unsupported type " + - x_type.toString() ); - } - - if( !(0 <= idx && 0 <= n && idx + n <= x_type.width() ) ) { - throw new UnsupportedOperationException("bvSelect subsequence out of bounds " + - idx + " " + n + " " + x_type.toString() ); - } - - return applyPrimitive( Type.bitvector( n ), - Protos.PrimitiveOp.BVSelect, - natLiteral(idx), - natLiteral(n), - x ); - } - - /** - * Concatenate two bitvectors - * @param x high-order bitvector of width m - * @param y low-order bitvector of width n - * @return concatenated bitvector of width (m+n) - */ - public T bvConcat( T x, T y ) { - Type x_type = x.type(); - Type y_type = y.type(); - if( !(x_type.isBitvector() && y_type.isBitvector()) ) { - throw new UnsupportedOperationException("bvConcat given unsupported types " + - x_type.toString() + " " + y_type.toString() ); - } - - Type ret_type = Type.bitvector( x_type.width() + y_type.width() ); - - return applyPrimitive( ret_type, Protos.PrimitiveOp.BVConcat, x, y ); - } - - /** - * Concatenate a sequence of bitvectors together in bigendian format. That is, - * index 0 contains the high order bits and index (N-1) contains the low-order bits. - * If xs contains 0 elements, the 0-width bitvector is returned. If xs contains - * 1 element, it is returned unchanged. - * @param xs An array of bitvectors to concatenate - * @return concateneated bitvector - */ - public T bvConcat( T[] xs ) { - if( xs.length == 0 ) { return bvLiteral( 0, BigInteger.ZERO ); } - - // Note: this loop structure is designed to produce a right-associated - // sequence of binary bvConcat operations. It's not clear that this - // actually matters... - - int i = xs.length - 1; - T acc = xs[i]; - while( i > 0 ) { - i--; - acc = bvConcat( xs[i], acc ); - } - - return acc; - } - - public T bvNonzero( T x ) { - Type x_type = x.type(); - if( !(x_type.isBitvector()) ) { - throw new UnsupportedOperationException("bvNonzero given unsupported type " + - x_type.toString() ); - } - - return applyPrimitive( Type.BOOL, Protos.PrimitiveOp.BVNonzero, x ); - } - - public T bvCarry( T x, T y ) { - return bvcmpop( Protos.PrimitiveOp.BVCarry, x, y ); - } - - public T bvSCarry( T x, T y ) { - return bvscmpop( Protos.PrimitiveOp.BVSCarry, x, y ); - } - - public T bvSBorrow( T x, T y ) { - return bvscmpop( Protos.PrimitiveOp.BVSBorrow, x, y ); - } - - public T boolToBV( T x, long width ) { - Type x_type = x.type(); - if( !x_type.equals( Type.BOOL ) ) { - throw new UnsupportedOperationException("boolToBV given unsupported type " + - x_type.toString() ); - } - - if( !(width >= 0) ) { - throw new UnsupportedOperationException("boolToBV given negative width " + width); - } - - return applyPrimitive( Type.bitvector(width), Protos.PrimitiveOp.BoolToBV, x ); - } - - - // ************** Vector ops *************** - public T vectorLit( Type type, T... xs ) throws Exception { - for(int i=0; i dimensions; - - /** A package internal method for creating types from a stream. */ - VarType(Protos.VarType type) { - this.id = type.getId(); - this.width = type.getWidth(); - this.dimensions = type.getDimensionList(); - } - - /** A private method for creating a type. */ - private VarType(Protos.VarTypeId id) { - this.id = id; - this.width = 0; - this.dimensions = null; - } - - /** A private method for creating a type with the given width. */ - private VarType(Protos.VarTypeId id, long width) { - this.id = id; - this.width = width; - this.dimensions = null; - } - - private VarType(Protos.VarTypeId id, long width, List dimensions) { - this.id = id; - this.width = width; - this.dimensions = dimensions; - } - - /** - * Boolean values (true or false) - */ - public static final VarType BOOL = new VarType(Protos.VarTypeId.BoolVarType); - - /** - * Type for integers - */ - public static final VarType INTEGER = new VarType(Protos.VarTypeId.IntegerVarType); - - /** - * Type for real numbers - */ - public static final VarType REAL = new VarType(Protos.VarTypeId.RealVarType); - - /** - * Returns the type of a bitvector with width bits. - * - * @param width The number of bits in bitvector. - * @return The given type. - */ - public static VarType bitvector(long width) { - return new VarType(Protos.VarTypeId.BitvectorVarType, width); - } - - public static VarType vector( long n, VarType t ) { - LinkedList d = null; - if( t.dimensions == null ) { - d = new LinkedList(); - d.addFirst( n ); - } else { - d = new LinkedList( t.dimensions ); - d.addFirst( n ); - } - - return new VarType( t.id, t.width, d ); - } - - /** - * Get representation of VarType in protocol buffer format. - */ - Protos.VarType getProtosRep() { - Protos.VarType.Builder b = Protos.VarType.newBuilder() - .setId(id) - .setWidth(width); - - if( dimensions != null ) { - b.addAllDimension( dimensions ); - } - - return b.build(); - } - - /** Compare if object equals this. */ - public boolean equals(Object o) { - if (!(o instanceof VarType)) return false; - VarType other = (VarType) o; - return this.id.equals(other.id) - && this.width == other.width; - } - - /** Hash fields together. */ - public int hashCode() { - return Arrays.hashCode( new Object[] { id, width } ); - } -} diff --git a/crucible-server/java_api/src/main/java/com/galois/crucible/VerificationHarness.java b/crucible-server/java_api/src/main/java/com/galois/crucible/VerificationHarness.java deleted file mode 100644 index 64ee25683..000000000 --- a/crucible-server/java_api/src/main/java/com/galois/crucible/VerificationHarness.java +++ /dev/null @@ -1,127 +0,0 @@ -package com.galois.crucible; - -import com.galois.crucible.proto.Protos; - -public class VerificationHarness { - private Protos.VerificationHarness.Builder harness; - private StateSpecification innerPrestate; - private StateSpecification innerPoststate; - - private static Protos.VariableSpecification newVar( String name, int width ) { - return Protos.VariableSpecification.newBuilder(). - setName(name). - addDimension(width). - build(); - } - - private static Protos.VariableSpecification newVar( String name, int elems, int width ) { - return Protos.VariableSpecification.newBuilder(). - setName(name). - addDimension(elems). - addDimension(width). - build(); - } - - private static Protos.VariableBinding newVariableBinding( Protos.VariableReference ref, String expr ) { - return Protos.VariableBinding.newBuilder(). - setVar( ref ). - setExpr( expr ). - build(); - } - - private static Protos.RegisterAssignment newRegisterAssignment( long offset, Protos.VariableReference value ) { - return Protos.RegisterAssignment.newBuilder(). - setRegOffset( offset ). - setValue( value ). - build(); - } - - private static Protos.MemoryAssignment newMemoryAssignment( Protos.VariableReference base, - long offset, - Protos.VariableReference value ) { - return Protos.MemoryAssignment.newBuilder(). - setBase( base ). - setOffset( offset ). - setValue( value ). - build(); - } - - public static Protos.VariableReference userVar( String name ) { - return Protos.VariableReference.newBuilder(). - setCode( Protos.VariableReferenceCode.UserVar ). - setVarName( name ). - build(); - } - - public static final Protos.VariableReference stackVar = - Protos.VariableReference.newBuilder(). - setCode( Protos.VariableReferenceCode.StackPointerVar ). - build(); - - public static final Protos.VariableReference returnVar = - Protos.VariableReference.newBuilder(). - setCode( Protos.VariableReferenceCode.ReturnAddressVar ). - build(); - - public class StateSpecification { - Protos.StateSpecification.Builder specBuilder; - - StateSpecification( Protos.StateSpecification.Builder specBuilder ) { - this.specBuilder = specBuilder; - } - - public Protos.VariableReference addVar( String name, int width ) { - specBuilder.addVariable( newVar( name, width ) ); - return userVar( name ); - } - - public Protos.VariableReference addVar( String name, int elems, int width ) { - specBuilder.addVariable( newVar( name, elems, width ) ); - return userVar( name ); - } - - public void assignRegister( long offset, Protos.VariableReference var ) { - specBuilder.addRegisterAssignment( newRegisterAssignment( offset, var ) ); - } - - public void assignMemory( Protos.VariableReference base, - long offset, - Protos.VariableReference value ) { - specBuilder.addMemoryAssignment( newMemoryAssignment( base, offset, value ) ); - } - - public void bindVariable( Protos.VariableReference var, String expr ) { - specBuilder.addVariableBinding( newVariableBinding( var, expr ) ); - } - - public void assertCondition( String expr ) { - specBuilder.addCondition( expr ); - } - } - - public VerificationHarness(String name, int regFileWidth, int addrWidth, Protos.Endianness endianness) { - this.harness = Protos.VerificationHarness.newBuilder(); - harness.setName(name); - harness.setRegFileWidth(regFileWidth); - harness.setAddressWidth(addrWidth); - harness.setEndianness(endianness); - this.innerPrestate = new StateSpecification( harness.getPrestateSpecificationBuilder() ); - this.innerPoststate = new StateSpecification( harness.getPoststateSpecificationBuilder() ); - } - - public void addCryptolSource( String fname ) { - harness.addCryptolSource( fname ); - } - - public Protos.VerificationHarness getRep() { - return harness.build(); - } - - public StateSpecification prestate() { - return innerPrestate; - } - - public StateSpecification poststate() { - return innerPoststate; - } -} diff --git a/crucible-server/java_api/src/main/java/com/galois/crucible/VerificationOptions.java b/crucible-server/java_api/src/main/java/com/galois/crucible/VerificationOptions.java deleted file mode 100644 index 674e87cf9..000000000 --- a/crucible-server/java_api/src/main/java/com/galois/crucible/VerificationOptions.java +++ /dev/null @@ -1,73 +0,0 @@ -package com.galois.crucible; - -import com.galois.crucible.cfg.Procedure; -import com.galois.crucible.proto.Protos; - -public class VerificationOptions { - private Protos.VerificationSimulateOptions.Builder opts; - - public VerificationOptions() { - opts = Protos.VerificationSimulateOptions.newBuilder(); - opts.setSeparateObligations( false ); - } - - /** - * Set the starting value of the PC. This indicates where to begin - * symbolic simulation, and is typically the entry point for a function. - */ - public void setStartPC( SimulatorValue v ) { - opts.setStartPc( v.getValueRep() ); - } - - /** - * Set the value to be used as the return address. This should not be - * the location of any valid instruction in the program. Symoblic simulation - * will end when control passes to this value. - */ - public void setReturnAddress( SimulatorValue v ) { - opts.setReturnAddress( v.getValueRep() ); - } - - /** - * Set the starting value of the stack pointer. This should be in an area - * of memory that does not overlap with the program's expected data segment, - * heap, etc. The stack will grow either up or down from here depending on - * the convention of the compiled program. - */ - public void setStartStack( SimulatorValue v ) { - opts.setStartStack( v.getValueRep() ); - } - - /** - * Set the program to simulate. This should be the function handle for - * the translated CFG to verify. - */ - public void setProgram( Procedure proc ) { - opts.setProgram( proc.getHandle().getValueRep() ); - } - - /** - * Set the output directory. The crucible server will produce it's output - * into the given directory path. - */ - public void setOutputDirectory( String path ) { - opts.setOutputDirectory( path ); - } - - /** - * Should the crucible server produce separate files for each generated proof obligation? - * If true, a separte SAWCore file will be generated for each safety condition and postcondition - * statement. If false, all conditions will be combined together into a single file. - * - * This is a tradeoff. Separate obligations may allow solvers to make better progress on individual goals. - * However, a single file allows better subterm sharing in the case that separate goals refer to the same - * subterms (which is fairly common). - */ - public void setSeparateObligations( boolean b ) { - opts.setSeparateObligations( b ); - } - - public Protos.VerificationSimulateOptions getRep() { - return opts.build(); - } -} diff --git a/crucible-server/java_api/src/main/java/com/galois/crucible/cfg/BinaryPosition.java b/crucible-server/java_api/src/main/java/com/galois/crucible/cfg/BinaryPosition.java deleted file mode 100644 index 79868efcd..000000000 --- a/crucible-server/java_api/src/main/java/com/galois/crucible/cfg/BinaryPosition.java +++ /dev/null @@ -1,31 +0,0 @@ -package com.galois.crucible.cfg; - -import com.galois.crucible.proto.Protos; - -public class BinaryPosition extends Position { - String path; - long addr; - - public BinaryPosition( String functionName, String path, long addr ) - { - this.functionName = functionName; - this.path = path; - this.addr = addr; - } - - public Protos.Position getPosRep() - { - return Protos.Position.newBuilder() - .setCode( Protos.PositionCode.BinaryPos ) - .setFunctionName( functionName ) - .setPath( path ) - .setAddr( addr ) - .build(); - } - - public String toString() - { - return path + ": 0x" + Long.toHexString( addr ) + " " + functionName; - } - -} diff --git a/crucible-server/java_api/src/main/java/com/galois/crucible/cfg/Block.java b/crucible-server/java_api/src/main/java/com/galois/crucible/cfg/Block.java deleted file mode 100644 index 08845000d..000000000 --- a/crucible-server/java_api/src/main/java/com/galois/crucible/cfg/Block.java +++ /dev/null @@ -1,31 +0,0 @@ -package com.galois.crucible.cfg; -import com.galois.crucible.proto.Protos; - -/** - * A contiguous set of instructions in a control flow graph. - */ -public final class Block extends SomeBlock { - /** - * Internal method for creating a block - */ - Block(Procedure procedure, int block_index) { - super(procedure, block_index); - } - - public Protos.Block getBlockRep() { - if (termStmt == null) { - String msg = "This block is unterminated."; - if( block_description != null ) { - msg = msg + " " + block_description; - } - throw new IllegalStateException(msg); - } - - return Protos.Block.newBuilder() - .addAllStatement(statements) - .setTermStmt(termStmt) - .setPos( pos ) - .build(); - } - -} diff --git a/crucible-server/java_api/src/main/java/com/galois/crucible/cfg/Expr.java b/crucible-server/java_api/src/main/java/com/galois/crucible/cfg/Expr.java deleted file mode 100644 index f2c73e6f8..000000000 --- a/crucible-server/java_api/src/main/java/com/galois/crucible/cfg/Expr.java +++ /dev/null @@ -1,17 +0,0 @@ -package com.galois.crucible.cfg; -import java.io.IOException; -import java.io.OutputStream; - -import com.galois.crucible.proto.Protos; -import com.galois.crucible.Typed; - -/** - * Interface that all expressions referenced in control flow graph must implement. - */ -public interface Expr extends Typed { - /** - * Return the Protocol Buffer representation of an expression. - * @return the representation - */ - Protos.Expr getExprRep(); -} diff --git a/crucible-server/java_api/src/main/java/com/galois/crucible/cfg/FunctionArg.java b/crucible-server/java_api/src/main/java/com/galois/crucible/cfg/FunctionArg.java deleted file mode 100644 index 11fd83aba..000000000 --- a/crucible-server/java_api/src/main/java/com/galois/crucible/cfg/FunctionArg.java +++ /dev/null @@ -1,30 +0,0 @@ -package com.galois.crucible.cfg; -import com.galois.crucible.proto.Protos; -import com.galois.crucible.Type; - -/** - * An argument to the function. - */ -class FunctionArg implements Expr { - /** The index of the function argument. */ - final long index; - /** The type of the function. */ - final Type type; - - FunctionArg(long index, Type type) { - if (type == null) throw new NullPointerException("type"); - this.index = index; - this.type = type; - } - - public Type type() { - return this.type; - } - - public Protos.Expr getExprRep() { - return Protos.Expr.newBuilder() - .setCode(Protos.ExprCode.FunctionArgExpr) - .setIndex(index) - .build(); - } -} diff --git a/crucible-server/java_api/src/main/java/com/galois/crucible/cfg/InternalPosition.java b/crucible-server/java_api/src/main/java/com/galois/crucible/cfg/InternalPosition.java deleted file mode 100644 index db9551368..000000000 --- a/crucible-server/java_api/src/main/java/com/galois/crucible/cfg/InternalPosition.java +++ /dev/null @@ -1,26 +0,0 @@ -package com.galois.crucible.cfg; - -import com.galois.crucible.proto.Protos; - -public class InternalPosition extends Position { - - public InternalPosition( String functionName ) - { - this.functionName = functionName; - } - - public Protos.Position getPosRep() - { - Protos.Position.Builder b = - Protos.Position.newBuilder(); - - b.setCode( Protos.PositionCode.InternalPos ); - b.setFunctionName( functionName ); - return b.build(); - } - - public String toString() - { - return "internal position: " + functionName; - } -} diff --git a/crucible-server/java_api/src/main/java/com/galois/crucible/cfg/LambdaArg.java b/crucible-server/java_api/src/main/java/com/galois/crucible/cfg/LambdaArg.java deleted file mode 100644 index d8b6718b8..000000000 --- a/crucible-server/java_api/src/main/java/com/galois/crucible/cfg/LambdaArg.java +++ /dev/null @@ -1,29 +0,0 @@ -package com.galois.crucible.cfg; -import com.galois.crucible.proto.Protos; -import com.galois.crucible.Type; - -/** - * An argument passed to a Lambda block. - */ -public final class LambdaArg implements Expr { - private final long block_index; - private final Type type; - - LambdaArg(long block_index, Type type) { - this.block_index = block_index; - this.type = type; - } - - public Type type() { - return type; - } - - public Protos.Expr getExprRep() { - return Protos.Expr.newBuilder() - .setCode(Protos.ExprCode.LambdaArgExpr) - .setBlockId(block_index) - .build(); - } - - -} diff --git a/crucible-server/java_api/src/main/java/com/galois/crucible/cfg/LambdaBlock.java b/crucible-server/java_api/src/main/java/com/galois/crucible/cfg/LambdaBlock.java deleted file mode 100644 index 960abd25f..000000000 --- a/crucible-server/java_api/src/main/java/com/galois/crucible/cfg/LambdaBlock.java +++ /dev/null @@ -1,52 +0,0 @@ -package com.galois.crucible.cfg; -import com.galois.crucible.proto.Protos; -import com.galois.crucible.Type; - -/** - * A block that accepts an argument from the previous block as an input. - * - * Used for pattern matching. - */ -public final class LambdaBlock extends SomeBlock { - private final LambdaArg arg; - - /** Internal method for creating a lambda block. */ - LambdaBlock(Procedure p, int index, Type param_type) { - super(p, index); - this.arg = new LambdaArg(index, param_type); - } - - /** - * Get argument passed to this block. - * @return the argument. - */ - public LambdaArg getArg() { - return arg; - } - - /** - * Return type of argument expected by block. - * @return the type - */ - public Type getArgType() { - return arg.type(); - } - - public Protos.Block getBlockRep() { - if (termStmt == null) { - String msg = "This block is unterminated."; - if( block_description != null ) { - msg = msg + " " + block_description; - } - throw new IllegalStateException(msg); - } - - return Protos.Block.newBuilder() - .setIsLambda(true) - .setLambdaType(arg.type().getTypeRep()) - .addAllStatement(statements) - .setTermStmt(termStmt) - .setPos( pos ) - .build(); - } -} diff --git a/crucible-server/java_api/src/main/java/com/galois/crucible/cfg/Position.java b/crucible-server/java_api/src/main/java/com/galois/crucible/cfg/Position.java deleted file mode 100644 index b3301e3db..000000000 --- a/crucible-server/java_api/src/main/java/com/galois/crucible/cfg/Position.java +++ /dev/null @@ -1,28 +0,0 @@ -package com.galois.crucible.cfg; - -import com.galois.crucible.proto.Protos; - -public abstract class Position { - String functionName; - String getFunctionName() { return functionName; } - - public abstract Protos.Position getPosRep(); - - public static Position fromProto( Protos.Position p ) { - switch( p.getCode() ) { - case InternalPos: - return new InternalPosition( p.getFunctionName() ); - case SourcePos: - return new SourcePosition( p.getFunctionName(), - p.getPath(), - p.getLine(), - p.getCol() ); - case BinaryPos: - return new BinaryPosition( p.getFunctionName(), - p.getPath(), - p.getAddr() ); - default: - throw new Error("Unknown Position code: "+p.getCode()); - } - } -} diff --git a/crucible-server/java_api/src/main/java/com/galois/crucible/cfg/Procedure.java b/crucible-server/java_api/src/main/java/com/galois/crucible/cfg/Procedure.java deleted file mode 100644 index cb93221d9..000000000 --- a/crucible-server/java_api/src/main/java/com/galois/crucible/cfg/Procedure.java +++ /dev/null @@ -1,166 +0,0 @@ -package com.galois.crucible.cfg; -import java.io.IOException; -import java.io.OutputStream; -import java.util.ArrayList; -import java.util.List; - -import com.galois.crucible.Simulator; -import com.galois.crucible.FunctionHandle; -import com.galois.crucible.proto.Protos; -import com.galois.crucible.Type; - -/** - * A control-flow-graph and handle associated to it. - */ -public final class Procedure { - private final FunctionHandle handle; - - /** List of expressions in function. */ - private final List arguments; - - /** List of all registers allocated in Cfg. */ - private final List registers; - - /** Entry block for this procedure. */ - private final Block entryBlock; - - /** List of all blocks allocated in Cfg. */ - private final List blocks; - - /** Position of this procedure */ - private Protos.Position pos; - - /** - * Create a new control-flow graph with a freshly-allocated function handle. - * @param sim simulator object - * @param displayName name attached to the funtion handle - * @param argTypes types of the arguments to the function - * @param returnType type of the return value of the function - */ - public Procedure( Simulator sim, String displayName, Type[] argTypes, Type returnType ) - throws IOException - { - this( sim.newHandle( displayName, argTypes, returnType ) ); - } - - /** - * Create a new control-flow graph. - * @param h the handle associated to procedure - */ - public Procedure(FunctionHandle h) { - this.handle = h; - this.pos = new InternalPosition( h.getDisplayName() ).getPosRep(); - - int argCount = h.getArgCount(); - this.arguments = new ArrayList(argCount); - // Populate argument list. - for (int i = 0; i != argCount; ++i) { - arguments.add(new FunctionArg(i, h.getArgType(i))); - } - - this.registers = new ArrayList(); - this.entryBlock = new Block(this, 0); - this.blocks = new ArrayList(); - this.blocks.add(entryBlock); - } - - /** - * Get the handle associated with this procedure. - * @return the handle - */ - public FunctionHandle getHandle() { - return handle; - } - - /** - * Get first block. - * @return the block - */ - public Block getEntryBlock() { - return entryBlock; - } - - /** - * Return number of arguments expected by procedure. - * @return the number of arguments - */ - public int getArgCount() { - return handle.getArgCount(); - } - - /** - * The the position for this procedure. - */ - public void setPosition( Position pos ) - { - this.pos = pos.getPosRep(); - } - - public Protos.Position getPosition() - { - return this.pos; - } - - /** - * Returns expression representing argument for function. - * @param i the index of the argument. - * @return the argument. - */ - public FunctionArg getArg(int i) { - if (!(0 <= i && i < arguments.size())) { - throw new IllegalArgumentException("Bad argument index."); - } - return arguments.get(i); - } - - /** - * Allocate a new register. - * @param tp the type of the register. - * @return the register - */ - public Reg newReg(Type tp) { - Reg r = new Reg(registers.size(), tp); - registers.add(r); - return r; - } - - /** - * Create a new basic block. - * @return the block - */ - public Block newBlock() { - Block b = new Block(this, blocks.size()); - blocks.add(b); - return b; - } - - /** - * Create a new block that expects an argument when jumped to. - * @param param_type the type of the argument expected by block. - * @return the block - */ - public LambdaBlock newLambdaBlock(Type param_type) { - LambdaBlock b = new LambdaBlock(this, blocks.size(), param_type); - blocks.add(b); - return b; - } - - /** - * Get the Protocol buffer representation. - * @return the representation object. - */ - public Protos.Cfg getCfgRep() { - Protos.Cfg.Builder b - = Protos.Cfg.newBuilder() - .setHandleId(handle.getUniqueId()) - .setPos( pos ); - for (Reg r : registers) { - b.addRegister(r.type().getTypeRep()); - } - for (SomeBlock block : blocks) { - b.addBlock(block.getBlockRep()); - } - return b.build(); - - } -} diff --git a/crucible-server/java_api/src/main/java/com/galois/crucible/cfg/Reg.java b/crucible-server/java_api/src/main/java/com/galois/crucible/cfg/Reg.java deleted file mode 100644 index b3c4b754c..000000000 --- a/crucible-server/java_api/src/main/java/com/galois/crucible/cfg/Reg.java +++ /dev/null @@ -1,34 +0,0 @@ -package com.galois.crucible.cfg; -import java.io.IOException; -import java.io.OutputStream; - -import com.galois.crucible.Type; -import com.galois.crucible.Typed; - -/** - * A mutable register that can be modified during execution. - */ -public final class Reg implements Typed { - private final long index; - private final Type type; - - /** Package level method for creating a register. */ - Reg(long index, Type type) { - this.index = index; - this.type = type; - } - - /** Get index of register. */ - long index() { - return index; - } - - - /** - * Get type of register. - * @return The type. - */ - public Type type() { - return type; - } -} diff --git a/crucible-server/java_api/src/main/java/com/galois/crucible/cfg/SomeBlock.java b/crucible-server/java_api/src/main/java/com/galois/crucible/cfg/SomeBlock.java deleted file mode 100644 index 1e1031f42..000000000 --- a/crucible-server/java_api/src/main/java/com/galois/crucible/cfg/SomeBlock.java +++ /dev/null @@ -1,353 +0,0 @@ -package com.galois.crucible.cfg; -import java.io.OutputStream; -import java.math.BigInteger; -import java.util.ArrayList; -import java.util.Arrays; - -import com.galois.crucible.BitvectorValue; -import com.galois.crucible.BoolValue; -import com.galois.crucible.IntegerValue; -import com.galois.crucible.NatValue; -import com.galois.crucible.FunctionHandle; -import com.galois.crucible.proto.Protos; -import com.galois.crucible.RationalValue; -import com.galois.crucible.SimulatorValue; -import com.galois.crucible.StringValue; -import com.galois.crucible.Type; -import com.galois.crucible.Typed; -import com.galois.crucible.ValueCreator; - -/** - * Common base class for blocks that expect an argument, and blocks that do not. - */ -public abstract class SomeBlock extends ValueCreator { - private final Procedure procedure; - /** The index of this block in the CFG. */ - private final int block_index; - - protected final ArrayList statements; - - public String block_description; - - /** Position of this block */ - protected Protos.Position pos; - - /** Current position used when adding statements */ - protected Protos.Position currentPos; - - /** - * The terminal statement of this block or null - * if it has not been defined. - */ - protected Protos.TermStmt termStmt; - - /** - * Internal method for creating a block - */ - SomeBlock(Procedure procedure, int block_index) { - this.procedure = procedure; - this.block_index = block_index; - this.statements = new ArrayList(); - this.termStmt = null; - this.pos = procedure.getPosition(); - } - - /** - * Get control-flow graph that this block is part of. - */ - public Procedure getProcedure() { - return procedure; - } - - /** Set the position */ - public void setPosition( Position pos ) - { - if( pos == null ) { - throw new IllegalArgumentException("pos cannot be null"); - } - this.pos = pos.getPosRep(); - } - - public void setCurrentPosition( Position pos ) - { - this.currentPos = pos.getPosRep(); - } - - // Check value is non-null and have type equal to tp. - private static void checkTypeEquals(String nm, Typed v, Type tp) { - if (v == null) { - String msg = String.format("%s must not be null.", nm); - throw new NullPointerException(msg); - } - if (!v.type().equals(tp)) { - String msg = String.format("%s has incorrect type. Expected %s, but got %s", nm, tp.toString(), v.type().toString()); - throw new IllegalArgumentException(msg); - } - } - - // Check that f is a function that expects the given arguments. - // Returns type of result of f. - private static Type checkFunctionArgs(Expr f, Expr[] args) { - - if (f == null) throw new NullPointerException("f"); - - Type f_type = f.type(); - - if (!f_type.isFunctionHandle()) { - throw new IllegalArgumentException("function does not have correct type."); - } - - int cnt = f_type.getFunctionArgumentCount(); - if (cnt != args.length) { - throw new IllegalArgumentException("Incorrect number of arguments."); - } - - for (int i = 0; i != cnt; ++i) { - Expr arg = args[i]; - Type type = f_type.getFunctionArgumentType(i); - checkTypeEquals("arg", arg, type); - } - return f_type.getFunctionReturnType(); - } - - private void addStatement(Protos.Statement.Builder stmt) { - if (this.termStmt != null) { - throw new IllegalStateException("This block has already been terminated."); - } - - if( currentPos != null ) { - stmt = stmt.setPos( currentPos ); - } - statements.add(stmt.build()); - } - - private - StatementResult addEvalStmt(Type result_type, - Protos.Statement.Builder stmt) { - - long stmt_index = statements.size(); - // Add statement to list. - addStatement(stmt); - // Get return value. - return new StatementResult(block_index, stmt_index, result_type); - } - - private void setTermStmt(Protos.TermStmt.Builder termStmt) { - if (this.termStmt != null) { - throw new IllegalStateException("This block has already been terminated."); - } - - if( currentPos != null ) { - termStmt = termStmt.setPos( currentPos ); - } - - this.termStmt = termStmt.build(); - } - - - public Expr boolLiteral( boolean val ) - { - if( val ) { - return BoolValue.TRUE; - } else { - return BoolValue.FALSE; - } - } - - public Expr bvLiteral( long width, BigInteger val ) - { - return new BitvectorValue( width, val ); - } - - public Expr natLiteral( BigInteger val ) - { - return new NatValue( val ); - } - - public Expr callHandle( FunctionHandle hdl, Object... args ) - { - return call( hdl, Arrays.copyOf( args, args.length, Expr[].class ) ); - } - - protected - Expr applyPrimitive(Type result_type, - Protos.PrimitiveOp op, - Object... args) { - Protos.Statement.Builder b - = Protos.Statement.newBuilder() - .setCode(Protos.StatementCode.ExecPrimitive) - .setPrimOp(op) - .setResultType(result_type.getTypeRep()); - for (Object e : args) { - b.addExpr(((Expr) e).getExprRep()); - } - // Add statement to list. - return addEvalStmt(result_type, b); - } - - /** - * Read the current value of the register. - */ - public Expr read(Reg r) { - if (r == null) throw new NullPointerException("r"); - return addEvalStmt(r.type(), - Protos.Statement.newBuilder() - .setCode(Protos.StatementCode.ReadReg) - .setReg(r.index())); - } - - /** - * Write the expression to the register. - */ - public void write(Reg lhs, Expr rhs) { - if (lhs == null) throw new NullPointerException("lhs"); - checkTypeEquals("rhs", rhs, lhs.type()); - addStatement(Protos.Statement.newBuilder() - .setCode(Protos.StatementCode.WriteReg) - .setReg(lhs.index()) - .addExpr(rhs.getExprRep())); - } - - /** - * Call a function with the given arguments. - */ - public Expr call(Expr f, Expr... args) { - Type result_type = checkFunctionArgs(f, args); - Protos.Statement.Builder b - = Protos.Statement.newBuilder() - .setCode(Protos.StatementCode.Call) - .addExpr(f.getExprRep()) - .setResultType(result_type.getTypeRep()); - for (Expr e : args) { - b.addExpr(e.getExprRep()); - } - - return addEvalStmt(result_type, b); - } - - /** - * Print a string. - * @param msg String to print - */ - public void print(Expr msg) { - checkTypeEquals("msg", msg, Type.STRING); - - addStatement(Protos.Statement.newBuilder() - .setCode(Protos.StatementCode.Print) - .addExpr(msg.getExprRep())); - } - - /** - * Print a string. - * @param msg String literal to print - */ - public void print(String msg) { - print( new StringValue(msg) ); - } - /** - * Add assertion statement. - */ - public void assertCond(Expr c, Expr m) { - checkTypeEquals("c", c, Type.BOOL); - checkTypeEquals("m", m, Type.STRING); - - addStatement(Protos.Statement.newBuilder() - .setCode(Protos.StatementCode.Assert) - .addExpr(c.getExprRep()) - .addExpr(m.getExprRep())); - } - - - /** - * End block with jump. - */ - public void jump(Block lbl) { - setTermStmt(Protos.TermStmt.newBuilder() - .setCode(Protos.TermStmtCode.JumpTermStmt) - .addBlock(((SomeBlock) lbl).block_index)); - } - - /** - * End block with branch. - */ - public void branch(Expr c, Block t, Block f) { - if (c == null) throw new NullPointerException("c"); - if (!c.type().equals(Type.BOOL)) - throw new IllegalArgumentException("Branch condition must be Boolean."); - - setTermStmt(Protos.TermStmt.newBuilder() - .setCode(Protos.TermStmtCode.BranchTermStmt) - .addExpr(c.getExprRep()) - .addBlock(((SomeBlock) t).block_index) - .addBlock(((SomeBlock) f).block_index)); - } - - /** - * Return from the procedure with the given value. - * @param v Return value - */ - public void returnExpr(Expr v) { - Type return_type = procedure.getHandle().getReturnType(); - checkTypeEquals("v", v, return_type); - - setTermStmt(Protos.TermStmt.newBuilder() - .setCode(Protos.TermStmtCode.ReturnTermStmt) - .addExpr(v.getExprRep())); - } - - /** - * Terminate block with an error message. - * @param msg String to print - */ - public void reportError(Expr msg) { - checkTypeEquals("msg", msg, Type.STRING); - setTermStmt(Protos.TermStmt.newBuilder() - .setCode(Protos.TermStmtCode.ErrorTermStmt) - .addExpr(msg.getExprRep())); - } - - /** - * Terminate block with a tail call. - * @param f Function to call - * @param args Arguments to function - */ - public void tailCall(Expr f, Expr ... args) { - Type f_returnType = checkFunctionArgs(f, args); - Type returnType = procedure.getHandle().getReturnType(); - if (!returnType.equals(f_returnType)) { - throw new IllegalArgumentException( - "Tail called function must return same type of result as caller."); - } - - Protos.TermStmt.Builder b - = Protos.TermStmt.newBuilder() - .setCode(Protos.TermStmtCode.TailCallTermStmt) - .addExpr(f.getExprRep()); - for (Expr e : args) { - b.addExpr(e.getExprRep()); - } - setTermStmt(b); - } - - /** - * Pattern match on whether the expression, which should be a - * maybe value has an expression. - */ - public void switchMaybe(Expr v, LambdaBlock j, Block n) { - if (v == null) throw new NullPointerException("m"); - Type v_type = v.type(); - if (!v_type.isMaybe()) { - throw new IllegalArgumentException("Expression must be maybe type."); - } - if (!(v_type.equals(j.getArgType()))) { - throw new IllegalArgumentException("Block must match expected type."); - } - setTermStmt(Protos.TermStmt.newBuilder() - .setCode(Protos.TermStmtCode.SwitchMaybeTermStmt) - .addExpr(v.getExprRep()) - .addBlock(((SomeBlock) j).block_index) - .addBlock(((SomeBlock) n).block_index)); - } - - public abstract Protos.Block getBlockRep(); -} diff --git a/crucible-server/java_api/src/main/java/com/galois/crucible/cfg/SourcePosition.java b/crucible-server/java_api/src/main/java/com/galois/crucible/cfg/SourcePosition.java deleted file mode 100644 index ab259795c..000000000 --- a/crucible-server/java_api/src/main/java/com/galois/crucible/cfg/SourcePosition.java +++ /dev/null @@ -1,33 +0,0 @@ -package com.galois.crucible.cfg; - -import com.galois.crucible.proto.Protos; - -public class SourcePosition extends Position { - String path; - long line; - long col; - - public SourcePosition( String functionName, String path, long line, long col ) - { - this.functionName = functionName; - this.path = path; - this.line = line; - this.col = col; - } - - public Protos.Position getPosRep() - { - return Protos.Position.newBuilder() - .setCode( Protos.PositionCode.SourcePos ) - .setFunctionName( functionName ) - .setPath( path ) - .setLine( line ) - .setCol( col ) - .build(); - } - - public String toString() - { - return path + ":" + line + ":" + col + " " + functionName; - } -} diff --git a/crucible-server/java_api/src/main/java/com/galois/crucible/cfg/StatementResult.java b/crucible-server/java_api/src/main/java/com/galois/crucible/cfg/StatementResult.java deleted file mode 100644 index 7d8f91ecb..000000000 --- a/crucible-server/java_api/src/main/java/com/galois/crucible/cfg/StatementResult.java +++ /dev/null @@ -1,36 +0,0 @@ -package com.galois.crucible.cfg; -import com.galois.crucible.proto.Protos; -import com.galois.crucible.Type; - -/** - * An expression obtained by evaluating a statement. - */ -public class StatementResult implements Expr { - final long blockIndex; - final long statementIndex; - final Type type; - - StatementResult(long blockIndex, long statementIndex, Type type) { - if (type == null) { - throw new NullPointerException("type is null."); - } - this.blockIndex = blockIndex; - this.statementIndex = statementIndex; - this.type = type; - } - - public Type type() { - return type; - } - - /** - * Return the representation of a crucible expression. - */ - public Protos.Expr getExprRep() { - return Protos.Expr.newBuilder() - .setCode(Protos.ExprCode.StatementResultExpr) - .setBlockId(blockIndex) - .setIndex(statementIndex) - .build(); - } -} diff --git a/crucible-server/java_api/src/main/java/com/galois/crucible/cfg/package-info.java b/crucible-server/java_api/src/main/java/com/galois/crucible/cfg/package-info.java deleted file mode 100644 index f7487193a..000000000 --- a/crucible-server/java_api/src/main/java/com/galois/crucible/cfg/package-info.java +++ /dev/null @@ -1,11 +0,0 @@ -/** - * This package contains classes specific to the static Control Flow - * Graph representation used by the simulator. - * - *

- * To define control-flow graphs for a specific procedure - * see {@link com.galois.crucible.cfg.Procedure}. This can - * then be used during simulation by calling - * {@link com.galois.crucible.Simulator#useCfg(Procedure)}. - */ -package com.galois.crucible.cfg; diff --git a/crucible-server/java_api/src/main/java/com/galois/crucible/examples/Test.java b/crucible-server/java_api/src/main/java/com/galois/crucible/examples/Test.java deleted file mode 100644 index ea7ced377..000000000 --- a/crucible-server/java_api/src/main/java/com/galois/crucible/examples/Test.java +++ /dev/null @@ -1,110 +0,0 @@ -package com.galois.crucible.examples; - -import com.galois.crucible.*; -import com.galois.crucible.proto.Protos; -import java.io.IOException; - -public class Test { - public static void main(String[] args) { - if (args.length != 1) { - System.err.println("The test server expects a single argument with the path to the server."); - System.exit(-1); - } - - try { - SimpleSimulator s = SimpleSimulator.launchLocal(args[0]); - System.out.println("client: Started server"); - SimulatorValue x = new IntegerValue(4); - System.out.format("client: Generated constant: %s\n", x); - - SimulatorValue v = s.freshConstant(VarType.INTEGER); - - SimulatorValue r = s.add(x,x); - System.out.format("client: Compute x + x: %s\n", r); - /* - SatResult r = s.checkSat(s.eq(s.add(x,x), s.natConstant(1))); - if (r.isSat()) { - System.out.println("Satisfiable"); - System.out.format(" x: $1%n", r.valueOf(x)); - } else { - System.out.println("Unsatisfiable"); - } - */ - - s.close(); - } catch (InterruptedException e) { - System.err.println("Error launching local server:"); - System.err.println(e.getLocalizedMessage()); - System.exit(-1); - } catch (IOException e) { - System.err.println("Error launching local server:"); - System.err.println(e.getLocalizedMessage()); - System.exit(-1); - } - } -} - /* -int main(int argc, char** argv) { - - // Create a simulator object for storing the simulator state. - simulator* s = csim_new_simulator(); - - // Create a new handle - handle* add_handle = - csim_new_handle(s, "write_add_comm", 1, csim_string_type(), csim_unit_type()); - - // Create a control flow graph for the handle. - cfg* g = csim_new_cfg(add_handle); - - // Get the entry block for g. - block* b = csim_cfg_entry_block(g); - - // Get an expression representing the first argument. - expr* path = csim_cfg_arg(g, 0); - - // Create two registers for storing 32-bit bitvector.s - reg* x = csim_new_reg(g, csim_bv_type(32)); - reg* y = csim_new_reg(g, csim_bv_type(32)); - - // Create two symbolic variables for. - handle* mk_symbolic = csim_handleof_symbolic_uint(s); - csim_append_call(b, x, mk_symbolic, csim_nat_lit(32)); - csim_append_call(b, y, mk_symbolic, csim_nat_lit(32)); - -// Question: why don't we get something back from this? - // - or is reg * a flag that gets set -// Goal: mere mortals should be able to figure this out. - - // Generate expression asserting x + y == y + x. - expr* eq = csim_bv_eq(csim_bv_add(csim_reg_expr(x), csim_reg_expr(y)), - csim_bv_add(csim_reg_expr(y), csim_reg_expr(x))); -// this makes sense -- we get an expression back - but why can't we say: - -// expr *x = csim_new_ivar(32) -// expr *y = csim_new_ivar(32) -// expr *eq = csim_bv_eq(csim_bv_add(x,y), ... ) -// ?? - - // Write expresison to SMT lib. - csim_append_call(b, x, csim_handleof_write_smtlib2(s), path, eq); -// why the X above? are we back to register variables? -// it would be nice to not have to track both symbolic variables and regular ones... -// "what is a regular variable" - why is a reg * different from an expr. -JHX - regs can be modified, exprs can not - basic blocks coming soon -// can we hide distinctions. - - - // Return from procedure. - csim_end_return(b, csim_unit_expr()); - - // Tell simulator to use CFG during simulation of add_handle. - csim_use_cfg(s, g); - - // Symbolically simulator the write_add_comm function. - csim_run_call(s, add_handle, csim_string_lit("add_comm.smt")); - - // Free the symbolic simulator. - csim_free_simulator(s); - return 0; -} - */ diff --git a/crucible-server/java_api/src/main/java/com/galois/crucible/package-info.java b/crucible-server/java_api/src/main/java/com/galois/crucible/package-info.java deleted file mode 100644 index 9aa804479..000000000 --- a/crucible-server/java_api/src/main/java/com/galois/crucible/package-info.java +++ /dev/null @@ -1,11 +0,0 @@ -/** - * The main package for the Crucible - * symbolic simulator, a framework for symbolically - * simulating code in multiple languages. - * - *

- * To perform symbolic simulation, one first - * must construct a {@link com.galois.crucible.Simulator} - * object. - */ -package com.galois.crucible; diff --git a/crucible-server/java_api/src/test/java/com/galois/crucible/TestSAWSimulator.java b/crucible-server/java_api/src/test/java/com/galois/crucible/TestSAWSimulator.java deleted file mode 100644 index bdae6a1bf..000000000 --- a/crucible-server/java_api/src/test/java/com/galois/crucible/TestSAWSimulator.java +++ /dev/null @@ -1,57 +0,0 @@ -package com.galois.crucible; - -import java.math.BigInteger; - -import org.junit.Assert; -import org.junit.Test; -import org.junit.Ignore; -import org.junit.Rule; -import org.junit.rules.ExternalResource; -import org.junit.runner.RunWith; -import org.junit.runners.JUnit4; - -import com.galois.crucible.proto.Protos; - -public class TestSAWSimulator { - String simPath = System.getProperty("CRUCIBLE_SERVER"); - SAWSimulator sim; - - @Rule - public ExternalResource simResource = new ExternalResource() { - @Override - protected void before() throws Throwable { - if( simPath == null ) { - throw new Exception( "crucible server executable path not configured!" ); - } - - sim = SAWSimulator.launchLocal(simPath); - if( sim == null ) { - throw new Exception( "unable to launch crucible server executable" ); - } - sim.addPrintMessageListener(new MessageConsumer(){ - public void acceptMessage(SimulatorMessage msg) { - System.out.println(msg.toString()); - } - }); - } - - @Override - protected void after() { - try { - sim.close(); - } catch (Exception e) { - e.printStackTrace(); - System.exit(1); - } - } - }; - - @Test - public void testSatPath() throws Exception { - boolean initSetting = sim.getPathSatChecking(); - sim.setPathSatChecking( !initSetting ); - boolean nextSetting = sim.getPathSatChecking(); - Assert.assertTrue( initSetting != nextSetting ); - } - -} diff --git a/crucible-server/java_api/src/test/java/com/galois/crucible/TestValueCreator.java b/crucible-server/java_api/src/test/java/com/galois/crucible/TestValueCreator.java deleted file mode 100644 index 37a85d880..000000000 --- a/crucible-server/java_api/src/test/java/com/galois/crucible/TestValueCreator.java +++ /dev/null @@ -1,182 +0,0 @@ -package com.galois.crucible; - -import java.math.BigInteger; - -import org.junit.Assert; -import org.junit.Test; -import org.junit.Ignore; -import org.junit.Rule; -import org.junit.rules.ExternalResource; -import org.junit.runner.RunWith; -import org.junit.runners.JUnit4; - -import com.galois.crucible.proto.Protos; - -public class TestValueCreator { - String simPath = System.getProperty("CRUCIBLE_SERVER"); - SimpleSimulator sim; - - @Rule - public ExternalResource simResource = new ExternalResource() { - @Override - protected void before() throws Throwable { - if( simPath == null ) { - throw new Exception( "crucible server executable path not configured!" ); - } - - sim = SimpleSimulator.launchLocal(simPath); - if( sim == null ) { - throw new Exception( "unable to launch crucible server executable" ); - } - } - - @Override - protected void after() { - try { - sim.close(); - } catch (Exception e) { - e.printStackTrace(); - System.exit(1); - } - } - }; - - @Test - public void basicTest() throws Exception { - SimulatorValue x = new BitvectorValue(8, BigInteger.valueOf(4)); - System.out.format("client: Generated constant: %s\n", x); - - SimulatorValue v = sim.freshConstant(VarType.bitvector(8)); - - SimulatorValue r = sim.add(x,x); - System.out.format("client: Compute x + x: %s\n", r); - - SimulatorValue query = sim.eq(sim.add(v,v), new BitvectorValue(8, BigInteger.valueOf(2))); - - boolean isSat = sim.checkSatWithAbc(query); - if (isSat) { - System.out.println("Satisfiable"); - } else { - System.out.println("Unsatisfiable"); - } - } - - @Test - public void concatTest() throws Exception { - SimulatorValue x = sim.bvLiteral( 16, 0xdeadL ); - SimulatorValue y = sim.bvLiteral( 16, 0xbeefL ); - - SimulatorValue xy = sim.bvConcat( x, y ); - SimulatorValue yx = sim.bvConcat( y, x ); - - Assert.assertTrue( xy.type().equals( Type.bitvector(32) ) ); - Assert.assertTrue( yx.type().equals( Type.bitvector(32) ) ); - - BitvectorValue bv_xy = (BitvectorValue) xy; - BitvectorValue bv_yx = (BitvectorValue) yx; - - Assert.assertTrue( bv_xy.getValue().equals( BigInteger.valueOf( 0xdeadbeefL ) ) ); - Assert.assertTrue( bv_yx.getValue().equals( BigInteger.valueOf( 0xbeefdeadL ) ) ); - } - - @Test - public void concatTest2() throws Exception { - SimulatorValue a = sim.bvLiteral( 8, 0xaaL ); - SimulatorValue b = sim.bvLiteral( 8, 0xbbL ); - SimulatorValue c = sim.bvLiteral( 8, 0xccL ); - SimulatorValue d = sim.bvLiteral( 8, 0xddL ); - - SimulatorValue abcd = sim.bvConcat( new SimulatorValue[] { a, b, c, d } ); - SimulatorValue dcba = sim.bvConcat( new SimulatorValue[] { d, c, b, a } ); - - Assert.assertTrue( abcd.type().equals( Type.bitvector(32) ) ); - Assert.assertTrue( dcba.type().equals( Type.bitvector(32) ) ); - - BitvectorValue bv_abcd = (BitvectorValue) abcd; - BitvectorValue bv_dcba = (BitvectorValue) dcba; - - Assert.assertTrue( bv_abcd.getValue().equals( BigInteger.valueOf( 0xaabbccddL ) ) ); - Assert.assertTrue( bv_dcba.getValue().equals( BigInteger.valueOf( 0xddccbbaaL ) ) ); - } - - @Test - public void selectTest() throws Exception { - SimulatorValue x = sim.bvLiteral( 32, 0x0123abcdL ); - - SimulatorValue hi = sim.bvSelect( 16, 16, x ); - SimulatorValue mid = sim.bvSelect( 8, 16, x ); - SimulatorValue lo = sim.bvSelect( 0, 16, x ); - - Assert.assertTrue( hi.type().equals( Type.bitvector(16) ) ); - Assert.assertTrue( mid.type().equals( Type.bitvector(16) ) ); - Assert.assertTrue( lo.type().equals( Type.bitvector(16) ) ); - - BitvectorValue bv_hi = (BitvectorValue) hi; - BitvectorValue bv_mid = (BitvectorValue) mid; - BitvectorValue bv_lo = (BitvectorValue) lo; - - Assert.assertTrue( bv_hi.getValue().equals( BigInteger.valueOf( 0x0123L ) ) ); - Assert.assertTrue( bv_mid.getValue().equals( BigInteger.valueOf( 0x23abL ) ) ); - Assert.assertTrue( bv_lo.getValue().equals( BigInteger.valueOf( 0xabcdL ) ) ); - } - - @Test - public void checkSatTest() throws Exception { - SimulatorValue x = sim.bvLiteral( 8, 12 ); - SimulatorValue y = sim.freshConstant( VarType.bitvector(8) ); - SimulatorValue z = sim.add( x, y ); - - SimulatorValue p = sim.eq( z, sim.bvLiteral( 8, 42 ) ); - SimulatorValue q = sim.eq( y, sim.bvLiteral( 8, 30 ) ); - - Assert.assertTrue( sim.checkSatWithAbc( p ) ); - Assert.assertTrue( sim.checkSatWithAbc( sim.and( p, q ) ) ); - Assert.assertTrue( sim.checkSatWithAbc( sim.not( q ) ) ); - Assert.assertFalse( sim.checkSatWithAbc( sim.and( p, sim.not( q ) ) ) ); - } - - @Test - public void concatSelectSat() throws Exception { - SimulatorValue x = sim.freshConstant( VarType.bitvector(8) ); - SimulatorValue y = sim.bvLiteral( 8, 0xaf ); - SimulatorValue z = sim.bvConcat( y , x ); - - SimulatorValue x2 = sim.bvSelect( 0, 8, z ); - SimulatorValue y2 = sim.bvSelect( 8, 8, z ); - - SimulatorValue p = sim.not(sim.eq( x, x2 )); - SimulatorValue q = sim.not(sim.eq( y, sim.bvLiteral( 8, 0xaf ))); - - Assert.assertFalse( sim.checkSatWithAbc( p ) ); - Assert.assertFalse( sim.checkSatWithAbc( q ) ); - } - - @Test - public void testMultipart1() throws Exception { - // 16-bit addresses and 9-bit words (just for kicks) - SimulatorValue wm = sim.emptyWordMap( 16, Type.bitvector(9) ); - SimulatorValue val = sim.bvLiteral( 27, 1234567 ); - SimulatorValue addr = sim.bvLiteral( 16, 0xabcd ); - - SimulatorValue wm2 = sim.multipartStore( BoolValue.TRUE, addr, val, wm ); - SimulatorValue x = sim.multipartLoad( BoolValue.TRUE, addr, 3, wm2 ); - SimulatorValue p = sim.eq( val, x ); - - Assert.assertTrue( ((BoolValue) p).equals( BoolValue.TRUE ) ); - } - - @Test - public void testMultipart2() throws Exception { - // 16-bit addresses and 9-bit words (just for kicks) - SimulatorValue wm = sim.emptyWordMap( 16, Type.bitvector(9) ); - SimulatorValue val = sim.bvLiteral( 27, 1234567 ); - SimulatorValue addr = sim.bvLiteral( 16, 0xabcd ); - - SimulatorValue wm2 = sim.multipartStore( BoolValue.FALSE, addr, val, wm ); - SimulatorValue x = sim.multipartLoad( BoolValue.FALSE, addr, 3, wm2 ); - SimulatorValue p = sim.eq( val, x ); - - Assert.assertTrue( ((BoolValue) p).equals( BoolValue.TRUE ) ); - } - -}; diff --git a/crucible-server/java_api/src/test/java/com/galois/crucible/TestVerificationHarness.java b/crucible-server/java_api/src/test/java/com/galois/crucible/TestVerificationHarness.java deleted file mode 100644 index a4f9d91a4..000000000 --- a/crucible-server/java_api/src/test/java/com/galois/crucible/TestVerificationHarness.java +++ /dev/null @@ -1,89 +0,0 @@ -package com.galois.crucible; - -import java.math.BigInteger; - -import org.junit.Assert; -import org.junit.Test; -import org.junit.Ignore; -import org.junit.Rule; -import org.junit.rules.ExternalResource; -import org.junit.runner.RunWith; -import org.junit.runners.JUnit4; - -import com.galois.crucible.proto.Protos; - -public class TestVerificationHarness { - String simPath = System.getProperty("CRUCIBLE_SERVER"); - SAWSimulator sim; - - @Rule - public ExternalResource simResource = new ExternalResource() { - @Override - protected void before() throws Throwable { - if( simPath == null ) { - throw new Exception( "crucible server executable path not configured!" ); - } - - sim = SAWSimulator.launchLocal(simPath); - if( sim == null ) { - throw new Exception( "unable to launch crucible server executable" ); - } - sim.addPrintMessageListener(new MessageConsumer(){ - public void acceptMessage(SimulatorMessage msg) { - System.out.println(msg.toString()); - } - }); - } - - @Override - protected void after() { - try { - sim.close(); - } catch (Exception e) { - e.printStackTrace(); - System.exit(1); - } - } - }; - - - @Test - public void testVerificationHarness() throws Exception { - VerificationHarness harness = new VerificationHarness("testHarness", 14, 64, Protos.Endianness.LittleEndian); - Protos.VariableReference constValue = harness.prestate().addVar( "constValue", 64 ); - Protos.VariableReference testVar = harness.prestate().addVar( "testVar", 16 ); - Protos.VariableReference testArray = harness.prestate().addVar( "testArray", 100, 32 ); - Protos.VariableReference poststateVar = harness.poststate().addVar( "poststateVar", 5, 24 ); - - harness.prestate().assignRegister( 0x0, constValue ); - harness.prestate().assignRegister( 0x8, harness.returnVar ); - harness.prestate().assignRegister( 0xf, harness.stackVar ); - harness.prestate().bindVariable( constValue, "~zero" ); - harness.prestate().assignMemory( VerificationHarness.stackVar, 0x00, testArray ); - harness.prestate().bindVariable( testVar, "take (testArray @ constValue)"); - - harness.prestate().assertCondition( "testVar == 0xabcd" ); - - Protos.VariableReference poststateStack = harness.poststate().addVar( "poststateStack", 64 ); - - harness.poststate().assignMemory( VerificationHarness.stackVar, 0x10, poststateVar ); - harness.poststate().bindVariable( poststateVar, "[0,1,2,3,4]" ); - harness.poststate().bindVariable( poststateStack, "stack + 8"); - harness.poststate().assignRegister( 0xf, poststateStack ); - - sim.compileHarness( harness ); - } - - // @Test - // public void bogusVerificationHarness() throws Exception { - // VerificationHarness harness = new VerificationHarness("bogusHarness", 64, Protos.Endianness.LittleEndian); - // Protos.VariableReference bogus1 = harness.prestate().addVar( "bogus1", 64 ); - // Protos.VariableReference bogus2 = harness.prestate().addVar( "bogus2", 64 ); - - // harness.prestate().bindVariable( bogus1, "bogus2" ); - // // harness.prestate().bindVariable( bogus2, "bogus1" ); - - // sim.compileHarness( harness ); - // } - -}; diff --git a/crucible-server/proto/crucible.proto b/crucible-server/proto/crucible.proto deleted file mode 100644 index bda39f4fd..000000000 --- a/crucible-server/proto/crucible.proto +++ /dev/null @@ -1,1206 +0,0 @@ -// syntax = "proto2"; - -package crucible; - -option java_package = "com.galois.crucible.proto"; -option java_outer_classname = "Protos"; -option optimize_for = SPEED; - -//////////////////////////////////////////////////////////////////////// -// Messages relating to the server startup handshake. In this phase -// the client requests to start the server using a specific backend. -// The server responds to indicate all is well; or returns an error. - -message HandShakeRequest { - optional Backend backend = 1; -} - -message HandShakeResponse { - optional HandShakeCode code = 1; - optional string message = 2; -} - -enum Backend { - SimpleBackend = 0; - SAWBackend = 1; -} - -enum HandShakeCode { - HandShakeOK = 0; - HandShakeError = 1; -} - -//////////////////////////////////////////////////////////////////////// -// Declarations for issuing requests to simulator when nothing is -// running. - -// A code to identify a request to the simulator. -// This is used exclusively within Request messages, and specific codes will -// require some of those fields to be populated. -enum RequestCode { - // Placeholder used if request code could not be parsed from a message. - UnknownMessage = 0; - - // Terminate the simulator (no additional information needed, and no response returned). - KillSimulator = 1; - - // Create a new handle with the handle info added in the handle. - // This message expects that the Request.handle field is populated. - // - // The server should return a RegisterHandleResponse message back to - // the client after this occurs. - RegisterHandle = 2; - - // Request code for associating a function handle with the given - // Crucible CFG for symbolic simulation. - // The first Request.cfg contains information about the cfg used. - // This Request has no return value. - UseCFG = 4; - - // Have Crucible callback to Java to support this function. - // Request.index contains the index of the handle to use. - UseOverride = 5; - - // Request code for running a function with a given list of arguments - // (in Request.argument), and getting the result. The first argument is - // the function to call, and the remaining arguments are the arguments to pass - // to the function. Since executing a function may take an arbitrary amount of - // time, this will transition the server into an Execution state, and the next message - // returned will be a CallResponse message. - RunCall = 6; - - // Release the resources associated with a symbolic value. - // Request.index contains the index of the value to release. - // This does not expect a return value. - ReleaseValue = 7; - - // Apply primitive operation to some arguments. - // - // The operation is in Request.prim_op. - // The arguments are in request.arg. - // The result width (if applicable) is in request.result_width. - // The server will respond to this with a SimulatorValueResponse message. - ApplyPrimitive = 8; - - // This request tells the simulator to keep running. - // - // It is only legal to send this message when the simulator has been paused - // to execute an Override. - // - // Request.return_value should contain the value to return to the calling - // function. - ResumeSimulation = 9; - - // This request tells the simulator to print the given CFG. This request - // exists primarily for debugging purposes. - // - // Request.cfg should contain the CFG to be printed. - PrintCFG = 10; - - // This request sets the verbosity level of the simulator. Higher verbosity - // levels generate more status and debugging informational messages. - // Request.arg should contain exactly one natural number literal argument. - SetVerbosity = 11; - - // This request takes a collection of symbolic values and exports them - // in the requested format. - ExportModel = 12; - - // This request takes a verification harness and returns a function handle that - // can be used as an override for compositional verification. - CompileVerificationOverride = 13; - - // Request the current setting of a configuration value. Use the - // Request.config_setting_name field to identify the setting of interest. - GetConfigValue = 14; - - // Set a configuration value. Use the Request.config_setting_name field to - // identify the setting of interest, and use the Request.arg field for the - // value to set. - SetConfigValue = 15; - - // Request that the simulator use a verification harness to simulate some code. - SimulateVerificationHarness = 16; - - ///////////////////////////////////////////////////////////////////////////// - // Operations to get predefined handles. - - // Request a predefined handle by its name. Fill out the handle.display_name - // field of the request object to indicate the name of the desired function handle. - GetHandleByName = 255; - - // Requests a handle to write SMTLIB2. This handle takes a string - // representing the file name, and a Boolean value denoting the predicate - // to check the satisfiability of. No arguments are expected in the message - // for obtaining this handle. - // - // OBSOLETE: use getHandleByName("write_SMTLIB2") - //WriteSmtlib2Handle = 256; - - // Requests a handle to create a fresh symbolic value. The message - // should specify Request.varType to indicate the type of the value - // to be returned by the handle. The function itself takes no arguments. - SymbolicHandle = 257; - - // Request a handle to call checkSat with ABC. - // OBSOLETE: use getHandleByName("checkSatWithAbc") - // CheckSatWithAbcHandle = 258; - - // Request a handle to print terms of a given type. Set the Request.type - // field to get a handle for printing terms of that type. - PrintTermHandle = 259; - - // Request a handle to store a multipart word in a word map. Such handles - // Take four arguments. First a boolean: true is big-endian; false is little-endian. - // Second is an address. Third is the value to store. Fourth is a word map. - // The address type must match the bitwidth of the given word map, and the value to - // store must be a multiple of the word map cell width. The return value of this - // function is an updated word map. - // - // Fill out the argument and return type values of the request.handle structure - // to request a specific store function. The name field will be ignored. - MultipartStoreHandle = 260; - - // Request a handle to laod a multipart word in a word map. Such handles - // Take three arguments. First a boolean: true is big-endian; false is little-endian. - // Second is an address to load. Third is a word map to load from. - // The address type must match the bitwidth of the given word map. The return - // value of the function will be a bitvector value. The bitwidth of the return value - // must be a multiple of the word map cell width. - // - // Fill out the argument and return type values of the request.handle structure - // to request a specific store function. The name field will be ignored. - MultipartLoadHandle = 261; -} - -// A request for when the simulator is currently waiting for more work. -message Request { - // Code for a message. - optional RequestCode code = 1; - - // Handle used for RegisterHandle and GetHandleByName - optional HandleInfo handle = 2; - - // Control flow graph used by DefineCFG. - optional Cfg cfg = 4; - - // Variable type argument (used by SymbolicHandle) - optional VarType varType = 5; - - // The index of a symbolic value or handle (see RequestCode documentation). - optional uint64 index = 6; - - // Operation used for ApplyPrimitive. - optional PrimitiveOp prim_op = 7; - - // Arguments used for run_call (must be non-empty as first argument is function), - // or ApplyPrimitive. Also used for ExportModel request. - repeated Value arg = 8; - - // Result type argument for RequestCode.ApplyPrimitive. This is required - // in some cases where the result type of the operation is not completely - // fixed by the types of the input arguments. - optional CrucibleType result_type = 9; - - // Value returned to simulator when code = ResumeSimulation. - optional Value return_value = 10; - - // Type argument for PrintTermHandle - optional CrucibleType type = 11; - - // The format to use for export - optional ExportFormat export_format = 12; - - // The destination for an export operation - optional string export_path = 13; - - // Verification harness to use for the CompileVerificationHarness - // request, or SimulateVerificationHarness request - optional VerificationHarness verification_harness = 14; - - // Name of the configuration value being read or written by a - // get or set option request - optional string config_setting_name = 15; - - // Additional options necessary to setup verification simulations and - // define what to do with the simulation products. - optional VerificationSimulateOptions verification_sim_options = 16; -} - - -//////////////////////////////////////////////////////////////////////// -// Responses -// -// All response types are gathered together into a GenericResponse -// container. - -enum GenericResponseCode { - // Respond with a string to print - PrintGenResp = 0; - - // Respond with a SimulatorValueResponse - SimulatorValueGenResp = 1; - - // Respond with a RegisterHandleResponse - RegisterHandleGenResp = 2; - - // Respond with a PredefinedHandleInfo - PredefHandleGenResp = 3; - - // Respond with a CallResponse - CallGenResp = 4; - - // Respond with an Exception. The message field of the GenericResponse - // indicates the content of the exception. - ExceptionGenResp = 5; - - // Respond with an acknowledgement. This message indicates that the requested - // action was taken successfully. No additional information is transmitted. - AcknowledgementResp = 6; -} - -message GenericResponse { - // Response code indicating what sort of response this is - optional GenericResponseCode code = 1; - - // Message corresponding to the PrintGenResp code - optional string message = 2; - - // Response value corresponding to the SimulatorValueGenResp code - optional SimulatorValueResponse simValResponse = 3; - - // Response value corresponding to the RegisterHandleGenResp code - optional RegisterHandleResponse regHandleResponse = 4; - - // Response value corresponding to the PredeHandleGenResp code - optional PredefinedHandleInfo predefHandleResponse = 5; - - // Response value corresponding to the CallGenResp code - optional CallResponse callResponse = 6; -} - -//////////////////////////////////////////////////////////////////////// -// Encoding for creating variables. - -// Identifier for variable type. -enum VarTypeId { - BoolVarType = 0; - IntegerVarType = 1; - RealVarType = 2; - BitvectorVarType = 3; -} - -// Type for symbolic value expressions. -message VarType { - // Identifier for message. - required VarTypeId id = 1; - - // Width for bitvector type. - optional uint64 width = 2; - - // Optional dimensions for creating sequences of symbolic values. - // If provided, they define the dimensions of a multi-dimensional - // sequence of base types. If not provided, a single base type - // variable will be created. - repeated uint64 dimension = 3; -} - -//////////////////////////////////////////////////////////////////////// -// ExportFormat codes - -enum ExportFormat { - // Export as an AIGER file - ExportAIGER = 1; - - // Export as a SAWCore term - ExportSAW = 2; -} - - -//////////////////////////////////////////////////////////////////////// -// PrimitiveOp codes - -// Code for operations of value to create. -// This is used inside Request -enum PrimitiveOp { - - ///////////////////////////////////////////////////////////////////////////// - // Boolean operations - - // Negate Boolean value. - BoolNot = 1; - // Add two Boolean values. - BoolAnd = 2; - // Take exclusive-or of values. - BoolXor = 3; - // If-then-else to three Boolean values. - BoolIte = 4; - - ///////////////////////////////////////////////////////////////////////////// - // Operations on natural numbers - - // Add two natural numbers. - NatAdd = 5; - // Multiply two natural numbers. - NatMul = 6; - // If-then-else on natural numbers. - // NatIte = 7; - // Return true if two natural numbers are equivalent. - NatEq = 8; - // Return true if first natural is less than second. - NatLt = 9; - - ///////////////////////////////////////////////////////////////////////////// - // Operations on Integers - - // Add two integers. - IntegerAdd = 10; - // Subtract second integer from another. - IntegerSub = 11; - // Multiply two integers. - IntegerMul = 12; - // If-then-else on integers. - // IntegerIte = 13; - // Return true if two integers are equivalent. - IntegerEq = 14; - // Return true if first integer is less than second. - IntegerLt = 15; - - ////////////////////////////////////////////////////////////////////// - // Operations on Reals - - // Add two reals. - RealAdd = 16; - // Subtract second real from another. - RealSub = 17; - // Multiply two reals. - RealMul = 18; - // If-then-else on reals. - RealIte = 19; - // Return true if two reals are equivalent. - RealEq = 20; - // Return true if first real is less than second. - RealLt = 21; - - ////////////////////////////////////////////////////////////////////// - // Bitvector operations - - // For the bitvector operations, I've added type signatures to the definitions - // to help document what arguments are expected. These should be stored - // in the Request.arg field. The result_width should be defined if the - // result has a width that is not bound by one of the arguments. - - // Bitvector addition (expects two bitvectors arguments with same width) - // BVAdd :: BV(n) -> BV(n) -> BV(n) - BVAdd = 22; - // Bitvector subtraction (expects two bitvectors arguments with same width) - // BVSub :: BV(n) -> BV(n) -> BV(n) - BVSub = 23; - // Bitvector multiplication (expects two bitvectors arguments with same width) - // BVMul :: BV(n) -> BV(n) -> BV(n) - BVMul = 24; - // Bitvector unsigned division - // BVUdiv :: BV(n) -> BV(n) -> BV(n) - BVUdiv = 25; - // Bitvector unsigned remainder - // BVUrem :: BV(n) -> BV(n) -> BV(n) - BVUrem = 26; - // Bitvector signed division - // BVSrem :: n >= 1 => BV(n) -> BV(n) -> BV(n) - BVSdiv = 27; - // Bitvector signed remainder - // BVSrem :: n >= 1 => BV(n) -> BV(n) -> BV(n) - BVSrem = 28; - - // If-then-else applied to bitvectors - // BVIte :: Bool -> BV(n) -> BV(n) -> BV(n) - BVIte = 30; - // Check if bitvectors are equal. - // BVEq :: BV(n) -> BV(n) -> Bool - BVEq = 31; - // Bitvector unsigned less-than or equal - // BVUle :: BV(n) -> BV(n) -> Bool - BVUle = 33; - // Bitvector unsigned less-than - // BVUlt :: BV(n) -> BV(n) -> Bool - BVUlt = 32; - // Bitvector signed less-than or equal - // BVSle :: n >= 1 => BV(n) -> BV(n) -> Bool - BVSle = 35; - // Bitvector signed less-than - // BVSlt :: n >= 1 => BV(n) -> BV(n) -> Bool - BVSlt = 34; - - // Bitvector shift lift - // The shift amount is an unsigned bitvector in the second argument. - BVShl = 36; - // Logic shift right (zeros shifted in from right) - // The shift amount is an unsigned bitvector in the second argument. - BVLshr = 37; - // Arithmetic shift right (zeros shifted in from right). - // The shift amount is an unsigned bitvector in the second argument. - BVAshr = 38; - // Bitwise complement - // BVNot :: BV(n) -> BV(n) - BVNot = 39; - // Bitwise and - // BVAnd :: BV(n) -> BV(n) -> BV(n) - BVAnd = 40; - // Bitwise or - // BVOr :: BV(n) -> BV(n) -> BV(n) - BVOr = 41; - // Bitwise exclusive or - // BVXor :: BV(n) -> BV(n) -> BV(n) - BVXor = 42; - // Bitvector truncation (single bitvector argument expected) - // The result_width field should contain the target width. - // BVTrunc :: (r <= n) => BV(n) -> BV(r) - BVTrunc = 45; - // Bitvector unsigned extension (single bitvector argument expected) - // Request.result_width should contain the target width. - // BVZExt :: n <= r => BV(n) -> BV(r) - BVZext = 43; - // Bitvector signed extension (single bitvector argument expected) - // The result_width field should contain the target width. - // BVSExt :: (1 <= n, n <= r) => BV(n) -> BV(r) - BVSext = 44; - // Concateneate two bitvectors. The first argument corresponds to the - // most significant bits, and the second to the least significant bits. - // BVConcat :: BV(n) -> BV(m) -> BV(n+m) - BVConcat = 46; - // Select a subvector from a bitvector. The first argument is the index - // to begin taking bits (counting from the most-significant bit as 0), and - // the second argument is the number of bits to take. - // BVSelect :: (idx + n <= w) => (idx::Nat) -> (n::Nat) -> BV(w) -> BV(n) - BVSelect = 47; - // Return true if the given bitvector is nonzero; return false if it is zero - // BVNonzero :: BV(n) -> Bool - BVNonzero = 48; - // Return true if the unsigned addition of two bitvector values overflows. - // BVCarry :: BV(n) -> BV(n) -> Bool - BVCarry = 49; - // Return true if the signed addition of two bitvector values overflows. - // BVSCarry :: BV(n) -> BV(n) -> Bool - BVSCarry = 50; - // Return true if the signed subtraction of two bitvector values overflows. - // BVSBorrow :: BV(n) -> BV(n) -> Bool - BVSBorrow = 51; - - ////////////////////////////////////////////////////////////////////// - // Conversions - - // Convert a natural number to an integer. - NatToInteger = 60; - // Convert an integer to a real. - IntegerToReal = 61; - // Return the constant 1 bitvector if the given boolean is true, and - // return the constant 0 bitvector if the boolean is false. - // BoolToBV :: Bool -> BV(w) - BoolToBV = 62; - - ///////////////////////////////////////////////////////////////////// - // Vector Operations - - // Build a vector directly from a sequence of values. Every value - // in the sequence is required to have the same type. - // VectorLit :: a -> ... -> a -> Vector(a) - VectorLit = 70; - - // Build a vector of length n, each element of which contains - // the given value. - // VectorReplicate :: Nat -> a -> Vector(a) - VectorReplicate = 71; - - // Return true if the vector contains no elements. - // VectorIsEmpty :: Vector(a) -> Bool - VectorIsEmpty = 72; - - // Return the number of elements in a vector. - // VectorSize :: Vector(a) -> Nat - VectorSize = 73; - - // Returns the nth element of the given vector. Results in a - // run-time error if the index is not in bounds. - // VectorGetEntry :: Vector(a) -> Nat -> a - VectorGetEntry = 74; - - // Returns an updated vector, where the nth element of the new vector - // contains the given elemtn. - // VectorSetEntry :: Vector(a) -> Nat -> a -> Vector(a) - VectorSetEntry = 75; - - ///////////////////////////////////////////////////////////////////// - // WordMap operations - - // Build a new, empty WordMap - // WordMapEmpty :: WordMap(n, a) - WordMapEmpty = 80; - - // Insert an element into a WordMap - // WordMapInsert :: BV(n) -> a -> WordMap(n, a) -> WordMap(n, a) - WordMapInsert = 81; - - // Lookup the value in a word map at the given index. Results in - // an error if the WordMap has no value at the given index. - // WordMapLookup :: BV(n) -> WordMap(n,a) -> a - WordMapLookup = 82; - - // Lookup the value in a word map at the given index. If the word map - // has no value at that index, a default value is returned instead. - // WordMapLookupWithDefault :: BV(n) -> WordMap(n,a) -> a -> a - WordMapLookupWithDefault = 83; - - /////////////////////////////////////////////////////////////////////// - // Struct operations - - // Build a structure literal from a sequence of values - // StructLiteral :: a_1 -> a_2 -> ... -> a_n -> Struct(a_1,a_2,...,a_n) - StructLiteral = 90; - - // Get an element from a structure value. The index must be a nat literal. - // StructGet :: (i :: Nat) -> Struct(a_1,a_2,...,a_n) -> a_i - StructGet = 91; - - // Update a structure value with a new element. The index must be a nat literal. - // StructSet :: Struct(a_1,a_2,...,a_n) -> (i :: Nat) -> a_i -> Struct(a_1,a_2,...,a_n) - StructSet = 92; - - ////////////////////////////////////////////////////////////////////////// - // Maybe operations - - // Build the 'Nothing' maybe value - // NothingValue :: Maybe a - NothingValue = 100; - - // Build a 'Just' maybe value containing the given value - // JustValue :: a -> Maybe a - JustValue = 101; - - ///////////////////////////////////////////////////////////////////////// - // Debugging operations - - // Generate a string representation of the given value, which must be - // of a base type. - // ShowValue :: a -> String - ShowValue = 102; - - // Return true if the given value of base type is concrete, or false if - // it is symbolic. - // IsConcrete :: a -> Bool - IsConcrete = 103; -} - -// This enum is used to identify how the simulator value is represented. -// Constants are represented by passing the value directly while symbolic -// values are represented by an opaque handle. -enum ValueCode { - // The value is a reference to a previous value. The value of the reference is - // stored in Value.index. When the value represents - // a simulator value, the value is a unique identifier. Within a CFG, this - // refers to an immutable result within the CFG. - ReferenceValue = 0; - // The value is the Boolean constant "true". - TrueValue = 1; - // The value is the Boolean constant "false". - FalseValue = 2; - - // A constant natural number value. - // This is stored in Value.data as a byte array of a unsigned integer - // in big-endian form. - NatValue = 3; - // A constant integer value. - // This is stored in Value.data as a byte array of a signed integer - // big-endian form. - IntegerValue = 4; - // A constant rational value. - // This is stored in Value.data with the enominator first encoded as a - // varint unsigned integer followed by the numerator encoded in signed - // big-endian form. - RationalValue = 5; - // A constant bitvector value. - // Value.val stores the width and Value.data - // stores the value in big-endian form. - BitvectorValue = 6; - // A constant string. - // Value is stored in Value.string_lit. - StringValue = 7; - // The unit constant. - UnitValue = 8; - // A handle literal. - // Value.index stores the index of the handle reference. - // Value.handle_info stores the information about the handle. - // handle_info is only populated when the server sends a value back to the - // client. The client does not need to populate the field. - FnHandleValue = 9; -} - -// Message representing a simulator value. -message Value { - // The kind of value encodeded. - required ValueCode code = 1; - // Used to store certain types of Value (see ValueCode constants). - optional uint64 index = 2; - // Used to store certain types of Value (see ValueCode constants). - optional uint64 width = 3; - - // Payload containing binary date (used to store actual simulator value). - optional bytes data = 4; - - // The actual value of a string literal. - optional string string_lit = 5; - - // Information about handle if this is a handle. - optional HandleInfo handle_info = 6; -} - -// Message sent when simulator is requested to create a value. -message SimulatorValueResponse { - // Indicates if request was successful. - required bool successful = 1; - // Value returned by the simulator. - optional Value value = 2; - // Error message when request failed. - optional string error_msg = 3; -} - -//////////////////////////////////////////////////////////////////////// -// CrucibleType - -// Code to identify crucible type. This appears in the context of -// a CrucibleType value. -enum CrucibleTypeId { - UnitType = 0; - BoolType = 1; - NatType = 2; - PosNatType = 3; - IntegerType = 4; - RealType = 5; - // Complex real numbers (no parameters) - ComplexType = 6; - // BitvectorType denotes bitvectors with a specific length. The - // CrucibleType.width field stores the width. - BitvectorType = 7; - // 16-bit IEEE754 float - HalfFloatType = 8; - // 32-bit IEEE754 float - SingleFloatType = 9; - // 64-bit IEEE754 float - DoubleFloatType = 10; - // 128-bit IEEE754 float - QuadFloatType = 11; - // 80-bit IEEE754 float - X86_80FloatType = 12; - // 2 64-bit floats used in double-double type. - DoubleDoubleFloatType = 13; - // A single unicode character (no parameters) - CharType = 14; - StringType = 15; - // A function handle - // Has a list of parameters for arguments, followed by the type of - // the return value. - FunctionHandleType = 16; - - // A maybe value (has one parameter for the type that it may contain) - MaybeType = 17; - // A vector value (has one parameter for the type of the elements). - VectorType = 18; - // A tuple containing an fixed tuple of values. There is a parameter - // for each value it may contain. - StructType = 19; - - // NB: There is deliberately a gap here in the numbering from 20-31 - // where other, now unused, types used to be. - - // A parametric type mapping strings to partial values. - StringMapType = 32; - - // A WordMap, which is a finite partial map from bitvectors to values - WordMapType = 34; -} - -// Information about a crucible type. -message CrucibleType { - required CrucibleTypeId id = 1; - // Width for bitvector type. - optional uint64 width = 2; - // Type parameters, if any - repeated CrucibleType param = 3; -} - -//////////////////////////////////////////////////////////////////////// -// Messages used for register handle. - -// Information about the handle to be registerd. -message HandleInfo { - optional string display_name = 1; - repeated CrucibleType arg_type = 2; - optional CrucibleType return_type = 3; -} - -// This message returns the identifier of a handle after the simulator -// creates it. -message RegisterHandleResponse { - // Index for new handle. - optional uint64 index = 1; -} - -//////////////////////////////////////////////////////////////////////// -// Messages for getting a predefined handle and information about it. - -// Return message sent when getting a predefined handle. Contains the Id -// and information about the handle. -message PredefinedHandleInfo { - // A uint64 that uniquely identifies the Handle. This can be used - // to uniquely identify the handle for creating values. - optional uint64 ref = 1; - // Information about the handle. - optional HandleInfo info = 2; -} - -//////////////////////////////////////////////////////////////////////// -// Messages when creating a control flow graph. - -enum PositionCode { - // An position with no additional information. - InternalPos = 0; - // A position in source code. - // Position.path contains the full path to the file. - // Position.line contains the line number in the file. - // Position.col contains the column number in the file. - SourcePos = 1; - // A position in a bianry. - // Position.path contains the full path to the binary. - // Position.addr contains the address when loaded into memory. - BinaryPos = 2; - // Unstructured string position. - // Position.pos_string contains an arbitrary string describing the - // program position. - OtherPos = 3; -} - -// A position in the code. -message Position { - optional PositionCode code = 1; - optional string path = 2; - optional uint64 line = 3; - optional uint64 col = 4; - optional uint64 addr = 5; - optional string functionName = 6; - optional string value = 7; -} - -message Cfg { - optional uint64 handle_id = 1; - // The position to use for the CFG. - optional Position pos = 2; - // Types of registers in CFG. - repeated CrucibleType register = 3; - // List of blocks in CFG. - repeated Block block = 4; -} - -// A basic block in the program. -// The block identifier is implicit and determined by the position in the CFG. -message Block { - // The position to use for the start of the block. - optional Position pos = 1; - // Indicates if this block is a lambda block (default false) - optional bool is_lambda = 2; - // The type of a lambda argument is this is a lambda block. - optional CrucibleType lambda_type = 3; - // The list of statements for the block. - repeated Statement statement = 4; - // The terminal statement for a block. - optional TermStmt termStmt = 5; -} - -enum StatementCode { - // Undefined is the default to catch cases where the statement id is out of range. - UndefinedStatment = 0; - - // Execute a primitive operation in the block. - // The operation is specified in Statement.prim_op. - // The arguments are stored in Statement.expr. - // Statement.result_type should contain the expected result returned by the - // function call. - ExecPrimitive = 1; - - // Call a function with the given arguments. - // Statement.expr contains the function to call as the first argument, and - // then the actual arguments in the rest of the list. - // Statement.result_type should contain the expected result returned by the - // function call. - Call = 2; - // Print a message. - // Statement.expr constains an expression to print. It should be a string - // expression. - Print = 3; - // Assert a condition holds. - // This takes two expression arguments: - // The first is the Boolean condition, the second is a string indicating what - // to do if it fails. - Assert = 4; - // Read a register - // Statement.reg should contain the index of the register to read. - ReadReg = 5; - // Write to a register. - // Statement.reg should contain the index of the register to write to. - // Statement.expr should contain the value to write. - WriteReg = 6; - // Read a global variable. - ReadGlobal = 7; - // Write to a global variable. - WriteGlobal = 8; -} - -message Statement { - optional StatementCode code = 1; - - // Position of statement. - optional Position pos = 2; - - // Register used in read or write reg. - optional uint64 reg = 3; - - // Operation used for ExecPrimitive. - optional PrimitiveOp prim_op = 4; - - // Expressions referenced by statement. - repeated Expr expr = 5; - - // Type of the result of the operation. - optional CrucibleType result_type = 7; -} - -enum TermStmtCode { - // Undefined is the default to catch cases where the statement id is out of range. - UndefinedTermStmt = 0; - // Jump to a basic block. - // TermStmt.block should contain the index of the block to jump to. - JumpTermStmt = 1; - // Branch on a condition. - // TermStmt.expr should contain a Boolean expression to branch on. - // TermStmt.block should two block indexes: - // * the first is the block to jump to when the condition is true. - // * the second is the block to jump to when the condition is true. - BranchTermStmt = 2; - // Return from this function. - // TermStmt.expr should contain the value to return. - ReturnTermStmt = 3; - // Fail with an error. - // TermStmt.expr should contain the message to print when failing. - ErrorTermStmt = 4; - // Jump to a new function with a tail call. - // TermStmt.expr should contain the function to call as the first - // argument, and the arguments to pass it as the remaining expressions. - TailCallTermStmt = 5; - // Case match on an expression with type Maybe t. - // TermStmt.expr should contain the expression to pattern match on. - // TermStmt.block should two block indexes: - // * the first is a lambda block to jump to when the expression contains a value. - // * the second is the block to jump to when the expression is nothing. - SwitchMaybeTermStmt = 6; -} - -message TermStmt { - // Code identifying the type of statement that this is. - optional TermStmtCode code = 1; - // Position of statement. - optional Position pos = 2; - // Expressions referenced by this statement. - repeated Expr expr = 3; - // Blocks referenced by this statement. - repeated uint64 block = 4; -} - -// Code used to identify the source of a Crucible expression. -enum ExprCode { - UnknownExpr = 0; - - // Expression denoting constant "true". - TrueExpr = 1; - - // Expression denoting constant "false". - FalseExpr = 2; - - // A constant natural number value. - // This is stored in Expr.data as a byte array of a unsigned integer - // in big-endian form. - NatExpr = 3; - // A constant integer value. - // This is stored in Expr.data as a byte array of a signed integer - // big-endian form. - IntegerExpr = 4; - // A constant rational value. - // This is stored in Expr.data with the denominator first encoded as a - // varint unsigned integer followed by the numerator encoded in signed - // big-endian form. - RationalExpr = 5; - // A constant bitvector value. - // Expr.width stores the width and Expr.data - // stores the value in big-endian form. - BitvectorExpr = 6; - // A constant string. - // Value is stored in Expr.string_lit. - StringExpr = 7; - // The unit constant. - UnitExpr = 8; - // A handle literal. - // Expr.index stores the index of the handle reference. - FnHandleExpr = 9; - - // Code for expressions from function argument. - // The index for this is stored in Expr.index. - FunctionArgExpr = 10; - - // Code for expressions generated from a lambda block. - // The field Expr.block_id contains the block that generated it. - LambdaArgExpr = 11; - - // Code for expressions created by previous statements. - // Expr.block_id contains the index of the block that the statement - // was defined in. - // Expr.index contains the index within the block of the statement. - StatementResultExpr = 12; -} - -// Identifies a Crucible expression. -message Expr { - optional ExprCode code = 1; - - // Index of block a statement result was created in. - optional uint64 block_id = 2; - - // Index if this is an argument expression. - optional uint64 index = 3; - - // Used to store certain types of Value (see ValueCode constants). - optional uint64 width = 4; - // Payload containing binary date (used to store actual simulator value). - optional bytes data = 5; - - // The actual value of a string literal. - optional string string_lit = 6; -} - -//////////////////////////////////////////////////////////////////////// -// Messages when running a function call. - -// Code used to indicate how the simulator responded to the call. -enum CallResponseCode { - // Indicates that an override was called. - // CallResponse.handle_index must contain the index of the handle that was called. - // CallResponse.arg contains the arguments to the function. - // When this message is sent, the client should send back a Request object. - CallOverrideCalled = 1; - // Indicates execution along a particular path aborted, - // simulator will keep execution. - CallPathAborted = 2; - // Indicates that the function returned a value. - CallReturnValue = 3; - // Indicates all branches ended in a abort - // (this is after the @CallPathAborted message@). - CallAllAborted = 4; -} - -// Call response is the message sent from Crucible to the caller once -// execution has paused for some reason. -message CallResponse { - // Code identifying what response occured from the call. - optional CallResponseCode code = 1; - - // Return value for CallReturnValue. - optional Value returnVal = 2; - - // Message to print for CallPathAborted. - optional PathAbortedMessage message = 3; - - // Index of handle when override is called. - optional uint64 handle_index = 4; - - // Arguments when override is called. - repeated Value arg = 5; -} - -enum PathAbortedCode { - // No specific information avaliable - AbortedGeneric = 0; - - // A path aborted because of a read-before-write error - AbortedReadBeforeWrite = 1; - - // Attempted to call a value that does not represent a function - AbortedNonFunction = 2; - - // An explicit assertion (i.e., one specificly inserted into the a CFG) failed - AbortedUserAssertFailure = 3; -} - -message PathAbortedMessage { - // Code identifying the specific failure - optional PathAbortedCode code = 1; - - // String message describing the error - optional string message = 2; - - // Position information when a path is aborted - repeated Position backtrace = 3; -} - -// Request for the simulator indicating what to do next after it sends a -// call response that indicates simulation has not yet terminated. -message CallRequest { - optional CallRequestCode code = 1; -} - -// Code for what to do next when the simulator returns a CallResponse. -enum CallRequestCode { - // Default code when the request code could not be parsed. - UnknownCallRequest = 0; - // Resume execution of the call. - ResumeCall = 1; - // Stop executing the call and switch back to a paused state (no response needeD). - AbortCall = 2; -} - - -///////////////////////////////////////////////////////////////////////////// -// Messages related to compositional verification - -message VerificationHarness { - // Human-consumable name to give to the override function - optional string name = 1; - - // Specification of prestate variables, register and memory state - optional StateSpecification prestate_specification = 2; - - // Specification of poststate variables, register and memory state - optional StateSpecification poststate_specification = 3; - - // Address word length, in bits; - optional uint64 address_width = 4; - - // Machine endianess - optional Endianness endianness = 5; - - // Register file width, in bits; - optional uint64 reg_file_width = 6; - - // Optional function output term - optional string output_expr = 7; - - // Cryptol specification files - repeated string cryptol_source = 8; -} - -// Code for indicating which byte-order to assume for verification harnesses -enum Endianness { - // Little-endian byte order - LittleEndian = 0; - - // Big-endian byte order - BigEndian = 1; -} - -message StateSpecification { - // specification variables - repeated VariableSpecification variable = 1; - - // specification register assignments - repeated RegisterAssignment register_assignment = 2; - - // specification memory assignments - repeated MemoryAssignment memory_assignment = 3; - - // specification variable bindings - repeated VariableBinding variable_binding = 4; - - // specification conditions - repeated string condition = 5; -} - -message VariableSpecification { - // The name of the varible, which must be a valid Cryptol identifier. - optional string name = 1; - - // The dimensions of the variable. There must be exactly one - // or two dimensions, indicating words or vectors of words. - // The word dimension must be a multiple of 8. - repeated uint64 dimension = 2; -} - -message RegisterAssignment { - // The offset of the register in the register file - optional uint64 reg_offset = 1; - - // The index of the specification variable found in this register - optional VariableReference value = 2; -} - -message MemoryAssignment { - // The base pointer of the memory address - optional VariableReference base = 1; - - // An offset from the base pointer - optional uint64 offset = 2; - - // The value pointed to at that location - optional VariableReference value = 3; -} - -message VariableBinding { - // The variable to be bound - optional VariableReference var = 1; - - // The cryptol expression to bind to this variable - optional string expr = 2; -} - -enum VariableReferenceCode { - // The value of the stack pointer - StackPointerVar = 1; - - // The value of the return address - ReturnAddressVar = 2; - - // The value of a user-defined variable - UserVar = 3; -} - -message VariableReference { - // The variable reference type - optional VariableReferenceCode code = 1; - - // The name of the variable, - // for references to user-defined variables - optional string var_name = 2; -} - -//////////////////////////////////////////////////////////////////////// -// -// Additional data about setting up simulation and where to deposit -// simulation results - -message VerificationSimulateOptions { - // Starting PC value for simulation - optional Value start_pc = 1; - - // Starting stack pointer value for simulation - optional Value start_stack = 2; - - // Return pointer value for simulation - optional Value return_address = 3; - - // Function handle for the program to simulate - optional Value program = 4; - - // Directory where to write output SAWCore terms - optional string output_directory = 5; - - // Should we produce proof obligations for side-conditions and - // postconditions, etc? - // optional bool output_proof_obligations = 6; - - // Shoule proof obligations be split into separate files? - optional bool separate_obligations = 7; -} diff --git a/crucible-server/src/Lang/Crucible/Proto.hproto b/crucible-server/src/Lang/Crucible/Proto.hproto deleted file mode 100644 index e69de29bb..000000000 diff --git a/crucible-server/src/Lang/Crucible/Server/CallbackOutputHandle.hs b/crucible-server/src/Lang/Crucible/Server/CallbackOutputHandle.hs deleted file mode 100644 index 01affa114..000000000 --- a/crucible-server/src/Lang/Crucible/Server/CallbackOutputHandle.hs +++ /dev/null @@ -1,77 +0,0 @@ ------------------------------------------------------------------------ --- | --- Module : Lang.Crucible.Server.CallbackOutputHandle --- Copyright : (c) Galois, Inc 2014-2016 --- Maintainer : Rob Dockins --- Stability : provisional --- License : BSD3 --- --- Utility for making an I/O handle from a collection of callback --- functions. ------------------------------------------------------------------------- - -{-# LANGUAGE DeriveDataTypeable #-} -module Lang.Crucible.Server.CallbackOutputHandle - ( OutputCallbacks(..) - , mkCallbackOutputHandle - ) where - -import qualified Data.ByteString as B -import qualified Data.ByteString.Internal as B -import Data.Typeable -import Foreign.ForeignPtr -import Foreign.Marshal.Utils -import Foreign.Ptr -import GHC.IO.Buffer -import GHC.IO.BufferedIO -import GHC.IO.Device -import GHC.IO.Handle -import System.IO - --- | Callbacks for writing to file. -data OutputCallbacks - = OutputCallbacks { devCallback :: !(B.ByteString -> IO ()) - -- ^ Function to call when buffer flushes. - , devClose :: !(IO ()) - -- ^ Function to call when device closes. - } - deriving (Typeable) - -instance IODevice OutputCallbacks where - ready _ isWrite _ = return isWrite - close d = devClose d - devType _ = return Stream - - -instance BufferedIO OutputCallbacks where - newBuffer _ = newByteBuffer 4096 - fillReadBuffer = error "Output device does not support reading." - fillReadBuffer0 = error "Output device does not support reading." - flushWriteBuffer md buf = do - -- Get offset of start of buffer. - let offset = bufL buf - -- Get length of offer - let l = bufferElems buf - -- Create bytestring with copy of data. - bs <- B.create l $ \p -> do - withForeignPtr (bufRaw buf) $ \src -> do - copyBytes p (src `plusPtr` offset) l - -- Send output to callback function. - devCallback md bs - -- Return empty buffer. - return buf { bufL = 0 - , bufR = 0 - } - - flushWriteBuffer0 md buf = do - buf' <- flushWriteBuffer md buf - return (bufferElems buf, buf') - --- | A handle that can receive output and call a callback function. -mkCallbackOutputHandle :: FilePath -- ^ "FilePath" used in debug messages. - -> OutputCallbacks - -- ^ Functions to call when using device. - -> IO Handle -mkCallbackOutputHandle path callback = do - let encoding = Nothing - mkFileHandle callback path AppendMode encoding noNewlineTranslation diff --git a/crucible-server/src/Lang/Crucible/Server/CryptolEnv.hs b/crucible-server/src/Lang/Crucible/Server/CryptolEnv.hs deleted file mode 100644 index 066739d8b..000000000 --- a/crucible-server/src/Lang/Crucible/Server/CryptolEnv.hs +++ /dev/null @@ -1,568 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ScopedTypeVariables #-} - -{- | -Module : $Header$ -Description : Context for interpreting Cryptol within the cryptol server -License : BSD3 -Maintainer : rdockins -Stability : provisional - -NOTE! This module is ripped from the corresponding functionality in SAWScript, and is -basically a copy-paste of module "SAWScript.CryptolEnv". It would probably be better -to abstract this functionality into a single place, either within Crytpol proper, -or in a separate package --} -module Lang.Crucible.Server.CryptolEnv - ( CryptolEnv(..) - , Import(..) - , initCryptolEnv - , loadCryptolModule - , bindCryptolModule - , lookupCryptolModule - , importModule - , bindTypedTerm - , bindType - , bindInteger - , parseTypedTerm - , inferTerm - , checkTerm - , renameTerm - , translateExpr - , parseDecls - , parseSchema - , declareName - , declareIdent - , typeNoUser - , schemaNoUser - , getNamingEnv - , defaultEvalOpts - ) - where - ---import qualified Control.Exception as X -import qualified Data.ByteString as BS -import Data.Map (Map) -import qualified Data.Map as Map -import qualified Data.Set as Set - -import Data.Maybe (fromMaybe) -import Data.Text (Text, pack) - -import System.Environment (lookupEnv) -import System.Environment.Executable (splitExecutablePath) -import System.FilePath ((), normalise, joinPath, splitPath, splitSearchPath) - -import Verifier.SAW.SharedTerm (SharedContext, Term, incVars) - -import qualified Verifier.SAW.Cryptol as C - -import qualified Cryptol.Eval as E -import qualified Cryptol.Parser as P -import qualified Cryptol.Parser.AST as P -import qualified Cryptol.Parser.Position as P -import qualified Cryptol.TypeCheck as T -import qualified Cryptol.TypeCheck.AST as T -import qualified Cryptol.TypeCheck.Infer as TI -import qualified Cryptol.TypeCheck.Kind as TK -import qualified Cryptol.TypeCheck.Monad as TM -import qualified Cryptol.TypeCheck.Solve as TS - ---import qualified Cryptol.TypeCheck.PP as TP - -import qualified Cryptol.ModuleSystem as M -import qualified Cryptol.ModuleSystem.Base as MB -import qualified Cryptol.ModuleSystem.Env as ME -import qualified Cryptol.ModuleSystem.Exports as MEx -import qualified Cryptol.ModuleSystem.Interface as MI -import qualified Cryptol.ModuleSystem.Monad as MM -import qualified Cryptol.ModuleSystem.NamingEnv as MN -import qualified Cryptol.ModuleSystem.Name as MN -import qualified Cryptol.ModuleSystem.Renamer as MR - -import Cryptol.Utils.PP -import Cryptol.Utils.Ident (Ident, preludeName, packIdent, interactiveName) -import Cryptol.Utils.Logger (quietLogger) - -import Lang.Crucible.Server.TypedTerm - - --------------------------------------------------------------------------------- -data Import = Import - { iModule :: Either FilePath P.ModName - , iAs :: Maybe P.ModName - , iSpec :: Maybe P.ImportSpec - } deriving (Eq, Show) - -data CryptolEnv = CryptolEnv - { eImports :: [P.Import] -- ^ Declarations of imported Cryptol modules - , eModuleEnv :: ME.ModuleEnv -- ^ Imported modules, and state for the ModuleM monad - , eExtraNames :: MR.NamingEnv -- ^ Context for the Cryptol renamer - , eExtraTypes :: Map T.Name T.Schema -- ^ Cryptol types for extra names in scope - , eExtraTSyns :: Map T.Name T.TySyn -- ^ Extra Cryptol type synonyms in scope - , eTermEnv :: Map T.Name Term -- ^ SAWCore terms for *all* names in scope - } - --- Initialize ------------------------------------------------------------------ - -initCryptolEnv :: SharedContext -> IO CryptolEnv -initCryptolEnv sc = do - modEnv0 <- M.initialModuleEnv - - -- Set the Cryptol include path (TODO: we may want to do this differently) - (binDir, _) <- splitExecutablePath - let instDir = normalise . joinPath . init . splitPath $ binDir - mCryptolPath <- lookupEnv "CRYPTOLPATH" - let cryptolPaths = - case mCryptolPath of - Nothing -> [] - Just path -> -#if defined(mingw32_HOST_OS) || defined(__MINGW32__) - -- Windows paths search from end to beginning - reverse (splitSearchPath path) -#else - splitSearchPath path -#endif - let modEnv1 = modEnv0 { ME.meSearchPath = cryptolPaths ++ - (instDir "lib") : ME.meSearchPath modEnv0 } - - -- Load Cryptol prelude - (_, modEnv) <- - liftModuleM modEnv1 $ - MB.loadModuleFrom False (MM.FromModule preludeName) - - -- Generate SAWCore translations for all values in scope - termEnv <- genTermEnv sc modEnv - - return CryptolEnv - { eImports = [P.Import preludeName Nothing Nothing] - , eModuleEnv = modEnv - , eExtraNames = mempty - , eExtraTypes = Map.empty - , eExtraTSyns = Map.empty - , eTermEnv = termEnv - } - --- Parse ----------------------------------------------------------------------- - -ioParseExpr :: String -> IO (P.Expr P.PName) -ioParseExpr = ioParseGeneric P.parseExprWith - -ioParseDecls :: String -> IO [P.Decl P.PName] -ioParseDecls = ioParseGeneric P.parseDeclsWith - -ioParseSchema :: String -> IO (P.Schema P.PName) -ioParseSchema = ioParseGeneric P.parseSchemaWith - -ioParseGeneric :: (P.Config -> Text -> Either P.ParseError a) -> String -> IO a -ioParseGeneric parse str = ioParseResult (parse cfg (pack str)) - where - cfg = P.defaultConfig - -ioParseResult :: Either P.ParseError a -> IO a -ioParseResult res = case res of - Right a -> return a - Left e -> fail $ "Cryptol parse error:\n" ++ show (P.ppError e) -- X.throwIO (ParseError e) - --- Rename ---------------------------------------------------------------------- - -getNamingEnv :: CryptolEnv -> MR.NamingEnv -getNamingEnv env = eExtraNames env `MR.shadowing` nameEnv - where - nameEnv = mconcat $ fromMaybe [] $ traverse loadImport (eImports env) - loadImport i = do - lm <- ME.lookupModule (T.iModule i) (eModuleEnv env) - return $ MN.interpImport i (MI.ifPublic (ME.lmInterface lm)) - -getAllIfaceDecls :: ME.ModuleEnv -> M.IfaceDecls -getAllIfaceDecls me = mconcat (map (both . ME.lmInterface) (ME.getLoadedModules (ME.meLoadedModules me))) - where both ifc = M.ifPublic ifc `mappend` M.ifPrivate ifc - --- Typecheck ------------------------------------------------------------------- - -runInferOutput :: TM.InferOutput a -> MM.ModuleM a -runInferOutput out = - case out of - - TM.InferOK nm warns seeds supply o -> - do MM.setNameSeeds seeds - MM.setSupply supply - MM.typeCheckWarnings nm warns - return o - - TM.InferFailed nm warns errs -> - do MM.typeCheckWarnings nm warns - MM.typeCheckingFailed nm errs - --- Translate ------------------------------------------------------------------- - -translateExpr :: SharedContext -> CryptolEnv -> T.Expr -> IO Term -translateExpr sc env expr = do - let modEnv = eModuleEnv env - let ifaceDecls = getAllIfaceDecls modEnv - (types, _) <- liftModuleM modEnv $ do - prims <- MB.getPrimMap - TM.inpVars `fmap` MB.genInferInput P.emptyRange prims MI.noIfaceParams ifaceDecls - let types' = Map.union (eExtraTypes env) types - let terms = eTermEnv env - let cryEnv = C.emptyEnv - { C.envE = fmap (\t -> (t, 0)) terms - , C.envC = types' - } - C.importExpr sc cryEnv expr - -translateDeclGroups :: SharedContext -> CryptolEnv -> [T.DeclGroup] -> IO CryptolEnv -translateDeclGroups sc env dgs = do - let modEnv = eModuleEnv env - let ifaceDecls = getAllIfaceDecls modEnv - (types, _) <- liftModuleM modEnv $ do - prims <- MB.getPrimMap - TM.inpVars `fmap` MB.genInferInput P.emptyRange prims MI.noIfaceParams ifaceDecls - let types' = Map.union (eExtraTypes env) types - let terms = eTermEnv env - let cryEnv = C.emptyEnv - { C.envE = fmap (\t -> (t, 0)) terms - , C.envC = types' - } - cryEnv' <- C.importTopLevelDeclGroups sc cryEnv dgs - termEnv' <- traverse (\(t, j) -> incVars sc 0 j t) (C.envE cryEnv') - - let decls = concatMap T.groupDecls dgs - let names = map T.dName decls - let newTypes = Map.fromList [ (T.dName d, T.dSignature d) | d <- decls ] - let addName name = MR.shadowing (MN.singletonE (P.mkUnqual (MN.nameIdent name)) name) - return env - { eExtraNames = foldr addName (eExtraNames env) names - , eExtraTypes = Map.union (eExtraTypes env) newTypes - , eTermEnv = termEnv' - } - --- | Translate all declarations in all loaded modules to SAWCore terms -genTermEnv :: SharedContext -> ME.ModuleEnv -> IO (Map T.Name Term) -genTermEnv sc modEnv = do - let declGroups = concatMap T.mDecls (ME.loadedModules modEnv) - cryEnv <- C.importTopLevelDeclGroups sc C.emptyEnv declGroups - traverse (\(t, j) -> incVars sc 0 j t) (C.envE cryEnv) - --------------------------------------------------------------------------------- - -loadCryptolModule :: SharedContext -> CryptolEnv -> FilePath - -> IO (CryptolModule, CryptolEnv) -loadCryptolModule sc env path = do - let modEnv = eModuleEnv env - (m, modEnv') <- liftModuleM modEnv (MB.loadModuleByPath path) - - let ifaceDecls = getAllIfaceDecls modEnv' - (types, modEnv'') <- liftModuleM modEnv' $ do - prims <- MB.getPrimMap - TM.inpVars `fmap` MB.genInferInput P.emptyRange prims MI.noIfaceParams ifaceDecls - - -- Regenerate SharedTerm environment. - let oldTermEnv = eTermEnv env - newTermEnv <- genTermEnv sc modEnv'' - let names = MEx.eBinds (T.mExports m) -- :: Set T.Name - let tm' = Map.filterWithKey (\k _ -> Set.member k names) $ - Map.intersectionWith TypedTerm types newTermEnv - let env' = env { eModuleEnv = modEnv'' - , eTermEnv = Map.union newTermEnv oldTermEnv - } - let sm' = Map.filterWithKey (\k _ -> Set.member k (T.eTypes (T.mExports m))) (T.mTySyns m) - return (CryptolModule sm' tm', env') - -bindCryptolModule :: (P.ModName, CryptolModule) -> CryptolEnv -> CryptolEnv -bindCryptolModule (modName, CryptolModule sm tm) env = - env { eExtraNames = flip (foldr addName) (Map.keys tm) $ - flip (foldr addTSyn) (Map.keys sm) $ eExtraNames env - , eExtraTSyns = Map.union sm (eExtraTSyns env) - , eExtraTypes = Map.union (fmap (\(TypedTerm s _) -> s) tm) (eExtraTypes env) - , eTermEnv = Map.union (fmap (\(TypedTerm _ t) -> t) tm) (eTermEnv env) - } - where - addName name = MN.shadowing (MN.singletonE (P.mkQual modName (MN.nameIdent name)) name) - addTSyn name = MN.shadowing (MN.singletonT (P.mkQual modName (MN.nameIdent name)) name) - -lookupCryptolModule :: CryptolModule -> String -> IO TypedTerm -lookupCryptolModule (CryptolModule _ tm) name = - case Map.lookup (packIdent name) (Map.mapKeys MN.nameIdent tm) of - Nothing -> fail $ "Binding not found: " ++ name - Just t -> return t - --------------------------------------------------------------------------------- - -importModule :: SharedContext -> CryptolEnv -> Import -> IO CryptolEnv -importModule sc env imp = do - let modEnv = eModuleEnv env - - (m, modEnv') <- - liftModuleM modEnv $ - case iModule imp of - Left path -> MB.loadModuleByPath path - Right mn -> snd <$> MB.loadModuleFrom True (MM.FromModule mn) - - -- Regenerate SharedTerm environment. TODO: preserve old - -- values, only translate decls from new module. - let oldTermEnv = eTermEnv env - newTermEnv <- genTermEnv sc modEnv' - - return env { eImports = P.Import (T.mName m) (iAs imp) (iSpec imp) : eImports env - , eModuleEnv = modEnv' - , eTermEnv = Map.union newTermEnv oldTermEnv } - -bindIdent :: Ident -> CryptolEnv -> (T.Name, CryptolEnv) -bindIdent ident env = (name, env') - where - modEnv = eModuleEnv env - supply = ME.meSupply modEnv - fixity = Nothing - (name, supply') = MN.mkDeclared interactiveName MN.UserName ident fixity P.emptyRange supply - modEnv' = modEnv { ME.meSupply = supply' } - env' = env { eModuleEnv = modEnv' } - --- | Produce a unique term-level @Name@ for the given @Ident@ and record its type, --- without giving it a definition. -declareIdent :: Ident -> T.Schema -> CryptolEnv -> (T.Name, CryptolEnv) -declareIdent ident schema env = - ( name - , env' { eExtraNames = MR.shadowing (MN.singletonE pname name) (eExtraNames env') - , eExtraTypes = Map.insert name schema (eExtraTypes env') - } - ) - where - pname = P.mkUnqual ident - (name, env') = bindIdent ident env - - -bindTypedTerm :: (Ident, TypedTerm) -> CryptolEnv -> CryptolEnv -bindTypedTerm (ident, TypedTerm schema trm) env = - env' { eExtraNames = MR.shadowing (MN.singletonE pname name) (eExtraNames env) - , eExtraTypes = Map.insert name schema (eExtraTypes env) - , eTermEnv = Map.insert name trm (eTermEnv env) - } - where - pname = P.mkUnqual ident - (name, env') = bindIdent ident env - -bindType :: (Ident, T.Schema) -> CryptolEnv -> CryptolEnv -bindType (ident, T.Forall [] [] ty) env = - env' { eExtraNames = MR.shadowing (MN.singletonT pname name) (eExtraNames env) - , eExtraTSyns = Map.insert name tysyn (eExtraTSyns env) - } - where - pname = P.mkUnqual ident - (name, env') = bindIdent ident env - tysyn = T.TySyn name [] [] ty Nothing -bindType _ env = env -- only monomorphic types may be bound - -bindInteger :: (Ident, Integer) -> CryptolEnv -> CryptolEnv -bindInteger (ident, n) env = - env' { eExtraNames = MR.shadowing (MN.singletonT pname name) (eExtraNames env) - , eExtraTSyns = Map.insert name tysyn (eExtraTSyns env) - } - where - pname = P.mkUnqual ident - (name, env') = bindIdent ident env - tysyn = T.TySyn name [] [] (T.tNum n) Nothing - --------------------------------------------------------------------------------- - -parseTypedTerm :: SharedContext -> CryptolEnv -> String -> IO TypedTerm -parseTypedTerm sc env input = do - pexpr <- ioParseExpr input - (env', schema, expr) <- inferTerm env pexpr - - -- Translate - trm <- translateExpr sc env' expr - return (TypedTerm schema trm) - - -renameTerm :: CryptolEnv -> P.Expr P.PName -> IO (CryptolEnv, P.Expr MN.Name) -renameTerm env pexpr = do - let modEnv = eModuleEnv env - - (expr, modEnv') <- liftModuleM modEnv $ do - -- Eliminate patterns - npe <- MM.interactive (MB.noPat pexpr) - - -- Resolve names - let nameEnv = getNamingEnv env - MM.interactive (MB.rename interactiveName nameEnv (MR.rename npe)) - - let env' = env{ eModuleEnv = modEnv' } - return (env', expr) - - -checkTerm :: CryptolEnv -> P.Expr MN.Name -> T.Type -> IO (CryptolEnv, T.Expr) -checkTerm env re expectedType = do - let modEnv = eModuleEnv env - - (expr, modEnv') <- liftModuleM modEnv $ do - - -- Infer types - let ifDecls = getAllIfaceDecls modEnv - let range = fromMaybe P.emptyRange (P.getLoc re) - prims <- MB.getPrimMap - tcEnv <- MB.genInferInput range prims MI.noIfaceParams ifDecls - let tcEnv' = tcEnv { TM.inpVars = Map.union (eExtraTypes env) (TM.inpVars tcEnv) - , TM.inpTSyns = Map.union (eExtraTSyns env) (TM.inpTSyns tcEnv) - } - - --out <- MM.io (T.tcExpr re tcEnv') - out <- MM.io $ TM.runInferM tcEnv' - (do e <- TI.checkE re (T.WithSource expectedType T.TypeWildCard) -- type source is kinda bogus... - TS.simplifyAllConstraints - return e) - MM.interactive (runInferOutput out) - - let env' = env { eModuleEnv = modEnv' } - return (env', expr) - - -inferTerm :: CryptolEnv -> P.Expr P.PName -> IO (CryptolEnv, T.Schema, T.Expr) -inferTerm env pexpr = do - let modEnv = eModuleEnv env - - ((expr, schema), modEnv') <- liftModuleM modEnv $ do - - -- Eliminate patterns - npe <- MM.interactive (MB.noPat pexpr) - - -- Resolve names - let nameEnv = getNamingEnv env - re <- MM.interactive (MB.rename interactiveName nameEnv (MR.rename npe)) - - -- Infer types - let ifDecls = getAllIfaceDecls modEnv - let range = fromMaybe P.emptyRange (P.getLoc re) - prims <- MB.getPrimMap - tcEnv <- MB.genInferInput range prims MI.noIfaceParams ifDecls - let tcEnv' = tcEnv { TM.inpVars = Map.union (eExtraTypes env) (TM.inpVars tcEnv) - , TM.inpTSyns = Map.union (eExtraTSyns env) (TM.inpTSyns tcEnv) - } - - out <- MM.io (T.tcExpr re tcEnv') - MM.interactive (runInferOutput out) - - let env' = env { eModuleEnv = modEnv' } - - return (env', schema, expr) - - -parseDecls :: SharedContext -> CryptolEnv -> String -> IO CryptolEnv -parseDecls sc env input = do - let modEnv = eModuleEnv env - let ifaceDecls = getAllIfaceDecls modEnv - - -- Parse - (decls :: [P.Decl P.PName]) <- ioParseDecls input - - (tmodule, modEnv') <- liftModuleM modEnv $ do - - -- Eliminate patterns - (npdecls :: [P.Decl P.PName]) <- MM.interactive (MB.noPat decls) - - -- Convert from 'Decl' to 'TopDecl' so that types will be generalized - let topdecls = [ P.Decl (P.TopLevel P.Public Nothing d) | d <- npdecls ] - - -- Label each TopDecl with the "interactive" module for unique name generation - let (mdecls :: [MN.InModule (P.TopDecl P.PName)]) = map (MN.InModule interactiveName) topdecls - nameEnv1 <- MN.liftSupply (MN.namingEnv' mdecls) - - -- Resolve names - let nameEnv = nameEnv1 `MR.shadowing` getNamingEnv env - (rdecls :: [P.TopDecl T.Name]) <- MM.interactive (MB.rename interactiveName nameEnv (traverse MR.rename topdecls)) - - -- Create a Module to contain the declarations - let rmodule = P.Module (P.Located P.emptyRange interactiveName) Nothing [] rdecls - - -- Infer types - let range = fromMaybe P.emptyRange (P.getLoc rdecls) - prims <- MB.getPrimMap - tcEnv <- MB.genInferInput range prims MI.noIfaceParams ifaceDecls - let tcEnv' = tcEnv { TM.inpVars = Map.union (eExtraTypes env) (TM.inpVars tcEnv) - , TM.inpTSyns = Map.union (eExtraTSyns env) (TM.inpTSyns tcEnv) - } - - out <- MM.io (TM.runInferM tcEnv' (TI.inferModule rmodule)) - tmodule <- MM.interactive (runInferOutput out) - return tmodule - - -- Add new type synonyms and their name bindings to the environment - let syns' = Map.union (eExtraTSyns env) (T.mTySyns tmodule) - let addName name = MR.shadowing (MN.singletonT (P.mkUnqual (MN.nameIdent name)) name) - let names' = foldr addName (eExtraNames env) (Map.keys (T.mTySyns tmodule)) - let env' = env { eModuleEnv = modEnv', eExtraNames = names', eExtraTSyns = syns' } - - -- Translate - let dgs = T.mDecls tmodule - translateDeclGroups sc env' dgs - -parseSchema :: CryptolEnv -> String -> IO T.Schema -parseSchema env input = do - --putStrLn $ "parseSchema: " ++ show input - let modEnv = eModuleEnv env - - -- Parse - pschema <- ioParseSchema input - --putStrLn $ "ioParseSchema: " ++ show pschema - - fmap fst $ liftModuleM modEnv $ do - - -- Resolve names - let nameEnv = getNamingEnv env - rschema <- MM.interactive (MB.rename interactiveName nameEnv (MR.rename pschema)) - - let ifDecls = getAllIfaceDecls modEnv - let range = fromMaybe P.emptyRange (P.getLoc rschema) - prims <- MB.getPrimMap - tcEnv <- MB.genInferInput range prims MI.noIfaceParams ifDecls - let tcEnv' = tcEnv { TM.inpTSyns = Map.union (eExtraTSyns env) (TM.inpTSyns tcEnv) } - let infer = - case rschema of - P.Forall [] [] t _ -> do - let k = Nothing -- allow either kind KNum or KType - (t', goals) <- TM.collectGoals $ TK.checkType t k - return (T.Forall [] [] t', goals) - _ -> TK.checkSchema TM.AllowWildCards rschema - out <- MM.io (TM.runInferM tcEnv' infer) - (schema, _goals) <- MM.interactive (runInferOutput out) - --mapM_ (MM.io . print . TP.ppWithNames TP.emptyNameMap) goals - return (schemaNoUser schema) - -declareName :: CryptolEnv -> P.ModName -> String -> IO (T.Name, CryptolEnv) -declareName env mname input = do - let pname = P.mkUnqual (packIdent input) - let modEnv = eModuleEnv env - (cname, modEnv') <- - liftModuleM modEnv $ MM.interactive $ - MN.liftSupply (MN.mkDeclared mname MN.UserName (P.getIdent pname) Nothing P.emptyRange) - let env' = env { eModuleEnv = modEnv' } - return (cname, env') - -typeNoUser :: T.Type -> T.Type -typeNoUser t = - case t of - T.TCon tc ts -> T.TCon tc (map typeNoUser ts) - T.TVar {} -> t - T.TUser _ _ ty -> typeNoUser ty - T.TRec fields -> T.TRec $ typeNoUser <$> fields - -schemaNoUser :: T.Schema -> T.Schema -schemaNoUser (T.Forall params props ty) = T.Forall params props (typeNoUser ty) - ------------------------------------------------------------- - -liftModuleM :: ME.ModuleEnv -> MM.ModuleM a -> IO (a, ME.ModuleEnv) -liftModuleM env m = MM.runModuleM (defaultEvalOpts, BS.readFile, env) m >>= moduleCmdResult - -defaultEvalOpts :: E.EvalOpts -defaultEvalOpts = E.EvalOpts quietLogger E.defaultPPOpts - -moduleCmdResult :: M.ModuleRes a -> IO (a, ME.ModuleEnv) -moduleCmdResult (res, ws) = do - --mapM_ (print . pp) ws - case res of - Right (a, me) -> return (a, me) - Left err -> - fail $ unlines (["Cryptol error:\n" ++ show (pp err)] ++ map (show . pp) ws) - --- X.throwIO (ModuleSystemError err) diff --git a/crucible-server/src/Lang/Crucible/Server/Encoding.hs b/crucible-server/src/Lang/Crucible/Server/Encoding.hs deleted file mode 100644 index 9069ae720..000000000 --- a/crucible-server/src/Lang/Crucible/Server/Encoding.hs +++ /dev/null @@ -1,135 +0,0 @@ ------------------------------------------------------------------------ --- | --- Module : Lang.Crucible.Server.Encoding --- Copyright : (c) Galois, Inc 2014-2016 --- Maintainer : Rob Dockins --- Stability : provisional --- License : BSD3 --- --- Encoding and decoding utilities for numeric data. ------------------------------------------------------------------------- - -{-# LANGUAGE CPP #-} -module Lang.Crucible.Server.Encoding - ( decodeSigned - , encodeSigned - , decodeUnsigned - , encodeUnsigned - , encodeRational - , decodeRational - ) where - -#if !MIN_VERSION_base(4,13,0) -import Control.Monad.Fail( MonadFail ) -#endif - -import Data.ByteString.Builder (Builder) -import qualified Data.ByteString.Builder as Builder -import qualified Data.ByteString as BS -import Data.Bits -import Data.Ratio -import Data.Word - - --- | Encode a signed integer in two's complement with the most-significant bit first. -encodeSigned :: Integer -> Builder -encodeSigned n0 = go (s n0) (ls n0) mempty - where -- Get least-significant byte. - ls :: Integer -> Word8 - ls n = fromIntegral (n .&. 0xFF) - -- Get most-significant bit. - msb w = w `testBit` 7 - -- Shift by byte - s n = n `shiftR` 8 - - -- | Incrementally create the bytestring. - go :: Integer -- ^ The value above the current word. - -> Word8 -- ^ The current word. - -> Builder - -> Builder - - -- When we have reached the end of a positive number, prepend - -- a zero byte if necessary to force the sign bit to be positive. - go 0 l b | msb l = Builder.word8 0 <> Builder.word8 l <> b - | otherwise = Builder.word8 l <> b - - -- When we have reached the end of a negative number, prepend - -- an 0xFF byte if necessary to force the sign bit to be negative. - go (-1) l b | msb l = Builder.word8 l <> b - | otherwise = Builder.word8 0xFF <> Builder.word8 l <> b - - -- Recurse when we haven't reached most-significant word. - go n l b = go (s n) (ls n) (Builder.word8 l <> b) - --- | Encode an unsigned integer with the most-significant bit first. -encodeUnsigned :: Integer -> Builder -encodeUnsigned n0 - | n0 >= 0 = go (s n0) (w n0) - | otherwise = error "encodeUnsigned given negative value." - where -- Get least-significant byte. - w :: Integer -> Builder - w n = Builder.word8 (fromIntegral (n .&. 0xFF)) - -- Shift by byte - s n = n `shiftR` 8 - go :: Integer -> Builder -> Builder - go 0 b = b - go n b = go (s n) (w n <> b) - --- | Decode a signed integer in two's complement with the most-significant bit first. -decodeSigned :: BS.ByteString -> Integer -decodeSigned bs0 = - case BS.uncons bs0 of - Nothing -> 0 - Just (w0, bs) -> decodeUnsigned' i bs - where - i | w0 > 127 = toInteger w0 - 256 - | otherwise = toInteger w0 - --- | Decode a signed integer in two's complement with the most-significant bit first. -decodeUnsigned :: BS.ByteString -> Integer -decodeUnsigned = decodeUnsigned' 0 - --- | Utility function that decode a unsigned integer with most-significant bit first -decodeUnsigned' :: Integer -- Initial value to shift (result negative if this is). - -> BS.ByteString - -> Integer -decodeUnsigned' = BS.foldl f - where -- Append word to integer, shifting current integer by 8. - f :: Integer -> Word8 -> Integer - f v w = (v `shiftL` 8) .|. toInteger w - --- | Encode an unsigned integer using Google protocol buffers varint format. -encodeUnsignedVarint :: Integer -> Builder -encodeUnsignedVarint w - -- If the low 7-bits are set, msb is clear, then we are done. - | low7 == w = Builder.word8 (fromIntegral low7) - | otherwise = Builder.word8 (fromIntegral (0x80 .|. low7)) - <> encodeUnsignedVarint (w `shiftR` 7) - where low7 = w .&. 0x7F - --- | Decode a unsigned integer in Google protocol buffers varint format --- from the head of a bytestring. -decodeUnsignedVarint :: MonadFail m => BS.ByteString -> m (Integer, BS.ByteString) -decodeUnsignedVarint = go 0 - where go :: MonadFail m => Integer -> BS.ByteString -> m (Integer, BS.ByteString) - go v bs0 = - case BS.uncons bs0 of - Nothing -> fail "Unexpected premature end of unsigned varint." - Just (w,bs) | low7 == w -> return (r, bs) - | otherwise -> go r bs - where low7 = w .&. 0x7F - r = (v `shiftL` 7) .|. toInteger low7 - --- | Encode a rational as a pair with a unsigned denominator followed by a --- signed numerator. -encodeRational :: Rational -> Builder -encodeRational r = d <> n - where n = encodeSigned (numerator r) - d = encodeUnsignedVarint (denominator r) - --- | Encode a rational as a pair with a unsigned denominator followed by a --- signed numerator. -decodeRational :: MonadFail m => BS.ByteString -> m Rational -decodeRational bs0 = do - (d, bs) <- decodeUnsignedVarint bs0 - return $ decodeSigned bs % d diff --git a/crucible-server/src/Lang/Crucible/Server/MultipartOperations.hs b/crucible-server/src/Lang/Crucible/Server/MultipartOperations.hs deleted file mode 100644 index 400d8d67c..000000000 --- a/crucible-server/src/Lang/Crucible/Server/MultipartOperations.hs +++ /dev/null @@ -1,193 +0,0 @@ ------------------------------------------------------------------------ --- | --- Module : Lang.Crucible.Server.MultipartOperations --- Copyright : (c) Galois, Inc 2014-2016 --- Maintainer : Rob Dockins --- Stability : provisional --- License : BSD3 --- --- Support operations for performing loads and stores into byte-oriented --- memory strucutures. ------------------------------------------------------------------------- - -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} - -module Lang.Crucible.Server.MultipartOperations where - -import Control.Lens -import qualified Data.Parameterized.Context as Ctx -import Data.Parameterized.Nonce -import qualified Data.Text as Text - -import What4.FunctionName -import What4.ProgramLoc - -import Lang.Crucible.Analysis.Postdom -import qualified Lang.Crucible.CFG.Core as C -import qualified Lang.Crucible.CFG.Generator as Gen -import qualified Lang.Crucible.CFG.Reg as R -import Lang.Crucible.CFG.SSAConversion (toSSA) -import Lang.Crucible.FunctionHandle -import Lang.Crucible.Simulator.ExecutionTree -import Lang.Crucible.Server.Simulator -import Lang.Crucible.Syntax -import Lang.Crucible.Types - - --- | This function constructs a crucible function for storing multibyte --- values into a word map. It supports both big- and --- little-endian encoding. The first argument to the constructed function --- is a boolean: true is for big-endian; false for little-endian. --- The next argument is the base address, followed by a value to write, --- followed by the word map to write into. The bitwidth of the value to write --- must be equal to the cellsize times the number of cells to write. --- The function will return a modified word map with the data written according --- to the selected endian encoding. Despite calling this a multibyte operation, --- bytes (i.e., 8-bit cells) are not assumed; the cell width may be any positive size. -multipartStoreFn :: forall p sym addrWidth cellWidth valWidth - . (1 <= addrWidth, 1 <= cellWidth, 1 <= valWidth) - => Simulator p sym - -> NatRepr addrWidth - -> NatRepr cellWidth - -> NatRepr valWidth - -> Int -- ^ number of bytes to write - -> IO (FnHandle (EmptyCtx - ::> BoolType - ::> BVType addrWidth - ::> BVType valWidth - ::> WordMapType addrWidth (BaseBVType cellWidth) - ) - (WordMapType addrWidth (BaseBVType cellWidth))) -multipartStoreFn sim addrWidth cellWidth valWidth num = do - let nameStr = ("multipartStore_"++(show addrWidth)++"_"++(show cellWidth)++"_"++(show num)) - let name = functionNameFromText $ Text.pack nameStr - let argsRepr = Ctx.empty - Ctx.:> BoolRepr - Ctx.:> BVRepr addrWidth - Ctx.:> BVRepr valWidth - Ctx.:> WordMapRepr addrWidth (BaseBVRepr cellWidth) - let retRepr = WordMapRepr addrWidth (BaseBVRepr cellWidth) - h <- simMkHandle sim name argsRepr retRepr - sng <- newIONonceGenerator - (R.SomeCFG regCfg, _) <- Gen.defineFunction InternalPos sng h fndef - case toSSA regCfg of - C.SomeCFG cfg -> do - bindHandleToFunction sim h (UseCFG cfg (postdomInfo cfg)) - return h - - where fndef :: Gen.FunctionDef () - Maybe - (EmptyCtx - ::> BoolType - ::> BVType addrWidth - ::> BVType valWidth - ::> WordMapType addrWidth (BaseBVType cellWidth) - ) - (WordMapType addrWidth (BaseBVType cellWidth)) - IO - - fndef regs = ( Nothing, - do let endianFlag = R.AtomExpr (regs^._1) - let basePtr = R.AtomExpr (regs^._2) - let v = R.AtomExpr (regs^._3) - let wordMap = R.AtomExpr (regs^._4) - - be <- Gen.defineBlockLabel $ Gen.returnFromFunction $ - bigEndianStore addrWidth cellWidth valWidth num basePtr v wordMap - le <- Gen.defineBlockLabel $ Gen.returnFromFunction $ - littleEndianStore addrWidth cellWidth valWidth num basePtr v wordMap - - Gen.branch endianFlag be le - ) - --- | This function constructs a crucible function for loading multibyte --- values from a word map. It supports both big- and --- little-endian encoding. The first argument to the constructed function --- is a boolean: true is for big-endian; false for little-endian. --- The next argument is the base address, followed by the word map to read from. --- The result of this function is a value decoded from the based address --- using the selected endianess; its bitwidth will be the cell size times the number --- of cells to read. The fourth argument to this function is an optional default value. --- When the default is a Hothing value and any address required by this load is not defined, --- an error will result. However, if a `Just` value is given as the default, that --- default value will be the result of reading from the word map at any undefined location. --- --- Note: bytes (i.e., 8-bit cells) are not assumed; the cell width may be any positive size. -multipartLoadFn :: forall p sym addrWidth cellWidth valWidth - . (1 <= addrWidth, 1 <= cellWidth, 1 <= valWidth) - => Simulator p sym - -> NatRepr addrWidth - -> NatRepr cellWidth - -> NatRepr valWidth - -> Int -- ^ numer of cells to read - -> IO (FnHandle (EmptyCtx - ::> BoolType - ::> BVType addrWidth - ::> WordMapType addrWidth (BaseBVType cellWidth) - ::> MaybeType (BVType cellWidth) - ) - (BVType valWidth)) -multipartLoadFn sim addrWidth cellWidth valWidth num = do - let nameStr = ("multipartLoad_"++(show addrWidth)++"_"++(show cellWidth)++"_"++(show num)) - let name = functionNameFromText $ Text.pack nameStr - let argsRepr = Ctx.empty - Ctx.:> BoolRepr - Ctx.:> BVRepr addrWidth - Ctx.:> WordMapRepr addrWidth (BaseBVRepr cellWidth) - Ctx.:> MaybeRepr (BVRepr cellWidth) - let retRepr = BVRepr valWidth - h <- simMkHandle sim name argsRepr retRepr - sng <- newIONonceGenerator - (R.SomeCFG regCfg, _) <- Gen.defineFunction InternalPos sng h fndef - case toSSA regCfg of - C.SomeCFG cfg -> do - bindHandleToFunction sim h (UseCFG cfg (postdomInfo cfg)) - return h - - where fndef :: Gen.FunctionDef () - Maybe - (EmptyCtx - ::> BoolType - ::> BVType addrWidth - ::> WordMapType addrWidth (BaseBVType cellWidth) - ::> MaybeType (BVType cellWidth) - ) - (BVType valWidth) - IO - - fndef args = ( Nothing, - do let endianFlag = R.AtomExpr (args^._1) - let basePtr = R.AtomExpr (args^._2) - let wordMap = R.AtomExpr (args^._3) - let maybeDefVal = R.AtomExpr (args^._4) - - be <- Gen.newLabel - le <- Gen.newLabel - be_nodef <- Gen.newLabel - le_nodef <- Gen.newLabel - be_def <- Gen.newLambdaLabel' (BVRepr cellWidth) - le_def <- Gen.newLambdaLabel' (BVRepr cellWidth) - - Gen.defineBlock be $ Gen.branchMaybe maybeDefVal be_def be_nodef - - Gen.defineBlock le $ Gen.branchMaybe maybeDefVal le_def le_nodef - - Gen.defineBlock be_nodef $ Gen.returnFromFunction $ - bigEndianLoad addrWidth cellWidth valWidth num basePtr wordMap - - Gen.defineBlock le_nodef $ Gen.returnFromFunction $ - littleEndianLoad addrWidth cellWidth valWidth num basePtr wordMap - - Gen.defineLambdaBlock be_def $ \def -> Gen.returnFromFunction $ - bigEndianLoadDef addrWidth cellWidth valWidth num basePtr wordMap def - - Gen.defineLambdaBlock le_def $ \def -> Gen.returnFromFunction $ - littleEndianLoadDef addrWidth cellWidth valWidth num basePtr wordMap def - - Gen.branch endianFlag be le - ) diff --git a/crucible-server/src/Lang/Crucible/Server/Requests.hs b/crucible-server/src/Lang/Crucible/Server/Requests.hs deleted file mode 100644 index 0ec9f3cd7..000000000 --- a/crucible-server/src/Lang/Crucible/Server/Requests.hs +++ /dev/null @@ -1,625 +0,0 @@ ------------------------------------------------------------------------ --- | --- Module : Lang.Crucible.Server.Requests --- Copyright : (c) Galois, Inc 2014-2016 --- Maintainer : Rob Dockins --- Stability : provisional --- License : BSD3 --- --- Code for handling requests from clients. ------------------------------------------------------------------------- - -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE EmptyCase #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ViewPatterns #-} - -module Lang.Crucible.Server.Requests - ( logMsg - , fulfillRequests - , BackendSpecificRequests(..) - ) where - -#if !MIN_VERSION_base(4,13,0) -import Control.Monad.Fail( MonadFail ) -#endif - -import Control.Exception -import Control.Lens -import Control.Monad -import Control.Monad.State.Strict -import Data.IORef -import Data.Foldable (toList) -import Data.Typeable -import qualified Data.Sequence as Seq -import qualified Data.Text as Text -import qualified Data.Parameterized.Context as Ctx -import Prettyprinter (layoutPretty, LayoutOptions(..), PageWidth(..)) -import Prettyprinter.Render.Text (renderIO) -import System.Exit -import System.IO - -import Data.HPB - -import qualified Data.Parameterized.Map as MapF -import Data.Parameterized.Some - -import What4.Config -import What4.FunctionName -import What4.Concrete -import What4.Interface - -import Lang.Crucible.Analysis.Postdom -import Lang.Crucible.CFG.Expr -import qualified Lang.Crucible.CFG.Core as C -import qualified Lang.Crucible.CFG.Reg as R -import Lang.Crucible.CFG.SSAConversion (toSSA) - -import Lang.Crucible.Backend -import qualified Lang.Crucible.Proto as P -import Lang.Crucible.Simulator.CallFrame (SomeHandle(..)) -import qualified Lang.Crucible.Simulator.Evaluation as Sim -import Lang.Crucible.Simulator.EvalStmt (executeCrucible, genericToExecutionFeature) -import Lang.Crucible.Simulator.ExecutionTree -import Lang.Crucible.Simulator.GlobalState -import Lang.Crucible.Simulator.OverrideSim -import Lang.Crucible.Simulator.RegMap -import Lang.Crucible.Types -import Lang.Crucible.Utils.MonadVerbosity - -import Lang.Crucible.Server.MultipartOperations -import Lang.Crucible.Server.Simulator -import Lang.Crucible.Server.Translation -import Lang.Crucible.Server.TypeConv -import Lang.Crucible.Server.ValueConv - ------------------------------------------------------------------------- --- Utilities - -data CrucibleNotImplementedException - = CrucibleNotImplemented String - deriving (Show, Typeable) -instance Exception CrucibleNotImplementedException where - -data FunctionNotFoundException - = FunctionNotFound Text - deriving (Show, Typeable) -instance Exception FunctionNotFoundException where - - -nyi :: String -> a -nyi nm = throw $ CrucibleNotImplemented (nm ++ " unimplemented.") - -getHead :: MonadFail m => Seq a -> m (a, Seq a) -getHead s = - case Seq.viewl s of - Seq.EmptyL -> fail "Unexpected end of arguments." - h Seq.:< t -> return (h, t) - -logMsg :: String -> IO () -logMsg = hPutStrLn stderr - - -fulfillUseCFGRequest :: IsSymInterface sym - => Simulator p sym - -> P.Cfg - -> IO () -fulfillUseCFGRequest sim pg = - unpackCFG sim pg $ \g -> do - case toSSA g of - C.SomeCFG g' -> - do bindHandleToFunction sim (R.cfgHandle g) $! (UseCFG g' (postdomInfo g')) - sendAckResponse sim - -fulfillPrintCFGRequest :: IsSymInterface sym - => Simulator p sym - -> P.Cfg - -> IO () -fulfillPrintCFGRequest sim pg = - unpackCFG sim pg $ \g -> do - h <- printHandle <$> readIORef (simContext sim) - -- FIXME, implement pretty printer for register-CFGs - case toSSA g of - C.SomeCFG g' -> do - let opts = LayoutOptions (AvailablePerLine maxBound 1.0) - renderIO h $ layoutPretty opts $ C.ppCFG False g' - hFlush h - sendAckResponse sim - ------------------------------------------------------------------------- --- RunCall request - -parseArgs :: IsSymInterface sym - => Simulator p sym - -> CtxRepr ctx - -> Seq P.Value - -> IO (Ctx.Assignment (RegEntry sym) ctx) -parseArgs sim types s = - case Ctx.viewAssign types of - Ctx.AssignEmpty -> do - when (not (Seq.null s)) $ do - fail $ "More arguments than expected." - return Ctx.empty - Ctx.AssignExtend c tp -> do - case Seq.viewr s of - s' Seq.:> v -> do - Ctx.extend <$> parseArgs sim c s' - <*> (checkedRegEntry tp =<< fromProtoValue sim v) - Seq.EmptyR -> fail "Expected more arguments" - -fulfillRunCallRequest :: IsSymInterface sym - => Simulator p sym - -> P.Value - -> Seq P.Value - -> IO () -fulfillRunCallRequest sim f_val encoded_args = do - Some (RegEntry f_tp f) <- fromProtoValue sim f_val - case f_tp of - FunctionHandleRepr arg_types res_tp -> do - args <- parseArgs sim arg_types encoded_args - - -- TODO: Redirect standard IO so that we can print messages. - ctx <- readIORef (simContext sim) - - let simSt = InitialState ctx emptyGlobals (serverErrorHandler sim) res_tp - $ runOverrideSim res_tp (regValue <$> callFnVal f (RegMap args)) - -- Send messages to server with bytestring. - exec_res <- executeCrucible (map genericToExecutionFeature (simExecFeatures sim)) simSt - case exec_res of - FinishedResult ctx' (TotalRes (GlobalPair r _globals)) -> do - writeIORef (simContext sim) $! ctx' - sendCallReturnValue sim =<< toProtoValue sim r - FinishedResult ctx' (PartialRes _ _ (GlobalPair r _globals) _) -> do - writeIORef (simContext sim) $! ctx' - sendCallReturnValue sim =<< toProtoValue sim r - AbortedResult ctx' _ -> do - writeIORef (simContext sim) $! ctx' - sendCallAllAborted sim - TimeoutResult exst -> do - writeIORef (simContext sim) $! execStateContext exst - sendCallAllAborted sim -- FIXME, this isn't really right... - - _ -> do - sendCallPathAborted sim - P.AbortedNonFunction - "Could not interpret first argument as function." - [] - sendCallAllAborted sim - ------------------------------------------------------------------------- --- GetConfigValue request - -fulfillGetConfigValueRequest - :: IsSymInterface sym - => Simulator p sym - -- ^ Simulator to run. - -> Text - -- ^ Name of the configuration setting - -> IO () -fulfillGetConfigValueRequest sim nm = - do ctx <- getSimContext sim - let sym = ctx^.ctxSymInterface - cfg = getConfiguration sym - Some optSetting <- getOptionSettingFromText nm cfg - getOption optSetting >>= \case - Just v -> - do e <- concreteToSym sym v - pv <- toProtoValue sim (RegEntry (baseToType (concreteType v)) e) - let resp = - mempty & P.simulatorValueResponse_successful .~ True - & P.simulatorValueResponse_value .~ pv - let gresp = - mempty & P.genericResponse_code .~ P.SimulatorValueGenResp - & P.genericResponse_simValResponse .~ resp - sendResponse sim gresp - Nothing -> - do let msg = "Config option " <> nm <> " is not set." - gresp = - mempty & P.genericResponse_code .~ P.ExceptionGenResp - & P.genericResponse_message .~ msg - sendResponse sim gresp - ------------------------------------------------------------------------- --- SetConfigValue request - -fulfillSetConfigValueRequest - :: IsSymInterface sym - => Simulator p sym - -- ^ Simulator to run. - -> Text - -- ^ Name of the configuration setting - -> Seq P.Value - -- ^ Value of the configuration setting - -> IO () -fulfillSetConfigValueRequest sim nm vals = - do ctx <- getSimContext sim - let sym = ctx^.ctxSymInterface - cfg = getConfiguration sym - case Seq.viewl vals of - val Seq.:< (Seq.null -> True) -> - do Some (RegEntry tpr v) <- fromProtoValue sim val - Some optSetting <- getOptionSettingFromText nm cfg - let tpr' = baseToType (configOptionType (optionSettingName optSetting)) - case testEquality tpr tpr' of - Just Refl - | Just x <- asConcrete v -> - do res <- setOption optSetting x - case optionSetError res of - Just msg -> fail (show msg) - Nothing -> - do let ws = toList (optionSetWarnings res) - unless (null ws) - (sendTextResponse sim (Text.unlines (map (Text.pack . show) ws))) - sendAckResponse sim - - | otherwise -> - fail $ unlines [ "Expected concrete value of type " ++ show tpr' - , "but was given a symbolic value." - ] - - Nothing -> fail $ unlines [ "Expected value of type " ++ show tpr' - , "when setting configuration value " ++ show nm - , "but was given a value of type " ++ show tpr - ] - - _ -> fail "Expected a single argument for SetConfigValue" - ------------------------------------------------------------------------- --- SetVerbosity request - -fulfillSetVerbosityRequest - :: IsSymInterface sym - => Simulator p sym - -- ^ Simulator to run. - -> Seq P.Value - -- ^ Verbosity level to set - -> IO () -fulfillSetVerbosityRequest sim args = do - unless (Seq.length args == 1) - (fail "expected exactly one argument to SetVerbosity request") - v <- fromProtoValue sim (Seq.index args 0) - case v of - Some (RegEntry NatRepr nv) | Just n <- asNat nv -> do - ctx <- readIORef (simContext sim) - let cfg = getConfiguration (ctx^.ctxSymInterface) - let h = printHandle ctx - verbSetting <- getOptionSetting verbosity cfg - oldv <- fromInteger <$> liftIO (getOpt verbSetting) - ws <- withVerbosity h oldv $ liftIO (setOpt verbSetting (toInteger n)) - unless (null ws) (sendTextResponse sim (Text.unlines (map (Text.pack . show) ws))) - sendAckResponse sim - _ -> fail "expected a natural number argument to SetVerbosity request" - ------------------------------------------------------------------------- --- ApplyPrimitive request - -fulfillApplyPrimitiveRequest :: IsSymInterface sym - => Simulator p sym - -- ^ Simulator to run. - -> P.PrimitiveOp - -- ^ Primitive operation to apply. - -> Seq P.Value - -- ^ Arguments to primitive op. - -> P.CrucibleType - -- ^ Optional Bitwidth passed into message. - -- Defaults to zero. - -> IO () -fulfillApplyPrimitiveRequest sim p_op args res_type = do - -- Run apply primitive - mv <- try $ convertToCrucibleApp (fromProtoValue sim) parseNatRepr p_op args res_type - case mv of - Left e -> do - let msg = fromString (show (e :: SomeException)) - let resp = - mempty & P.simulatorValueResponse_successful .~ False - & P.simulatorValueResponse_error_msg .~ msg - let gresp = - mempty & P.genericResponse_code .~ P.SimulatorValueGenResp - & P.genericResponse_simValResponse .~ resp - sendResponse sim gresp - Right (Some a) -> do - let logLn _ _ = return () - sym <- getInterface sim - r <- Sim.evalApp sym MapF.empty logLn (\_ x -> case x of) (\(RegEntry _ v) -> return v) a - pv <- toProtoValue sim (RegEntry (appType a) r) - let resp = - mempty & P.simulatorValueResponse_successful .~ True - & P.simulatorValueResponse_value .~ pv - let gresp = - mempty & P.genericResponse_code .~ P.SimulatorValueGenResp - & P.genericResponse_simValResponse .~ resp - sendResponse sim gresp - - ----------------------------------------------------------------------------- --- GetHandleByName request - -fulfillGetHandleByNameRequest :: Simulator p sim -> Text -> IO () -fulfillGetHandleByNameRequest sim name = do - respondToPredefinedHandleRequest sim (NamedPredefHandle (functionNameFromText name)) $ do - -- if the function is not already in the cache, throw an exception - throw $ FunctionNotFound name - ----------------------------------------------------------------------------- --- GetMultipartStoreHandle request - -fulfillGetMultipartStoreHandleRequest :: Simulator p sym -> P.HandleInfo -> IO () -fulfillGetMultipartStoreHandleRequest sim hinfo = do - let c_arg_types = hinfo^.P.handleInfo_arg_types - c_ret_type = hinfo^.P.handleInfo_return_type - - when (Seq.length c_arg_types /= 4) - (fail ("expected 4 types for multipart store handle")) - - argty1 <- fromProtoType (Seq.index c_arg_types 0) - argty2 <- fromProtoType (Seq.index c_arg_types 1) - argty3 <- fromProtoType (Seq.index c_arg_types 2) - argty4 <- fromProtoType (Seq.index c_arg_types 3) - rettype <- fromProtoType c_ret_type - - case (argty1, argty2, argty3, argty4, rettype) of - ( Some BoolRepr - , Some (BVRepr addrWidth) - , Some (BVRepr valWidth) - , Some (WordMapRepr addrWidth' (BaseBVRepr cellWidth)) - , Some (WordMapRepr addrWidth'' (BaseBVRepr cellWidth')) - ) - | Just Refl <- testEquality addrWidth addrWidth' - , Just Refl <- testEquality addrWidth addrWidth'' - , Just Refl <- testEquality cellWidth cellWidth' - , Just LeqProof <- isPosNat addrWidth - , Just LeqProof <- isPosNat cellWidth - , Just LeqProof <- isPosNat valWidth - -> do let addrInt = fromIntegral (natValue addrWidth) - let valInt = fromIntegral (natValue valWidth) - let cellInt = fromIntegral (natValue cellWidth) - let num = valInt `div` cellInt - when (num * cellInt /= valInt) - (fail $ unwords [ "value bitwidth must be a multiple of the wordmap cell width for multipart stores:" - , show valInt - , show cellInt - ]) - respondToPredefinedHandleRequest sim (MultiPartStoreHandle addrInt cellInt num) $ - SomeHandle <$> multipartStoreFn sim addrWidth cellWidth valWidth num - - _ -> (fail $ unwords [ "illegal types to multipart store", show argty1, show argty2, - show argty3, show argty4, show rettype]) - - ----------------------------------------------------------------------------- --- GetMultipartLoadHandle request - -fulfillGetMultipartLoadHandleRequest :: Simulator p sym -> P.HandleInfo -> IO () -fulfillGetMultipartLoadHandleRequest sim hinfo = do - let c_arg_types = hinfo^.P.handleInfo_arg_types - c_ret_type = hinfo^.P.handleInfo_return_type - - when (Seq.length c_arg_types /= 4) - (fail ("expected 4 types for multipart load handle")) - - argty1 <- fromProtoType (Seq.index c_arg_types 0) - argty2 <- fromProtoType (Seq.index c_arg_types 1) - argty3 <- fromProtoType (Seq.index c_arg_types 2) - argty4 <- fromProtoType (Seq.index c_arg_types 3) - rettype <- fromProtoType c_ret_type - - case (argty1, argty2, argty3, argty4, rettype) of - ( Some BoolRepr - , Some (BVRepr addrWidth) - , Some (WordMapRepr addrWidth' (BaseBVRepr cellWidth)) - , Some (MaybeRepr (BVRepr cellWidth')) - , Some (BVRepr valWidth) - ) - | Just Refl <- testEquality addrWidth addrWidth' - , Just Refl <- testEquality cellWidth cellWidth' - , Just LeqProof <- isPosNat addrWidth - , Just LeqProof <- isPosNat cellWidth - , Just LeqProof <- isPosNat valWidth - -> do let addrInt = fromIntegral (natValue addrWidth) - let valInt = fromIntegral (natValue valWidth) - let cellInt = fromIntegral (natValue cellWidth) - let num = valInt `div` cellInt - when (num * cellInt /= valInt) - (fail $ unwords [ "value bitwidth must be a multiple of the wordmap cell width for multipart loads:" - , show valInt - , show cellInt - ]) - respondToPredefinedHandleRequest sim (MultiPartLoadHandle addrInt cellInt num) $ - SomeHandle <$> multipartLoadFn sim addrWidth cellWidth valWidth num - - _ -> (fail $ unwords [ "illegal types to multipart load", show argty1, show argty2, - show argty3, show argty4, show rettype]) - -------------------------------------------------------------------------- --- PrintTermHandle Request - -printTermOverride :: (IsSymInterface sym) - => BaseTypeRepr ty - -> Override p sym () (EmptyCtx ::> BaseToType ty) UnitType -printTermOverride tpr = - mkOverride (functionNameFromText (Text.pack ("printTerm_"++show tpr))) $ do - RegMap args <- getOverrideArgs - let p = regValue $ args^._1 - let doc = printSymExpr p - h <- printHandle <$> getContext - let opts = LayoutOptions (AvailablePerLine maxBound 1.0) - liftIO $ renderIO h $ layoutPretty opts doc - liftIO $ hPutStrLn h "" - liftIO $ hFlush h - -buildPrintTermOverride - :: (IsSymInterface sym) - => Simulator p sym - -> BaseTypeRepr ty - -> IO SomeHandle -buildPrintTermOverride sim tpr = - SomeHandle <$> simOverrideHandle sim (Ctx.empty Ctx.:> baseToType tpr) UnitRepr - (printTermOverride tpr) - -fulfillPrintTermHandleRequest :: IsSymInterface sym - => Simulator p sym - -> TypeRepr ty - -> IO () -fulfillPrintTermHandleRequest sim tpr = do - respondToPredefinedHandleRequest sim (PrintTermHandle (Some tpr)) $ - case tpr of - BoolRepr -> buildPrintTermOverride sim BaseBoolRepr - NatRepr -> buildPrintTermOverride sim BaseNatRepr - IntegerRepr -> buildPrintTermOverride sim BaseIntegerRepr - RealValRepr -> buildPrintTermOverride sim BaseRealRepr - BVRepr w | Just LeqProof <- isPosNat w -> - buildPrintTermOverride sim (BaseBVRepr w) - _ -> fail $ "Cannot print values of type: "++show tpr - ------------------------------------------------------------------------- --- RegisterHandle request - -fulfillRegisterHandleRequest :: IsSymInterface sym - => Simulator p sym - -> P.HandleInfo - -> IO () -fulfillRegisterHandleRequest sim hinfo = do - let nm = hinfo^.P.handleInfo_display_name - c_arg_types = hinfo^.P.handleInfo_arg_types - c_ret_type = hinfo^.P.handleInfo_return_type - - Some arg_types <- fromProtoTypeSeq c_arg_types - Some ret_type <- fromProtoType c_ret_type - h <- simMkHandle sim (functionNameFromText nm) arg_types ret_type - - let resp = mempty & P.registerHandleResponse_index .~ handleRef h - let gresp = mempty - & P.genericResponse_code .~ P.RegisterHandleGenResp - & P.genericResponse_regHandleResponse .~ resp - - sendResponse sim $ gresp - ------------------------------------------------------------------------- --- main - -handleOneRequest :: IsSymInterface sym - => Simulator p sym - -> BackendSpecificRequests p sym - -> P.Request - -> IO () -handleOneRequest sim addlRequests request = - case request^.P.request_code of - P.RegisterHandle -> do - let hinfo = request^.P.request_handle - fulfillRegisterHandleRequest sim hinfo - P.UseCFG -> do - fulfillUseCFGRequest sim (request^.P.request_cfg) - P.RunCall -> do - let all_args = request^.P.request_args - -- Get function aand arguments. - (fn, args) <- getHead all_args - -- Fulfill request - fulfillRunCallRequest sim fn args - P.ReleaseValue -> do - releaseRegEntryRef sim (request^.P.request_index) - P.SetVerbosity -> do - let args = request^.P.request_args - fulfillSetVerbosityRequest sim args - P.GetConfigValue -> do - let nm = request^.P.request_config_setting_name - fulfillGetConfigValueRequest sim nm - P.SetConfigValue -> do - let nm = request^.P.request_config_setting_name - let args = request^.P.request_args - fulfillSetConfigValueRequest sim nm args - P.ApplyPrimitive -> do - let p_op = request^.P.request_prim_op - let args = request^.P.request_args - let res_type = request^.P.request_result_type - fulfillApplyPrimitiveRequest sim p_op args res_type - P.PrintCFG -> do - fulfillPrintCFGRequest sim (request^.P.request_cfg) - P.GetHandleByName -> do - fulfillGetHandleByNameRequest sim (request^.P.request_handle^.P.handleInfo_display_name) - P.SymbolicHandle -> do - fulfillSymbolHandleRequest addlRequests sim (request^.P.request_varType) - P.PrintTermHandle -> do - Some tyr <- fromProtoType (request^.P.request_type) - fulfillPrintTermHandleRequest sim tyr - P.MultipartStoreHandle -> do - fulfillGetMultipartStoreHandleRequest sim (request^.P.request_handle) - P.MultipartLoadHandle -> do - fulfillGetMultipartLoadHandleRequest sim (request^.P.request_handle) - P.ExportModel -> do - let path = request^.P.request_export_path - let all_args = request^.P.request_args - let format = request^.P.request_export_format - fulfillExportModelRequest addlRequests sim format path all_args - - P.CompileVerificationOverride -> do - let harness = request^.P.request_verification_harness - fulfillCompileVerificationOverrideRequest addlRequests sim harness - - P.SimulateVerificationHarness -> do - let harness = request^.P.request_verification_harness - let opts = request^.P.request_verification_sim_options - fullfillSimulateVerificationHarnessRequest addlRequests sim harness opts - - P.ResumeSimulation -> do - nyi "resumeSimulation" - P.UseOverride -> do - nyi "useOverride" - - P.KillSimulator -> fail "kill simulator unexpected" - P.UnknownMessage -> fail "unknown message" - - - -data BackendSpecificRequests p sym - = BackendSpecificRequests - { fulfillExportModelRequest - :: Simulator p sym - -> P.ExportFormat - -> Text - -> Seq P.Value - -> IO () - , fulfillSymbolHandleRequest - :: Simulator p sym - -> P.VarType - -> IO () - , fulfillCompileVerificationOverrideRequest - :: Simulator p sym - -> P.VerificationHarness - -> IO () - , fullfillSimulateVerificationHarnessRequest - :: Simulator p sym - -> P.VerificationHarness - -> P.VerificationSimulateOptions - -> IO () - } - --- | Loop for fulfilling request -fulfillRequests :: IsSymInterface sym - => Simulator p sym - -> BackendSpecificRequests p sym - -> IO () -fulfillRequests sim addlRequests = do - -- logMsg "Waiting for request" - request <- getDelimited (requestHandle sim) - -- logMsg "Received request" - case request^.P.request_code of - P.KillSimulator -> exitSuccess - P.UnknownMessage -> do - hPutStrLn stderr "Could not interpret message." - exitWith (ExitFailure (-1)) - _ -> do - r <- try (handleOneRequest sim addlRequests request) - case r of - Left ex -> sendExceptionResponse sim ex - Right _ -> return () - fulfillRequests sim addlRequests diff --git a/crucible-server/src/Lang/Crucible/Server/SAWOverrides.hs b/crucible-server/src/Lang/Crucible/Server/SAWOverrides.hs deleted file mode 100644 index 395d787d6..000000000 --- a/crucible-server/src/Lang/Crucible/Server/SAWOverrides.hs +++ /dev/null @@ -1,344 +0,0 @@ ------------------------------------------------------------------------ --- | --- Module : Lang.Crucible.Server.SAWOverrides --- Copyright : (c) Galois, Inc 2014-2016 --- Maintainer : Rob Dockins --- Stability : provisional --- License : BSD3 --- --- Function implementations that are specific to the SAW backend. ------------------------------------------------------------------------- - -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} - -module Lang.Crucible.Server.SAWOverrides where - -import Control.Lens -import Control.Monad.IO.Class -import Data.Foldable (toList) -import Data.IORef -import qualified Data.Parameterized.Context as Ctx -import Data.Parameterized.Some ---import Data.Sequence (Seq) -import qualified Data.Sequence as Seq -import qualified Data.Text as Text -import qualified Data.Vector as V -import System.Directory -import System.FilePath - -import What4.Config -import What4.Interface -import qualified What4.Expr.Builder as SB - -import Lang.Crucible.Backend -import qualified Lang.Crucible.Backend.SAWCore as SAW -import qualified Lang.Crucible.Proto as P -import Lang.Crucible.Server.CryptolEnv -import Lang.Crucible.Server.Requests -import Lang.Crucible.Server.Simulator -import Lang.Crucible.Server.TypeConv ---import Lang.Crucible.Server.TypedTerm -import Lang.Crucible.Server.ValueConv -import Lang.Crucible.Server.Verification.Harness -import Lang.Crucible.Server.Verification.Override -import Lang.Crucible.Simulator.CallFrame (SomeHandle(..)) -import Lang.Crucible.Simulator.ExecutionTree -import Lang.Crucible.Simulator.EvalStmt (executeCrucible,genericToExecutionFeature) -import Lang.Crucible.Simulator.GlobalState -import Lang.Crucible.Simulator.OverrideSim -import Lang.Crucible.Simulator.RegMap -import Lang.Crucible.Types - -import qualified Verifier.SAW.ExternalFormat as SAW -import qualified Verifier.SAW.SharedTerm as SAW -import qualified Verifier.SAW.Recognizer as SAW - -sawServerOptions :: [ConfigDesc] -sawServerOptions = [] - -sawServerOverrides :: [Simulator p (SAWBack n) -> IO SomeHandle] -sawServerOverrides = [] - -data SAWCrucibleServerPersonality = - SAWCrucibleServerPersonality - { _sawServerCryptolEnv :: CryptolEnv - } - -sawServerCryptolEnv :: Lens' SAWCrucibleServerPersonality CryptolEnv -sawServerCryptolEnv = lens _sawServerCryptolEnv (\s v -> s{ _sawServerCryptolEnv = v }) - -initSAWServerPersonality :: - SAWBack n -> - IO SAWCrucibleServerPersonality -initSAWServerPersonality sym = - do sc <- SAW.sawBackendSharedContext sym - cryEnv <- initCryptolEnv sc - return SAWCrucibleServerPersonality - { _sawServerCryptolEnv = cryEnv - } - -sawBackendRequests :: BackendSpecificRequests SAWCrucibleServerPersonality (SAWBack n) -sawBackendRequests = - BackendSpecificRequests - { fulfillExportModelRequest = sawFulfillExportModelRequest - , fulfillSymbolHandleRequest = sawFulfillSymbolHandleRequest - , fulfillCompileVerificationOverrideRequest = sawFulfillCompileVerificationOverrideRequest - , fullfillSimulateVerificationHarnessRequest = sawFulfillSimulateVerificationHarnessRequest - } - - -sawFulfillCompileVerificationOverrideRequest - :: forall n - . Simulator SAWCrucibleServerPersonality (SAWBack n) - -> P.VerificationHarness - -> IO () -sawFulfillCompileVerificationOverrideRequest sim harness = - do sc <- SAW.sawBackendSharedContext =<< getInterface sim - cryEnv <- view (cruciblePersonality . sawServerCryptolEnv) <$> readIORef (simContext sim) - let hout = sendTextResponse sim . Text.pack - - (cryEnv',harness') <- processHarness hout sc cryEnv harness - -- NB: we explicitly do not store the modified cryEnv' back into the simContext; - -- the modifications to the environment produced by processing a harness are only - -- scoped over the harness itself. - - let addrWidth = verificationAddressWidth harness' - let regFileWidth = verificationRegFileWidth harness' - - case someNat (toInteger regFileWidth) of - Just (Some rw) | Just LeqProof <- isPosNat rw -> - case someNat (toInteger addrWidth) of - Just (Some w) | Just LeqProof <- isPosNat w -> - - do fnhandle <- verificationHarnessOverrideHandle sim rw w cryEnv' harness' - let response = displayHarness (fmap snd harness') - - sendTextResponse sim response - sendPredefinedHandleResponse sim fnhandle - - _ -> fail ("Improper address width given for verification harness: " ++ show addrWidth) - _ -> fail ("Improper register file width given for verification harness: " ++ show regFileWidth) - - -sawFulfillSimulateVerificationHarnessRequest :: - Simulator SAWCrucibleServerPersonality (SAWBack n) -> - P.VerificationHarness -> - P.VerificationSimulateOptions -> - IO () -sawFulfillSimulateVerificationHarnessRequest sim harness opts = - do sym <- getInterface sim - ctx <- readIORef (simContext sim) - let hout = sendTextResponse sim . Text.pack - - sc <- SAW.sawBackendSharedContext sym - let cryEnv = ctx^.cruciblePersonality.sawServerCryptolEnv - - (cryEnv', harness') <- processHarness hout sc cryEnv harness - -- NB: we explicitly do not store the modified cryEnv' back into the simContext; - -- the modifications to the environment produced by processing a harness are only - -- scoped over the harness itself. - - let addrWidth = verificationAddressWidth harness' - let regFileWidth = verificationRegFileWidth harness' - - -- Clear all proof-management context and restore it afterwards - SAW.inFreshNamingContext sym $ - case someNat (toInteger regFileWidth) of - Just (Some rw) | Just LeqProof <- isPosNat rw -> - case someNat (toInteger addrWidth) of - Just (Some w) | Just LeqProof <- isPosNat w -> - do pc <- regValue <$> (checkedRegEntry (BVRepr w) =<< fromProtoValue sim (opts^.P.verificationSimulateOptions_start_pc)) - sp <- regValue <$> (checkedRegEntry (BVRepr w) =<< fromProtoValue sim (opts^.P.verificationSimulateOptions_start_stack)) - ret <- regValue <$> (checkedRegEntry (BVRepr w) =<< fromProtoValue sim (opts^.P.verificationSimulateOptions_return_address)) - fn <- regValue <$> (checkedRegEntry (verifFnRepr rw w) =<< fromProtoValue sim (opts^.P.verificationSimulateOptions_program)) - - let simSt = InitialState ctx emptyGlobals (serverErrorHandler sim) UnitRepr - $ runOverrideSim UnitRepr - (simulateHarness sim rw w sc cryEnv' harness' pc sp ret fn) - - exec_res <- executeCrucible (map genericToExecutionFeature (simExecFeatures sim)) simSt - case exec_res of - TimeoutResult exst -> do - let ctx' = execStateContext exst - sendTextResponse sim "Simulation timed out!" - writeIORef (simContext sim) $! ctx' - FinishedResult ctx' (TotalRes (GlobalPair _r _globals)) -> do - sendTextResponse sim "Finished!" - writeIORef (simContext sim) $! ctx' - FinishedResult ctx' (PartialRes _ _ (GlobalPair _r _globals) _) -> do - sendTextResponse sim "Finished, some paths aborted!" - writeIORef (simContext sim) $! ctx' - AbortedResult ctx' _ -> do - sendTextResponse sim "All paths aborted!" - writeIORef (simContext sim) $! ctx' - handleProofObligations sim sym opts - - _ -> fail ("Improper address width given for verification harness: " ++ show addrWidth) - _ -> fail ("Improper register file width given for verification harness: " ++ show regFileWidth) - -handleProofObligations :: - Simulator SAWCrucibleServerPersonality (SAWBack n) -> - SAWBack n -> - P.VerificationSimulateOptions -> - IO () -handleProofObligations sim sym opts = - do obls <- getProofObligations sym - clearProofObligations sym - dirPath <- makeAbsolute (Text.unpack (opts^.P.verificationSimulateOptions_output_directory)) - createDirectoryIfMissing True dirPath - if opts^.P.verificationSimulateOptions_separate_obligations - then handleSeparateProofObligations sim sym dirPath obls - else handleSingleProofObligation sim sym dirPath obls - sendAckResponse sim - -handleSeparateProofObligations :: - Simulator SAWCrucibleServerPersonality (SAWBack n) -> - SAWBack n -> - FilePath -> - ProofObligations (SAWBack n) -> - IO () -handleSeparateProofObligations _sim _sym _dir _obls = fail "FIXME separate proof obligations!" - -handleSingleProofObligation :: - Simulator SAWCrucibleServerPersonality (SAWBack n) -> - SAWBack n -> - FilePath -> - ProofObligations (SAWBack n) -> - IO () -handleSingleProofObligation _sim sym dir obls = - do createDirectoryIfMissing True {- create parents -} dir - -- TODO: there is probably a much more efficient way to do this - -- that more directly follows the structure of the proof goal tree - preds <- mapM (sequentToSC sym) (proofGoalsToList obls) - totalPred <- andAllOf sym folded preds - sc <- SAW.sawBackendSharedContext sym - exts <- toList <$> SAW.getInputs sym - finalPred <- SAW.scAbstractExts sc exts =<< SAW.toSC sym totalPred - - let fname = dir "obligations.saw" - writeFile fname (SAW.scWriteExternal finalPred) - -sequentToSC :: - SAWBack n -> - ProofObligation (SAWBack n) -> - IO (Pred (SAWBack n)) -sequentToSC sym (ProofGoal assumes goal) = - do assume <- andAllOf sym (folded.labeledPred) assumes - impliesPred sym assume (goal^.labeledPred) - -sawFulfillExportModelRequest - :: forall p n - . Simulator p (SAWBack n) - -> P.ExportFormat - -> Text.Text - -> Seq.Seq P.Value - -> IO () -sawFulfillExportModelRequest sim P.ExportSAW path vals = do - sym <- getInterface sim - st <- readIORef $ SB.sbStateManager sym - - let f :: Some (RegEntry (SAWBack n)) - -> IO (Maybe (SAW.Term, SAW.Term)) - f (Some (RegEntry (VectorRepr tp) v)) = do - (v' :: [Maybe (SAW.Term, SAW.Term)]) - <- traverse (\x -> f (Some (RegEntry tp x))) $ V.toList v - case sequence v' of - Nothing -> return Nothing - Just [] -> return Nothing -- FIXME? fail on empty vectors... - Just vs@((_,vtp):_) -> do - x' <- SAW.scVector (SAW.saw_ctx st) vtp (map fst vs) - tp' <- SAW.scTypeOf (SAW.saw_ctx st) x' - return (Just (x',tp')) - f (Some r) = asSymExpr r (\x -> do - x' <- SAW.toSC sym x - tp <- SAW.scTypeOf (SAW.saw_ctx st) x' - return $ Just (x',tp)) - (return Nothing) - vals' <- traverse f =<< mapM (fromProtoValue sim) (toList vals) - case map fst <$> sequence vals' of - Nothing -> fail "Could not translate values for SAW export" - Just scs -> do - tm <- case scs of - [] -> fail "No terms passed to SAW export" - [x] -> return x - _ -> SAW.scTuple (SAW.saw_ctx st) scs - exts <- toList <$> readIORef (SAW.saw_inputs st) - tm' <- SAW.scAbstractExts (SAW.saw_ctx st) exts tm - writeFile (Text.unpack path) (SAW.scWriteExternal tm') - let v = mempty & P.value_code .~ P.UnitValue - sendCallReturnValue sim v - -sawFulfillExportModelRequest _sim P.ExportAIGER _path _vals = do - fail "SAW backend does not implement AIGER export" - - -sawTypeFromTypeVar :: SAWBack n - -> SAW.SharedContext - -> [Int] - -> BaseTypeRepr tp - -> IO SAW.Term -sawTypeFromTypeVar sym sc [] bt = SAW.baseSCType sym sc bt -sawTypeFromTypeVar sym sc (x:xs) bt = do - txs <- sawTypeFromTypeVar sym sc xs bt - n <- SAW.scNat sc (fromIntegral x) - SAW.scVecType sc n txs - --- | Returns override for creating a given variable associated with the given type. -symbolicOverride :: forall p n tp - . SAW.SharedContext - -> [Int] - -> SAW.Term - -> TypeRepr tp - -> Override p (SAWBack n) () EmptyCtx tp -symbolicOverride sc dims0 sawTp0 tpr0 = do - mkOverride' "symbolic" tpr0 $ do - sym <- getSymInterface - - t <- liftIO $ SAW.sawCreateVar sym "x" sawTp0 - liftIO $ buildVecs dims0 sym sawTp0 tpr0 t - - where buildVecs :: [Int] - -> SAWBack n - -> SAW.Term - -> TypeRepr tp' - -> SAW.Term - -> IO (RegValue (SAWBack n) tp') - - buildVecs [] sym _ tpr t = - case asBaseType tpr of - AsBaseType bt -> SAW.bindSAWTerm sym bt t - NotBaseType -> fail $ "Unsupported SAW base type" ++ show tpr - - buildVecs (x:xs) sym sawTp (VectorRepr tpr) t = do - case SAW.asVecType sawTp of - Nothing -> fail $ "Expected vector type, but got " ++ show sawTp - Just (n SAW.:*: sawTp') -> - V.generateM x (\i -> do - n' <- SAW.scNat sc n - i' <- SAW.scNat sc (fromIntegral i) - t' <- SAW.scAt sc n' sawTp' t i' - buildVecs xs sym sawTp' tpr t' - ) - - buildVecs _ _ _ tpr _ = do - fail $ "Unsupported SAW variable type: " ++ show tpr - -sawFulfillSymbolHandleRequest :: Simulator p (SAWBack n) -> P.VarType -> IO () -sawFulfillSymbolHandleRequest sim proto_tp = do - let dims = proto_tp^.P.varType_dimensions - let dims' = map fromIntegral $ toList dims - Some tpr <- crucibleTypeFromProtoVarType proto_tp - Some vtp <- varTypeFromProto proto_tp - sym <- getInterface sim - st <- readIORef $ SB.sbStateManager sym - sawTp <- sawTypeFromTypeVar sym (SAW.saw_ctx st) dims' vtp - - respondToPredefinedHandleRequest sim (SymbolicHandle dims' (Some vtp)) $ do - let o = symbolicOverride (SAW.saw_ctx st) dims' sawTp tpr - SomeHandle <$> simOverrideHandle sim Ctx.empty tpr o diff --git a/crucible-server/src/Lang/Crucible/Server/SimpleOverrides.hs b/crucible-server/src/Lang/Crucible/Server/SimpleOverrides.hs deleted file mode 100644 index d08dfdcdd..000000000 --- a/crucible-server/src/Lang/Crucible/Server/SimpleOverrides.hs +++ /dev/null @@ -1,216 +0,0 @@ - ----------------------------------------------------------------------- --- | --- Module : Lang.Crucible.Server.SimpleOverrides --- Copyright : (c) Galois, Inc 2014-2016 --- Maintainer : Rob Dockins --- Stability : provisional --- License : BSD3 --- --- Function implementations that are specific to the "simple" backend. ------------------------------------------------------------------------- - -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DoAndIfThenElse #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} - -module Lang.Crucible.Server.SimpleOverrides where - -import Control.Lens -import Control.Monad.State.Strict -import Data.Foldable (toList) -import qualified Data.Sequence as Seq -import qualified Data.Text as Text -import System.IO - -import Data.Parameterized.Some -import qualified Data.Parameterized.Context as Ctx - -import What4.Config -import What4.Interface -import qualified What4.Protocol.SMTLib2 as SMT2 -import What4.SatResult -import What4.Solver -import What4.Solver.Adapter -import qualified What4.Solver.ABC as ABC -import qualified What4.Solver.Yices as Yices - -import Lang.Crucible.Backend -import Lang.Crucible.Backend.Simple -import Lang.Crucible.Simulator.CallFrame (SomeHandle(..)) -import Lang.Crucible.Simulator.ExecutionTree -import Lang.Crucible.Simulator.OverrideSim -import Lang.Crucible.Simulator.RegMap -import Lang.Crucible.Types -import Lang.Crucible.Utils.MonadVerbosity - -import qualified Lang.Crucible.Proto as P -import Lang.Crucible.Server.Simulator -import Lang.Crucible.Server.Requests -import Lang.Crucible.Server.TypeConv -import Lang.Crucible.Server.ValueConv - -crucibleServerAdapters :: [SolverAdapter st] -crucibleServerAdapters = - [ ABC.abcAdapter - , ABC.genericSatAdapter - , boolectorAdapter - , Yices.yicesAdapter - , cvc4Adapter - , z3Adapter - ] - -simpleServerOptions :: [ConfigDesc] -simpleServerOptions = concatMap solver_adapter_config_options crucibleServerAdapters - -simpleServerOverrides :: IsSymInterface (SimpleBackend n fs) => [Simulator p (SimpleBackend n fs) -> IO SomeHandle] -simpleServerOverrides = - [ mkPredef checkSatWithAbcOverride - , mkPredef checkSatWithYicesOverride - , mkPredef writeSMTLib2Override - , mkPredef writeYicesOverride - ] - - -simpleBackendRequests :: IsSymInterface (SimpleBackend n fs) => BackendSpecificRequests p (SimpleBackend n fs) -simpleBackendRequests = - BackendSpecificRequests - { fulfillExportModelRequest = sbFulfillExportModelRequest - , fulfillSymbolHandleRequest = sbFulfillSymbolHandleRequest - , fulfillCompileVerificationOverrideRequest = sbFulfillCompileVerificationOverrideRequest - , fullfillSimulateVerificationHarnessRequest = sbFulfillSimulateVerificationHarnessRequest - } - ------------------------------------------------------------------------- --- CheckSatWithAbcHandle Request - -type CheckSatArgs = EmptyCtx ::> BoolType - --- | Returns override for creating a given variable associated with the given type. -checkSatWithAbcOverride :: Override p (SimpleBackend n fs) () CheckSatArgs BoolType -checkSatWithAbcOverride = do - mkOverride "checkSatWithAbc" $ do - RegMap args <- getOverrideArgs - let p = regValue $ args^._1 - sym <- getSymInterface - logLn <- getLogFunction - let logData = defaultLogData { logCallbackVerbose = logLn, logReason = "checkSatWithABC" } - r <- liftIO $ ABC.checkSat sym logData p - return $ backendPred sym (isSat r) - ------------------------------------------------------------------------- --- CheckSatWithYicesHandle Request - --- | Returns override for creating a given variable associated with the given type. -checkSatWithYicesOverride :: Override p (SimpleBackend n fs) () CheckSatArgs BoolType -checkSatWithYicesOverride = do - mkOverride "checkSatWithYices" $ do - RegMap args <- getOverrideArgs - let p = regValue $ args^._1 - sym <- getSymInterface - logLn <- getLogFunction - let logData = defaultLogData { logCallbackVerbose = logLn, logReason = "checkSatWithYices" } - r <- liftIO $ Yices.runYicesInOverride sym logData [p] (return . isSat) - return $ backendPred sym r - ------------------------------------------------------------------------- --- WriteSMTLib2Handle request - -type WriteSMTLIB2Args - = EmptyCtx - ::> StringType Unicode - ::> BoolType - -writeSMTLib2Override :: Override p (SimpleBackend n fs) () WriteSMTLIB2Args UnitType -writeSMTLib2Override = do - mkOverride "write_SMTLIB2" $ do - RegMap args <- getOverrideArgs - let file_nm = regValue $ args^._1 - p = regValue $ args^._2 - sym <- getSymInterface - case asString file_nm of - Just (UnicodeLiteral path) -> do - liftIO $ withFile (Text.unpack path) WriteMode $ \h -> - SMT2.writeDefaultSMT2 () "SMTLIB2" defaultWriteSMTLIB2Features sym h [p] - Nothing -> do - fail "Expected concrete file name in write_SMTLIB2 override" - ------------------------------------------------------------------------------------------ --- WriteYicesHandle request - -writeYicesOverride :: Override p (SimpleBackend n fs) () WriteSMTLIB2Args UnitType -writeYicesOverride = do - mkOverride "write_yices" $ do - RegMap args <- getOverrideArgs - let file_nm = regValue $ args^._1 - p = regValue $ args^._2 - ctx <- getContext - case asString file_nm of - Just (UnicodeLiteral path) -> do - let sym = ctx^.ctxSymInterface - liftIO $ Yices.writeYicesFile sym (Text.unpack path) p - Nothing -> do - fail "Expected concrete file name in write_yices override" - ------------------------------------------------------------------------- --- SimpleBackend ExportModel request - -sbFulfillExportModelRequest - :: IsSymInterface (SimpleBackend n fs) - => Simulator p (SimpleBackend n fs) - -> P.ExportFormat - -> Text.Text - -> Seq.Seq P.Value - -> IO () -sbFulfillExportModelRequest sim P.ExportAIGER path vals = do - vals' <- mapM (fromProtoValue sim) (toList vals) - let f :: Some (RegEntry (SimpleBackend n fs)) -> Maybe (Some (SymExpr (SimpleBackend n fs))) - f (Some r) = asSymExpr r (\x -> Just (Some x)) Nothing - case traverse f vals' of - Nothing -> fail "Could not translate values for AIG export" - Just vals'' -> do - ABC.writeAig (Text.unpack path) vals'' [] - let v = mempty & P.value_code .~ P.UnitValue - sendCallReturnValue sim v - -sbFulfillExportModelRequest _sim P.ExportSAW _path _vals = do - fail "The simple backend does not support exporting SAWCore terms" - - ------------------------------------------------------------------------- --- SymbolHandle request - --- | Returns override for creating a given variable associated with the given type. -symbolicOverride :: IsSymInterface sym => BaseTypeRepr tp -> Override p sym () EmptyCtx (BaseToType tp) -symbolicOverride tp = do - mkOverride' "symbolic" (baseToType tp) $ do - sym <- getSymInterface - liftIO $ freshConstant sym emptySymbol tp - -sbFulfillSymbolHandleRequest :: IsSymInterface sym => Simulator p sym -> P.VarType -> IO () -sbFulfillSymbolHandleRequest sim proto_tp = do - Some vtp <- varTypeFromProto proto_tp - let dims = proto_tp^.P.varType_dimensions - when (not $ Seq.null dims) - (fail "Simple backend does not support creating symbolic sequences") - respondToPredefinedHandleRequest sim (SymbolicHandle [] (Some vtp)) $ do - let o = symbolicOverride vtp - let tp = baseToType vtp - SomeHandle <$> simOverrideHandle sim Ctx.empty tp o - -------------------------------------------------------------------------- --- Compile verification request - -sbFulfillCompileVerificationOverrideRequest - :: IsSymInterface sym => Simulator p sym -> P.VerificationHarness -> IO () -sbFulfillCompileVerificationOverrideRequest _sim _harness = - fail "The 'simple' server backend does not support verification harnesses" - -sbFulfillSimulateVerificationHarnessRequest - :: IsSymInterface sym => Simulator p sym -> P.VerificationHarness -> P.VerificationSimulateOptions -> IO () -sbFulfillSimulateVerificationHarnessRequest _sim _harness _opts = - fail "The 'simple' server backend does not support verification harnesses" diff --git a/crucible-server/src/Lang/Crucible/Server/Simulator.hs b/crucible-server/src/Lang/Crucible/Server/Simulator.hs deleted file mode 100644 index d66ee8e6a..000000000 --- a/crucible-server/src/Lang/Crucible/Server/Simulator.hs +++ /dev/null @@ -1,351 +0,0 @@ ------------------------------------------------------------------------ --- | --- Module : Lang.Crucible.Server.Simulator --- Copyright : (c) Galois, Inc 2014-2016 --- Maintainer : Rob Dockins --- Stability : provisional --- License : BSD3 --- --- State-management datastructures and functions for interfacing with --- the main crucible simulator. ------------------------------------------------------------------------- - -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE EmptyCase #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE DeriveGeneric #-} -module Lang.Crucible.Server.Simulator where - -import Control.Exception -import Control.Lens -import Control.Monad.IO.Class -import Data.Hashable -import qualified Data.HashTable.IO as HIO -import Data.IORef -import qualified Data.Map as Map -import Data.Maybe ( mapMaybe ) -import qualified Data.Sequence as Seq -import qualified Data.Text as Text -import Data.Text.Encoding (decodeUtf8) -import System.IO.Error - -import GHC.Generics -import GHC.IO.Handle - - -import Data.HPB -import qualified Data.Parameterized.Map as MapF -import Data.Parameterized.Nonce (indexValue) -import Data.Parameterized.Some - -import What4.Config -import What4.FunctionName -import What4.ProgramLoc -import What4.Interface - -import Lang.Crucible.Backend -import Lang.Crucible.FunctionHandle -import Lang.Crucible.Simulator -import Lang.Crucible.Simulator.ExecutionTree (stateTree, activeFrames, filterCrucibleFrames) -import Lang.Crucible.Simulator.Operations( abortExec ) -import Lang.Crucible.Server.CallbackOutputHandle -import Lang.Crucible.Server.TypeConv - -import Lang.Crucible.Types -import qualified Lang.Crucible.Proto as P - - ------------------------------------------------------------------------- --- PredefinedHandle - -data PredefinedHandle - = SymbolicHandle ![Int] !(Some BaseTypeRepr) - | NamedPredefHandle !FunctionName - | PrintTermHandle !(Some TypeRepr) - | MultiPartLoadHandle !Int !Int !Int - | MultiPartStoreHandle !Int !Int !Int - deriving (Eq, Generic) - -instance Hashable PredefinedHandle where - ------------------------------------------------------------------------- --- Simulator - --- | The simulator contains the state associated with the crucible-server --- interface. -data Simulator p sym - = Simulator { simContext :: !(IORef (SimContext p sym ())) - , requestHandle :: !Handle - , responseHandle :: !Handle - -- | Maps handle ids to the associated handle. - , handleCache :: !(IORef (Map.Map Word64 SomeHandle)) - -- | Maps predefined handles to associated handle. - , predefinedHandles :: - !(HIO.BasicHashTable PredefinedHandle SomeHandle) - , simValueCache :: !(HIO.BasicHashTable Word64 (Some (RegEntry sym))) - , simValueCounter :: !(IORef Word64) - , simExecFeatures :: [GenericExecutionFeature sym] - } - -getSimContext :: Simulator p sym -> IO (SimContext p sym ()) -getSimContext sim = readIORef (simContext sim) - -getHandleAllocator :: Simulator p sym -> IO HandleAllocator -getHandleAllocator sim = simHandleAllocator <$> getSimContext sim - -getInterface :: Simulator p sym -> IO sym -getInterface sim = (^.ctxSymInterface) <$> getSimContext sim - --- | Create a new Simulator interface -newSimulator :: IsSymInterface sym - => sym - -> [ConfigDesc] - -> p - -> [GenericExecutionFeature sym] - -- ^ Execution features to install in the simulator - -> [Simulator p sym -> IO SomeHandle] -- ^ Predefined function handles to install - -> Handle - -- ^ Handle for reading requests. - -> Handle - -- ^ Handle for writing responses. - -> IO (Simulator p sym) -newSimulator sym opts p execFeats hdls request_handle response_handle = do - let cb = OutputCallbacks { devCallback = \s -> do - sendPrintValue response_handle (decodeUtf8 s) - , devClose = return () - } - h <- mkCallbackOutputHandle "crucible-server" cb - - withHandleAllocator $ \halloc -> do - - let bindings = emptyHandleMap - let extImpl :: ExtensionImpl p sym () - extImpl = ExtensionImpl (\_sym _iTypes _logFn _f x -> case x of) (\x -> case x of) - - -- add relevant configuration options - extendConfig opts (getConfiguration sym) - - -- Create new context - ctxRef <- newIORef $ - initSimContext sym MapF.empty halloc h bindings extImpl p - - hc <- newIORef Map.empty - ph <- HIO.new - svc <- HIO.new - svCounter <- newIORef 0 - - let sim = - Simulator { simContext = ctxRef - , requestHandle = request_handle - , responseHandle = response_handle - , handleCache = hc - , predefinedHandles = ph - , simValueCache = svc - , simValueCounter = svCounter - , simExecFeatures = execFeats - } - populatePredefHandles sim hdls ph - return sim - -populatePredefHandles :: IsSymInterface sym - => Simulator p sym - -> [Simulator p sym -> IO SomeHandle] - -> HIO.BasicHashTable PredefinedHandle SomeHandle - -> IO () -populatePredefHandles _ [] _ = return () -populatePredefHandles s (mkh : hs) ph = do - SomeHandle h <- mkh s - HIO.insert ph (NamedPredefHandle (handleName h)) (SomeHandle h) - populatePredefHandles s hs ph - -mkPredef :: (KnownCtx TypeRepr args, KnownRepr TypeRepr ret, IsSymInterface sym) - => Override p sym () args ret - -> Simulator p sym - -> IO SomeHandle -mkPredef ovr s = SomeHandle <$> simOverrideHandle s knownRepr knownRepr ovr - -handleRef :: FnHandle args tp -> Word64 -handleRef h = indexValue (handleID h) - --- | Create a handle associated with given arguments, and ensure simulator --- can find it when given index. -simMkHandle :: Simulator p sim - -> FunctionName - -> CtxRepr args - -> TypeRepr tp - -> IO (FnHandle args tp) -simMkHandle sim nm args tp = do - halloc <- getHandleAllocator sim - h <- mkHandle' halloc nm args tp - modifyIORef' (handleCache sim) $ Map.insert (handleRef h) (SomeHandle h) - return h - -getHandleBinding :: Simulator p sym -> Word64 -> IO SomeHandle -getHandleBinding sim r = do - ms <- readIORef (handleCache sim) - case Map.lookup r ms of - Just s -> return s - Nothing -> fail $ "The index " ++ show r ++ " is not associated with a known handle." - --- | Get a predefined handle associated with the entry. -getPredefinedHandle :: Simulator p sym - -> PredefinedHandle - -> IO SomeHandle -- Function to create handle (if needed). - -> IO SomeHandle -getPredefinedHandle sim predef fallback = do - let tbl = predefinedHandles sim - mh <- HIO.lookup tbl predef - case mh of - Just h -> return h - Nothing -> do - h <- fallback - -- Associate predef with handle for caching. - HIO.insert tbl predef h - return h - --- | Send response to crucible-server. -sendResponse :: HasMessageRep a => Simulator p sym -> a -> IO () -sendResponse sim resp = putDelimited (responseHandle sim) resp - -toProtoHandleInfo :: FnHandle args rtp -> P.HandleInfo -toProtoHandleInfo h - = mempty - & P.handleInfo_display_name .~ fromString (show (handleName h)) - & P.handleInfo_arg_types .~ mkProtoTypeSeq (handleArgTypes h) - & P.handleInfo_return_type .~ mkProtoType (handleReturnType h) - --- | Send a response with a predefined handle. -sendPredefinedHandleResponse :: Simulator p sym -> FnHandle args rtp -> IO () -sendPredefinedHandleResponse sim h = do - -- Sent response with value and info - let resp = mempty - & P.predefinedHandleInfo_ref .~ handleRef h - & P.predefinedHandleInfo_info .~ toProtoHandleInfo h - let gresp = mempty - & P.genericResponse_code .~ P.PredefHandleGenResp - & P.genericResponse_predefHandleResponse .~ resp - sendResponse sim gresp - --- | Respond to a request for a predefined handle. -respondToPredefinedHandleRequest :: Simulator p sym -> PredefinedHandle -> IO SomeHandle -> IO () -respondToPredefinedHandleRequest sim predef fallback = do - SomeHandle h <- getPredefinedHandle sim predef fallback - sendPredefinedHandleResponse sim h - --- Associate a function with the given handle. -bindHandleToFunction :: Simulator p sym - -> FnHandle args ret - -> FnState p sym () args ret - -> IO () -bindHandleToFunction sim h s = - modifyIORef' (simContext sim) $ - functionBindings %~ insertHandleMap h s - -simOverrideHandle :: Simulator p sym - -> CtxRepr args - -> TypeRepr tp - -> Override p sym () args tp - -> IO (FnHandle args tp) -simOverrideHandle sim args ret o = do - h <- simMkHandle sim (overrideName o) args ret - -- Add override to state. - bindHandleToFunction sim h (UseOverride o) - return h - - -sendExceptionResponse :: Simulator p sym - -> SomeException - -> IO () -sendExceptionResponse sim ex = do - let msg = case fromException ex of - Just ioex | isUserError ioex -> Text.pack $ ioeGetErrorString ioex - _ -> Text.pack $ displayException ex - let gresp = mempty - & P.genericResponse_code .~ P.ExceptionGenResp - & P.genericResponse_message .~ msg - sendResponse sim gresp - - -sendCallResponse :: Simulator p sym - -> P.CallResponse - -> IO () -sendCallResponse sim cresp = do - let gresp = mempty - & P.genericResponse_code .~ P.CallGenResp - & P.genericResponse_callResponse .~ cresp - sendResponse sim gresp - -sendAckResponse :: Simulator p sym - -> IO () -sendAckResponse sim = - sendResponse sim (mempty & P.genericResponse_code .~ P.AcknowledgementResp) - -sendCallReturnValue :: IsSymInterface sym - => Simulator p sym - -> P.Value --RegEntry sym tp - -> IO () -sendCallReturnValue sim pv = do - --pv <- toProtoValue sim v - sendCallResponse sim $ mempty & P.callResponse_code .~ P.CallReturnValue - & P.callResponse_returnVal .~ pv - -sendCallAllAborted :: Simulator p sym -> IO () -sendCallAllAborted sim = do - sendCallResponse sim $ mempty & P.callResponse_code .~ P.CallAllAborted - -sendTextResponse :: Simulator p sym - -> Text - -> IO () -sendTextResponse sim msg = sendPrintValue (responseHandle sim) msg - --- | Send message to print value. -sendPrintValue :: Handle -> Text -> IO () -sendPrintValue h msg = do - putDelimited h $ mempty & P.genericResponse_code .~ P.PrintGenResp - & P.genericResponse_message .~ msg - -sendCallPathAborted :: Simulator p sym - -> P.PathAbortedCode - -> String - -> [ProgramLoc] - -> IO () -sendCallPathAborted sim code msg bt = do - let ps = Seq.fromList $ map toProtoPos bt - let abortMsg = mempty & P.pathAbortedMessage_code .~ code - & P.pathAbortedMessage_message .~ fromString msg - & P.pathAbortedMessage_backtraces .~ ps - sendCallResponse sim $ mempty & P.callResponse_code .~ P.CallPathAborted - & P.callResponse_message .~ abortMsg - -serverErrorHandler :: IsSymInterface sym - => Simulator p sym - -> AbortHandler p sym () rtp -serverErrorHandler sim = AH $ \e -> - do t <- view stateTree - let frames = activeFrames t - -- Get location of frame. - let loc = mapMaybe filterCrucibleFrames frames - -- let msg = ppExceptionContext frames e - - -- If a branch aborted becasue of an error condition, - -- tell client that a part aborted with the given message. - liftIO $ - case e of - AssumedFalse (AssumingNoError se) -> - case simErrorReason se of - ReadBeforeWriteSimError msg -> do - sendCallPathAborted sim P.AbortedReadBeforeWrite (show msg) loc - AssertFailureSimError msg _details -> do - sendCallPathAborted sim P.AbortedUserAssertFailure (show msg) loc - _ -> do - sendCallPathAborted sim P.AbortedGeneric (show (simErrorReason se)) loc - - -- In other cases, do nothing - _ -> return () - - -- Abort execution. - abortExec e diff --git a/crucible-server/src/Lang/Crucible/Server/Translation.hs b/crucible-server/src/Lang/Crucible/Server/Translation.hs deleted file mode 100644 index e1563c21e..000000000 --- a/crucible-server/src/Lang/Crucible/Server/Translation.hs +++ /dev/null @@ -1,525 +0,0 @@ ------------------------------------------------------------------------ --- | --- Module : Lang.Crucible.Server.Translations --- Copyright : (c) Galois, Inc 2014-2016 --- Maintainer : Rob Dockins --- Stability : provisional --- License : BSD3 --- --- Operations for translating between the protocol-buffer representations --- and the internal Crucible representations of control-flow graphs. ------------------------------------------------------------------------- - -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Lang.Crucible.Server.Translation - ( unpackCFG - ) where - -#if !MIN_VERSION_base(4,13,0) -import Control.Monad.Fail( MonadFail ) -#endif - -import Control.Lens -import Control.Monad -import qualified Data.Foldable as Fold -import qualified Control.Monad.Catch as X -import Control.Monad.Reader -import Control.Monad.State -import qualified Data.Map as Map -import Data.IORef -import Data.Maybe -import Data.Parameterized.Nonce ( Nonce, NonceGenerator - , freshNonce, newIONonceGenerator ) -import qualified Data.Sequence as Seq -import qualified Data.Set as Set -import qualified Data.Vector as V -import qualified Data.Parameterized.Context as Ctx - - -import Data.HPB -import qualified Data.BitVector.Sized as BV -import Data.Parameterized.Some -import Data.Parameterized.TraversableFC - -import What4.ProgramLoc -import What4.Utils.StringLiteral - -import Lang.Crucible.Backend -import Lang.Crucible.CFG.Expr -import qualified Lang.Crucible.CFG.Reg as R -import Lang.Crucible.FunctionHandle -import Lang.Crucible.Types -import qualified Lang.Crucible.Proto as P -import Lang.Crucible.Server.ValueConv -import Lang.Crucible.Server.Encoding -import Lang.Crucible.Server.Simulator -import Lang.Crucible.Server.TypeConv - ------------------------------------------------------------------------- --- UseCFG request - -newtype Gen s (ret :: CrucibleType) a = - Gen { unGen :: ReaderT (NonceGenerator IO s) IO a } - deriving ( Functor - , Applicative - , Monad - , MonadFail - ) - -newAtomIdx :: Gen s ret (Nonce s (tp :: CrucibleType)) -newAtomIdx = do - ng <- Gen $ ask - Gen $ lift (freshNonce ng) - -genBlockID :: P.Block -- ^ Block to generate label for. - -> Gen s ret (R.BlockID s) -genBlockID b - | b^.P.block_is_lambda = do - Some tp <- fromProtoType (b^.P.block_lambda_type) - idx <- newAtomIdx - r_idx <- newAtomIdx - let a = R.Atom { R.atomPosition = plSourceLoc $ fromProtoPos (b^.P.block_pos) - , R.atomId = r_idx - , R.atomSource = R.LambdaArg l - , R.typeOfAtom = tp --- , R.regSource = R.LambdaArg l --- , R.typeOfReg = tp - } - l = R.LambdaLabel idx a - return $ R.LambdaID l - | otherwise = R.LabelID . R.Label <$> newAtomIdx - -type RegVector s = V.Vector (Some (R.Reg s)) -type StmtResultMap s = Map.Map (Word64, Word64) (Some (R.Atom s)) - --- | Get type of result returned by statement. -genStmtResultType :: RegVector s -> P.Statement -> Gen s ret (Maybe (Some TypeRepr)) -genStmtResultType rv s = - case s^.P.statement_code of - P.ExecPrimitive -> do - Just <$> fromProtoType (s^.P.statement_result_type) - P.Call -> do - Just <$> fromProtoType (s^.P.statement_result_type) - P.Print -> return Nothing - P.Assert -> return Nothing - P.ReadReg -> do - case rv V.!? fromIntegral (s^.P.statement_reg) of - Just (Some r) -> return $ Just $ Some (R.typeOfReg r) - Nothing -> fail $ "Read reg given illegal index." - P.WriteReg -> do - return Nothing - -- TODO: Support globals - _ -> fail $ "Could not interpret statement." - -mkStmtResultMap :: forall s ret . RegVector s -> [P.Block] -> Gen s ret (StmtResultMap s) -mkStmtResultMap rv blocks = do - let mkStmtResult :: Word64 - -> Word64 - -> P.Statement - -> Gen s ret (Maybe ((Word64, Word64),Some (R.Atom s))) - mkStmtResult block_idx stmt_idx s = do - mtp <- genStmtResultType rv s - case mtp of - Nothing -> return Nothing - Just (Some tp) -> do - r_idx <- newAtomIdx - let a = R.Atom { R.atomPosition = plSourceLoc $ fromProtoPos (s^.P.statement_pos) - , R.atomId = r_idx - , R.atomSource = R.Assigned - , R.typeOfAtom = tp - } - return $ Just ((block_idx, stmt_idx), Some a) - - f :: Word64 -> P.Block -> Gen s ret [((Word64, Word64),Some (R.Atom s))] - f block_idx b = do - let stmts = Fold.toList (b^.P.block_statements) - catMaybes <$> zipWithM (mkStmtResult block_idx) [0..] stmts - Map.fromList . concat <$> zipWithM f [0..] blocks - ------------------------------------------------------------------------- --- Translation - -data TransState s = TransState { blockLabelMap :: !(Map.Map Word64 (R.BlockID s)) - , handleMap :: !(Map.Map Word64 SomeHandle) - , argVec :: !(V.Vector (Some (R.Atom s))) - , regVec :: !(V.Vector (Some (R.Reg s))) - , nonceGen :: NonceGenerator IO s - , stmtResultMap :: !(StmtResultMap s) - } - -newtype Trans s (ret :: CrucibleType) a = Trans { unTrans :: StateT (TransState s) IO a } - deriving ( Functor - , Applicative - , Monad - , MonadFail - , MonadState (TransState s) - , X.MonadThrow - , MonadIO - ) - -getBlockID :: Word64 -> Trans s ret (R.BlockID s) -getBlockID w = do - m <- gets blockLabelMap - case Map.lookup w m of - Nothing -> fail $ "Illegal block index: " ++ show w - Just b -> return b - -getBlockLabel :: Word64 -> Trans s ret (R.Label s) -getBlockLabel w = do - b <- getBlockID w - case b of - R.LabelID l -> return l - R.LambdaID{} -> fail $ "Block label refers to lambda." - -getLambdaLabel :: Word64 -> TypeRepr tp -> Trans s ret (R.LambdaLabel s tp) -getLambdaLabel w tp = do - b <- getBlockID w - case b of - R.LabelID{} -> fail $ "Lambda label refers to block." - R.LambdaID l -> do - case testEquality (R.typeOfAtom (R.lambdaAtom l)) tp of - Just Refl -> return l - Nothing -> fail $ "Lambda label has incorrect type." - -getFnArg :: Word64 -- ^ Index of argument - -> Trans s ret (Some (R.Atom s)) -getFnArg arg_idx = do - v <- gets argVec - case v V.!? fromIntegral arg_idx of - Nothing -> fail $ "Could not find argument at " ++ show arg_idx ++ "." - Just e -> return e - -getLambdaArg :: Word64 -- ^ Index of block - -> Trans s ret (Some (R.Atom s)) -getLambdaArg block_idx = do - b <- getBlockID block_idx - case b of - R.LabelID{} -> fail $ "Lambda arg refers to block." - R.LambdaID l -> return (Some (R.lambdaAtom l)) - -getReg :: Word64 -> Trans s ret (Some (R.Reg s)) -getReg reg_idx = do - v <- gets regVec - case v V.!? fromIntegral reg_idx of - Nothing -> fail $ "Could not find register at " ++ show reg_idx ++ "." - Just r -> return r - -getStmtResult :: Word64 -> Word64 -> Trans s ret (Some (R.Atom s)) -getStmtResult block_idx stmt_idx = do - m <- gets stmtResultMap - case Map.lookup (block_idx, stmt_idx) m of - Nothing -> do - fail $ "Could not find statement at " ++ show (block_idx, stmt_idx) ++ "." - Just r -> return r - -getRegWithType :: Word64 -> TypeRepr tp -> Trans s ret (R.Reg s tp) -getRegWithType w tp = do - Some r <- getReg w - case testEquality (R.typeOfReg r) tp of - Just Refl -> return r - Nothing -> fail $ "Register does not match type." - -getStmtResultWithType :: Word64 -> Word64 -> TypeRepr tp -> Trans s ret (R.Atom s tp) -getStmtResultWithType block_idx stmt_idx tp = do - Some r <- getStmtResult block_idx stmt_idx - case testEquality (R.typeOfAtom r) tp of - Just Refl -> return r - Nothing -> fail $ "Statement result does not match type." - -transNatExpr :: MonadFail m => P.Expr -> m (Some NatRepr) -transNatExpr pe = do - case pe^.P.expr_code of - P.NatExpr -> do - let i = decodeUnsigned (pe^.P.expr_data) - case someNat i of - Just rep -> return rep - Nothing -> fail "improper nat value in parseNatRepr" - _ -> fail "expected Nat value in parseNatRepr" - - -data BlockState s = BlockState { blockPos :: !Position - , blockStmts :: ![Posd (R.Stmt () s)] - } - -type StmtTrans s r = StateT (BlockState s) (Trans s r) - -setPos :: Position -> StmtTrans s r () -setPos p = do - s <- get - put $! s { blockPos = p } - -addStmt :: R.Stmt () s -> StmtTrans s r () -addStmt stmt = seq stmt $ do - s <- get - let pstmt = Posd (blockPos s) stmt - seq pstmt $ do - let l = pstmt : blockStmts s - put $! s { blockStmts = l } - -addAppStmt :: App () (R.Atom s) tp -> StmtTrans s r (R.Atom s tp) -addAppStmt app = do - ng <- lift $ gets nonceGen - i <- liftIO $ freshNonce ng - p <- gets blockPos - let a = R.Atom { R.atomPosition = p - , R.atomId = i - , R.atomSource = R.Assigned - , R.typeOfAtom = appType app - } - addStmt $ R.DefineAtom a (R.EvalApp app) - return $! a - --- | Translate a protocol buffer expression into either a constant or a known atom. -transExpr :: P.Expr -> StmtTrans s ret (Some (R.Atom s)) -transExpr pe = do - case pe^.P.expr_code of - P.TrueExpr -> do - fmap Some $ addAppStmt $ BoolLit True - P.FalseExpr -> do - fmap Some $ addAppStmt $ BoolLit False - P.NatExpr -> do - let i = decodeUnsigned (pe^.P.expr_data) - fmap Some $ addAppStmt $ NatLit (fromInteger i) - P.IntegerExpr -> do - let i = decodeSigned (pe^.P.expr_data) - fmap Some $ addAppStmt $ IntLit i - P.RationalExpr -> do - r <- decodeRational (pe^.P.expr_data) - fmap Some $ addAppStmt $ RationalLit r - P.BitvectorExpr -> do - case someNat (toInteger (pe^.P.expr_width)) of - Just (Some w) -> do - case isPosNat w of - Nothing -> fail $ "Zero width bitvector." - Just LeqProof -> do - let i = decodeSigned (pe^.P.expr_data) - fmap Some $ addAppStmt $ BVLit w (BV.mkBV w i) - Nothing -> fail "Width is too large" - P.StringExpr -> do - let s = pe^.P.expr_string_lit - fmap Some $ addAppStmt $ StringLit $ UnicodeLiteral s - P.UnitExpr -> do - fmap Some $ addAppStmt $ EmptyApp - P.FnHandleExpr -> do - m <- lift $ gets handleMap - let idx = pe^.P.expr_index - case Map.lookup idx m of - Just (SomeHandle h) -> - fmap Some $ addAppStmt $ HandleLit h - Nothing -> fail $ "Could not find handle with index " ++ show idx ++ "." - P.FunctionArgExpr -> do - lift $ getFnArg (pe^.P.expr_index) - P.LambdaArgExpr -> do - lift $ getLambdaArg (pe^.P.expr_block_id) - P.StatementResultExpr -> do - lift $ getStmtResult (pe^.P.expr_block_id) (pe^.P.expr_index) - P.UnknownExpr -> fail $ "Could not parse expression." - -transExprWithType :: P.Expr - -> TypeRepr tp - -> StmtTrans s ret (R.Atom s tp) -transExprWithType pe tp = do - Some a <- transExpr pe - case testEquality (R.typeOfAtom a) tp of - Just Refl -> return a - Nothing -> fail "Expression does not match expected type." - -transExprSeqWithTypes :: Seq P.Expr - -> CtxRepr ctx - -> StmtTrans s ret (Ctx.Assignment (R.Atom s) ctx) -transExprSeqWithTypes s0 c0 = - case Ctx.viewAssign c0 of - Ctx.AssignEmpty -> do - when (not (Seq.null s0)) $ do - fail $ "More expressions than expected." - return $ Ctx.empty - Ctx.AssignExtend c tp -> do - case Seq.viewr s0 of - Seq.EmptyR -> fail $ "Fewer expressions than expected." - s Seq.:> pe -> do - (Ctx.:>) <$> transExprSeqWithTypes s c - <*> transExprWithType pe tp - ------------------------------------------------------------------------- - -transStmt :: Word64 -- ^ Index of block - -> Word64 -- ^ Index of statement - -> P.Statement - -> StmtTrans s ret () -transStmt block_idx stmt_idx s = do - setPos (plSourceLoc (fromProtoPos (s^.P.statement_pos))) - let exprs = s^.P.statement_exprs - case (s^.P.statement_code, Fold.toList exprs) of - (P.ExecPrimitive, _) -> do - let prim_op = s^.P.statement_prim_op - let res_type = s^.P.statement_result_type - Some a <- convertToCrucibleApp transExpr transNatExpr prim_op exprs res_type - res <- lift $ getStmtResultWithType block_idx stmt_idx (appType a) - addStmt $ R.DefineAtom res (R.EvalApp a) - (P.Call, pf:pargs) -> do - Some f <- transExpr pf - case R.typeOfAtom f of - FunctionHandleRepr argTypes ret -> do - args <- transExprSeqWithTypes (Seq.fromList pargs) argTypes - res <- lift $ getStmtResultWithType block_idx stmt_idx ret - addStmt $ R.DefineAtom res (R.Call f args ret) - _ -> fail $ "Call given non-function." - (P.Print, [pmsg]) -> do - msg <- transExprWithType pmsg (StringRepr UnicodeRepr) - addStmt $ R.Print msg - (P.Assert, [pc, pmsg]) -> do - c <- transExprWithType pc BoolRepr - msg <- transExprWithType pmsg (StringRepr UnicodeRepr) - addStmt $ R.Assert c msg - (P.ReadReg, []) -> do - Some r <- lift $ getReg (s^.P.statement_reg) - res <- lift $ getStmtResultWithType block_idx stmt_idx (R.typeOfReg r) - addStmt $ R.DefineAtom res (R.ReadReg r) - (P.WriteReg, [pv]) -> do - Some v <- transExpr pv - r <- lift $ getRegWithType (s^.P.statement_reg) (R.typeOfAtom v) - addStmt $ R.SetReg r v - -- TODO: Support globals - _ -> fail $ "Could not interpret statement." - -transTermStmt' :: TypeRepr ret -> P.TermStmt -> StmtTrans s ret (R.TermStmt s ret) -transTermStmt' retType t = do - - let exprs = Fold.toList $ t^.P.termStmt_exprs - let blocks = Fold.toList $ t^.P.termStmt_blocks - case (t^.P.termStmt_code, exprs, blocks) of - (P.JumpTermStmt, [], [b_id]) -> do - lift $ do - b <- getBlockLabel b_id - return $ R.Jump b - (P.BranchTermStmt, [pc], [x_id, y_id]) -> do - c <- transExprWithType pc BoolRepr - lift $ do - x <- getBlockLabel x_id - y <- getBlockLabel y_id - return $ R.Br c x y - (P.ReturnTermStmt, [pe], []) -> do - e <- transExprWithType pe retType - return $ R.Return e - (P.ErrorTermStmt, [pe], []) -> do - e <- transExprWithType pe (StringRepr UnicodeRepr) - return $ R.ErrorStmt e - (P.TailCallTermStmt, (pf:pargs), []) -> do - Some f <- transExpr pf - case R.typeOfAtom f of - FunctionHandleRepr argTypes ret -> do - case testEquality ret retType of - Just Refl -> do - args <- transExprSeqWithTypes (Seq.fromList pargs) argTypes - return $ R.TailCall f argTypes args - Nothing -> fail "Tail call returns incorrect value." - _ -> fail $ "Tail call given non-function." - (P.SwitchMaybeTermStmt, [pe], [pj,pn]) -> do - Some e <- transExpr pe - case R.typeOfAtom e of - MaybeRepr tp -> lift $ do - j <- getLambdaLabel pj tp - n <- getBlockLabel pn - return $ R.MaybeBranch tp e j n - _ -> fail "MaybeBranch given bad expression." - _ -> do - fail $ "Could not parse term stmt." - -transTermStmt :: TypeRepr ret -> P.TermStmt -> StmtTrans s ret (Posd (R.TermStmt s ret)) -transTermStmt retType t = do - let p = plSourceLoc $ fromProtoPos (t^.P.termStmt_pos) - setPos p - Posd p <$> transTermStmt' retType t - -transBlock :: TypeRepr ret - -> Word64 -- ^ Index of block (0 is first index). - -> P.Block -- ^ Block to write to. - -> Trans s ret (R.Block () s ret) -transBlock retType idx b = do - block_id <- getBlockID idx - v <- gets argVec - let inputs | idx == 0 = Set.fromList $ V.toList (fmap (mapSome R.AtomValue) v) - | otherwise = Set.empty - let block_state = BlockState { blockPos = plSourceLoc $ fromProtoPos (b^.P.block_pos) - , blockStmts = [] - } - flip evalStateT block_state $ do - zipWithM_ (transStmt idx) [0..] (Fold.toList (b^.P.block_statements)) - term <- transTermStmt retType (b^.P.block_termStmt) - stmts <- gets blockStmts - return $ R.mkBlock block_id inputs (Seq.fromList (reverse stmts)) term - -mkRegs :: forall s ctx - . Position - -> NonceGenerator IO s - -> CtxRepr ctx - -> IO (V.Vector (Some (R.Reg s))) -mkRegs p ng argTypes = V.mapM (mapSomeM f) v - where v = V.fromList (Fold.toList (ctxReprToSeq argTypes)) - f :: TypeRepr tp -> IO (R.Reg s tp) - f tp = do - i <- freshNonce ng - return $ R.Reg { R.regPosition = p - , R.regId = i --- , R.regSource = R.Assigned - , R.typeOfReg = tp - } - - mapSomeM :: Functor m - => (forall (x :: CrucibleType). a x -> m (b x)) - -> Some a -> m (Some b) - mapSomeM h (Some x) = Some <$> h x - -unpackCFG :: IsSymInterface sym - => Simulator p sym - -> P.Cfg - -> (forall s init ret. R.CFG () s init ret -> IO a) - -> IO a -unpackCFG sim pg cont = do - let h_index = pg^.P.cfg_handle_id - Some reg_types <- fromProtoTypeSeq (pg^.P.cfg_registers) - let pblocks = Fold.toList $ pg^.P.cfg_blocks - SomeHandle h <- getHandleBinding sim h_index - - handle_map <- readIORef (handleCache sim) - - let argTypes = handleArgTypes h - let retType = handleReturnType h - - let p = plSourceLoc $ fromProtoPos $ pg^.P.cfg_pos - - Some ng <- newIONonceGenerator - argRegs <- V.fromList . toListFC Some <$> R.mkInputAtoms ng p argTypes - regRegs <- mkRegs p ng reg_types - - initState <- flip runReaderT ng $ unGen $ do - block_ids <- mapM genBlockID pblocks - let block_map = Map.fromList (zip [0..] block_ids) - stmt_result_map <- mkStmtResultMap regRegs pblocks - return TransState { blockLabelMap = block_map - , handleMap = handle_map - , argVec = argRegs - , regVec = regRegs - , nonceGen = ng - , stmtResultMap = stmt_result_map - } - - (blocks,_finalSt) <- flip runStateT initState $ unTrans $ - zipWithM (transBlock retType) [0..] pblocks - - let entryLabel = case R.blockID (head blocks) of - R.LabelID lbl -> lbl - R.LambdaID {} -> error "entry block has lambda label" - - let g = R.CFG { R.cfgHandle = h - , R.cfgEntryLabel = entryLabel - , R.cfgBlocks = blocks - } - cont g diff --git a/crucible-server/src/Lang/Crucible/Server/TypeConv.hs b/crucible-server/src/Lang/Crucible/Server/TypeConv.hs deleted file mode 100644 index fe4c1d536..000000000 --- a/crucible-server/src/Lang/Crucible/Server/TypeConv.hs +++ /dev/null @@ -1,286 +0,0 @@ ------------------------------------------------------------------------ --- | --- Module : Lang.Crucible.Server.TypeConv --- Copyright : (c) Galois, Inc 2014-2016 --- Maintainer : Rob Dockins --- Stability : provisional --- License : BSD3 --- --- Operations to translate between the protocol-buffer represntation --- of types and the internal Crucible representation. ------------------------------------------------------------------------- - -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Lang.Crucible.Server.TypeConv where - -#if !MIN_VERSION_base(4,13,0) -import Control.Monad.Fail( MonadFail ) -#endif - -import Control.Lens -import Control.Monad -import qualified Data.Sequence as Seq -import Data.Foldable( toList ) - -import Data.HPB -import qualified Data.Parameterized.Context as Ctx -import Data.Parameterized.Some - -import What4.FunctionName -import What4.ProgramLoc -import What4.Interface - -import Lang.Crucible.Types - -import qualified Lang.Crucible.Proto as P - - - -getTail :: MonadFail m => String -> Seq a -> m (Seq a, a) -getTail msg s = - case Seq.viewr s of - Seq.EmptyR -> fail msg - h Seq.:> t -> return (h, t) - ------------------------------------------------------------------------- --- Positions - -fromProtoPos :: P.Position -> ProgramLoc -fromProtoPos p = - case p^.P.position_code of - P.InternalPos -> - let nm = p^.P.position_functionName - in mkProgramLoc (functionNameFromText nm) InternalPos - P.SourcePos -> - let path = p^.P.position_path - line = fromIntegral $ p^.P.position_line - col = fromIntegral $ p^.P.position_col - nm = p^.P.position_functionName - in mkProgramLoc (functionNameFromText nm) $ SourcePos path line col - P.BinaryPos -> - let path = p^.P.position_path - addr = p^.P.position_addr - nm = p^.P.position_functionName - in mkProgramLoc (functionNameFromText nm) $ BinaryPos path addr - P.OtherPos -> - let str = p^.P.position_value - nm = p^.P.position_functionName - in mkProgramLoc (functionNameFromText nm) $ OtherPos str - -toProtoPos :: ProgramLoc -> P.Position -toProtoPos pl = - case plSourceLoc pl of - InternalPos -> - mempty & P.position_code .~ P.InternalPos - & P.position_functionName .~ functionName (plFunction pl) - SourcePos path line col -> - mempty & P.position_code .~ P.SourcePos - & P.position_path .~ path - & P.position_line .~ fromIntegral line - & P.position_col .~ fromIntegral col - & P.position_functionName .~ functionName (plFunction pl) - BinaryPos path addr -> - mempty & P.position_code .~ P.BinaryPos - & P.position_path .~ path - & P.position_addr .~ fromIntegral addr - & P.position_functionName .~ functionName (plFunction pl) - OtherPos str -> - mempty & P.position_code .~ P.OtherPos - & P.position_value .~ str - ------------------------------------------------------------------------- --- Type conversion - --- | Convert protocol var type to Interface type. -varTypeFromProto :: MonadFail m => P.VarType -> m (Some BaseTypeRepr) -varTypeFromProto tp = - case tp^.P.varType_id of - P.BitvectorVarType -> do - let wv = tp^.P.varType_width - when (wv == 0) $ do - fail $ "Bitvector variables must have a positive width." - case someNat wv of - Just (Some w) | Just LeqProof <- isPosNat w -> do - return $ Some (BaseBVRepr w) - _ -> error "Illegal type width" - P.BoolVarType -> return $ Some BaseBoolRepr - P.IntegerVarType -> return $ Some BaseIntegerRepr - P.RealVarType -> return $ Some BaseRealRepr - - --- Given a protocol vartype, wrap a "Vector" type operator --- for each dimension on top of the base type -crucibleTypeFromProtoVarType :: MonadFail m => P.VarType -> m (Some TypeRepr) -crucibleTypeFromProtoVarType tp = do - let dims = tp^.P.varType_dimensions - Some vtp <- varTypeFromProto tp - let basetp = baseToType vtp - wrapVectors (toList dims) (Some basetp) - - where wrapVectors [] basetp = return basetp - wrapVectors (_:xs) basetp = do - Some t <- wrapVectors xs basetp - return (Some (VectorRepr t)) - ------------------------------------------------------------------------- --- Converting from a protocol buffer type. - -fromProtoTypeSeq :: MonadFail m => Seq P.CrucibleType -> m (Some CtxRepr) -fromProtoTypeSeq s0 = do - case Seq.viewr s0 of - Seq.EmptyR -> return (Some Ctx.empty) - s Seq.:> tp -> do - Some ctx <- fromProtoTypeSeq s - Some rep <- fromProtoType tp - return $ Some $ ctx Ctx.:> rep - -fromProtoType :: MonadFail m => P.CrucibleType -> m (Some TypeRepr) -fromProtoType tp = do - let params = tp^.P.crucibleType_params - case tp^.P.crucibleType_id of - P.UnitType -> do - return $ Some UnitRepr - P.BoolType -> do - return $ Some BoolRepr - P.NatType -> do - return $ Some NatRepr - -- TODO: Eliminate this type - P.PosNatType -> do - return $ Some NatRepr - P.IntegerType -> do - return $ Some IntegerRepr - P.RealType -> do - return $ Some RealValRepr - P.ComplexType -> do - return $ Some ComplexRealRepr - P.BitvectorType -> do - case someNat (tp^.P.crucibleType_width) of - Just (Some w) | Just LeqProof <- isPosNat w -> return $ Some $ BVRepr w - _ -> error "Could not parse bitwidth." - - P.HalfFloatType -> do - return $ Some $ FloatRepr HalfFloatRepr - P.SingleFloatType -> do - return $ Some $ FloatRepr SingleFloatRepr - P.DoubleFloatType -> do - return $ Some $ FloatRepr DoubleFloatRepr - P.QuadFloatType -> do - return $ Some $ FloatRepr QuadFloatRepr - P.X86_80FloatType -> do - return $ Some $ FloatRepr X86_80FloatRepr - P.DoubleDoubleFloatType -> do - return $ Some $ FloatRepr DoubleDoubleFloatRepr - - P.CharType -> do - return $ Some CharRepr - P.StringType -> do - return $ Some (StringRepr UnicodeRepr) - P.FunctionHandleType -> do - (args, ret) <- getTail "Missing return type." params - Some arg_ctx <- fromProtoTypeSeq args - Some ret_tp <- fromProtoType ret - return $ Some $ FunctionHandleRepr arg_ctx ret_tp - - P.MaybeType -> do - when (Seq.length params /= 1) $ do - fail $ "Expected single parameter to Maybe." - Some etp <- fromProtoType (params `Seq.index` 0) - return $ Some $ MaybeRepr etp - P.VectorType -> do - when (Seq.length params /= 1) $ do - fail $ "Expected single parameter to Vector" - Some etp <- fromProtoType (params `Seq.index` 0) - return $ Some $ VectorRepr etp - P.StructType -> do - Some ctx <- fromProtoTypeSeq params - return $ Some $ StructRepr ctx - P.WordMapType -> do - when (Seq.length params /= 1) $ do - fail $ "Expected single parameter to WordMap" - Some etp <- fromProtoType (params `Seq.index` 0) - case asBaseType etp of - AsBaseType bt -> - case someNat (tp^.P.crucibleType_width) of - Just (Some w) | Just LeqProof <- isPosNat w -> - return $ Some $ WordMapRepr w bt - _ -> error $ unwords ["Invalid word map type: ", show etp] - _ -> error "Could not parse bitwidth." - - P.StringMapType -> do - when (Seq.length params /= 1) $ do - fail $ "Expected single parameter to StringMapType" - Some etp <- fromProtoType (params `Seq.index` 0) - return $ Some $ StringMapRepr etp - ------------------------------------------------------------------------- --- Generating a protocol buffer type. - -mkType :: P.CrucibleTypeId -> P.CrucibleType -mkType tp = mempty & P.crucibleType_id .~ tp - -mkType1 :: P.CrucibleTypeId -> TypeRepr tp -> P.CrucibleType -mkType1 tp param = mkType tp & setTypeParams (Seq.singleton (mkProtoType param)) - -setTypeParams :: Seq P.CrucibleType -> P.CrucibleType -> P.CrucibleType -setTypeParams params = P.crucibleType_params .~ params - -ctxReprToSeq :: CtxRepr ctx -> Seq (Some TypeRepr) -ctxReprToSeq c = - case Ctx.viewAssign c of - Ctx.AssignEmpty -> Seq.empty - Ctx.AssignExtend ctx r -> ctxReprToSeq ctx Seq.|> Some r - -mkProtoTypeSeq :: CtxRepr ctx -> Seq P.CrucibleType -mkProtoTypeSeq c = (\(Some tp) -> mkProtoType tp) <$> ctxReprToSeq c - -mkProtoType :: TypeRepr tp -> P.CrucibleType -mkProtoType tpr = - case tpr of - UnitRepr -> - mkType P.UnitType - BoolRepr -> - mkType P.BoolType - NatRepr -> - mkType P.NatType - IntegerRepr -> - mkType P.IntegerType - RealValRepr -> - mkType P.RealType - ComplexRealRepr -> - mkType P.ComplexType - BVRepr w -> - mkType P.BitvectorType & P.crucibleType_width .~ fromIntegral (widthVal w) - FloatRepr repr -> mkType c_type - where c_type = case repr of - HalfFloatRepr -> P.HalfFloatType - SingleFloatRepr -> P.SingleFloatType - DoubleFloatRepr -> P.DoubleFloatType - QuadFloatRepr -> P.QuadFloatType - X86_80FloatRepr -> P.X86_80FloatType - DoubleDoubleFloatRepr -> P.DoubleDoubleFloatType - CharRepr -> - mkType P.CharType - StringRepr UnicodeRepr -> - mkType P.StringType - FunctionHandleRepr args ret -> do - let params = mkProtoTypeSeq args Seq.|> mkProtoType ret - mkType P.FunctionHandleType & setTypeParams params - - MaybeRepr tp -> mkType1 P.MaybeType tp - VectorRepr tp -> mkType1 P.VectorType tp - WordMapRepr w tp -> - -- FIXME, better handling of base types - mkType1 P.WordMapType (baseToType tp) & P.crucibleType_width .~ fromIntegral (widthVal w) - - StructRepr ctx -> - mkType P.StructType & setTypeParams (mkProtoTypeSeq ctx) - - StringMapRepr tp -> mkType1 P.StringMapType tp - - _ -> error $ unwords ["crucible-server: type not yet supported", show tpr] diff --git a/crucible-server/src/Lang/Crucible/Server/TypedTerm.hs b/crucible-server/src/Lang/Crucible/Server/TypedTerm.hs deleted file mode 100644 index 8892d8967..000000000 --- a/crucible-server/src/Lang/Crucible/Server/TypedTerm.hs +++ /dev/null @@ -1,66 +0,0 @@ -{- | -Module : $Header$ -Description : SAW-Core terms paired with Cryptol types. -License : BSD3 -Maintainer : huffman -Stability : provisional --} -module Lang.Crucible.Server.TypedTerm where - -import Data.Map (Map) -import qualified Data.Map as Map - -import Cryptol.ModuleSystem.Name (nameIdent) -import qualified Cryptol.TypeCheck.AST as C -import Cryptol.Utils.PP (pretty, text, PP(..)) - -import Verifier.SAW.Cryptol (scCryptolType) -import Verifier.SAW.SharedTerm - --- Typed terms ----------------------------------------------------------------- - -{- Within SAWScript, we represent an object language term as a SAWCore -shared term paired with a Cryptol type schema. The Cryptol type is -used for type inference/checking of inline Cryptol expressions. -} - -data TypedTerm = - TypedTerm - { ttSchema :: C.Schema - , ttTerm :: Term - } - deriving Show - -ttTermLens :: Functor f => (Term -> f Term) -> TypedTerm -> f TypedTerm -ttTermLens f tt = tt `seq` fmap (\x -> tt{ttTerm = x}) (f (ttTerm tt)) - -mkTypedTerm :: SharedContext -> Term -> IO TypedTerm -mkTypedTerm sc trm = do - ty <- scTypeOf sc trm - ct <- scCryptolType sc ty - return $ TypedTerm (C.Forall [] [] ct) trm - --- Ugh... -instance PP TypedTerm where - ppPrec _i (TypedTerm _ x) = text (scPrettyTerm defaultPPOpts x) - - --- Typed modules --------------------------------------------------------------- - -{- In SAWScript, we can refer to a Cryptol module as a first class -value. These are represented simply as maps from names to typed -terms. -} - -data CryptolModule = - CryptolModule (Map C.Name C.TySyn) (Map C.Name TypedTerm) - -showCryptolModule :: CryptolModule -> String -showCryptolModule (CryptolModule sm tm) = - unlines $ - (if Map.null sm then [] else - "Type Synonyms" : "=============" : map showTSyn (Map.elems sm) ++ [""]) ++ - "Symbols" : "=======" : map showBinding (Map.assocs tm) - where - showTSyn (C.TySyn name params _props rhs _doc) = - " " ++ unwords (pretty (nameIdent name) : map pretty params) ++ " = " ++ pretty rhs - showBinding (name, TypedTerm schema _) = - " " ++ pretty (nameIdent name) ++ " : " ++ pretty schema diff --git a/crucible-server/src/Lang/Crucible/Server/ValueConv.hs b/crucible-server/src/Lang/Crucible/Server/ValueConv.hs deleted file mode 100644 index 2863d15e2..000000000 --- a/crucible-server/src/Lang/Crucible/Server/ValueConv.hs +++ /dev/null @@ -1,665 +0,0 @@ ------------------------------------------------------------------------ --- | --- Module : Lang.Crucible.Server.ValueConv --- Copyright : (c) Galois, Inc 2014-2016 --- Maintainer : Rob Dockins --- Stability : provisional --- License : BSD3 --- --- Operations for translating between the protocol-buffer representations --- and the internal Crucible representations of expressions and values. ------------------------------------------------------------------------- - -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeOperators #-} - -module Lang.Crucible.Server.ValueConv where - -#if !MIN_VERSION_base(4,13,0) -import Control.Monad.Fail( MonadFail ) -#endif - -import Control.Lens -import Control.Monad -import qualified Data.Sequence as Seq -import qualified Data.HashTable.IO as HIO -import qualified Control.Monad.Catch as X -import Data.IORef -import qualified Data.Foldable as Fold -import Data.ByteString.Builder (Builder) -import qualified Data.ByteString.Builder as Builder -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as LazyBS -import qualified Data.Vector as V - -import qualified Data.BitVector.Sized as BV -import Data.HPB -import Data.Parameterized.Some -import qualified Data.Parameterized.Context as Ctx - -import What4.Interface - -import Lang.Crucible.CFG.Expr -import qualified Lang.Crucible.CFG.Reg as R -import qualified Lang.Crucible.Proto as P -import Lang.Crucible.Simulator.RegMap -import Lang.Crucible.Server.Encoding -import Lang.Crucible.FunctionHandle -import Lang.Crucible.Server.Simulator -import Lang.Crucible.Server.TypeConv -import Lang.Crucible.Types - - -toByteString :: Builder -> BS.ByteString -toByteString b = LazyBS.toStrict (Builder.toLazyByteString b) - ----------------------------------------------------------------------- --- Exceptions that can be thrown by functions here - -data ValueException where - InvalidUnaryOpArgCount :: String -> Int -> ValueException - InvalidBinaryOpArgCount :: String -> Int -> ValueException - InvalidArgumentType :: String -> TypeRepr ty -> ValueException - InvalidElementType :: String -> TypeRepr ty -> ValueException - InvalidStructureIndex :: String -> Int -> Int -> ValueException - InvalidStructureArgCount :: String -> Int -> Int -> ValueException - InvalidResultType :: String -> TypeRepr ty -> ValueException - BadResultWidth :: String -> NatRepr w -> ValueException - OutOfBounds :: String -> NatRepr w_actual -> NatRepr w_limit -> ValueException - TypeMismatch :: String -> TypeRepr ty1 -> TypeRepr ty2 -> ValueException - -deriving instance Show ValueException -instance X.Exception ValueException - - -withOneArg :: (Show w, X.MonadThrow m, Fold.Foldable t) => - w -> t a -> (a -> m b) -> m b -withOneArg what args op1 = - if Fold.length args == 1 - then let [a1] = take 1 $ Fold.toList args in op1 a1 - else X.throwM $ InvalidUnaryOpArgCount (show what) (Fold.length args) - -with2Args :: (Show w, X.MonadThrow m, Fold.Foldable t) => - w -> t a -> (a -> a -> m b) -> m b -with2Args what args op2 = - if Fold.length args == 2 - then let [a1, a2] = take 2 $ Fold.toList args in op2 a1 a2 - else X.throwM $ InvalidBinaryOpArgCount (show what) (Fold.length args) - -with3Args :: (Show w, X.MonadThrow m, Fold.Foldable t) => - w -> t a -> (a -> a -> a -> m b) -> m b -with3Args what args op3 = - if Fold.length args == 3 - then let [a1, a2, a3] = take 3 $ Fold.toList args in op3 a1 a2 a3 - else X.throwM $ InvalidBinaryOpArgCount (show what) (Fold.length args) - - ------------------------------------------------------------------------- --- RegEntry reference - -newRegEntryRef :: Simulator p sym -> RegEntry sym tp -> IO Word64 -newRegEntryRef sim a = do - cnt <- readIORef (simValueCounter sim) - writeIORef (simValueCounter sim) $! cnt+1 - HIO.insert (simValueCache sim) cnt (Some a) - return cnt - -parseRegEntryRef :: Simulator p sym -> Word64 -> IO (Some (RegEntry sym)) -parseRegEntryRef sim w = do - mv <- HIO.lookup (simValueCache sim) w - case mv of - Just v -> return v - Nothing -> error "Could not find reg entry" - -releaseRegEntryRef :: Simulator p sym -> Word64 -> IO () -releaseRegEntryRef sim w = do - HIO.delete (simValueCache sim) w - ------------------------------------------------------------------------- --- PValue encoding/decoding. - -class HasTypeRepr f where - getTypeRepr :: f tp -> TypeRepr tp - -instance HasTypeRepr (RegEntry sym) where - getTypeRepr (RegEntry tp _) = tp - -instance HasTypeRepr (R.Expr () s) where - getTypeRepr = R.exprType - -instance HasTypeRepr (R.Atom s) where - getTypeRepr = R.typeOfAtom - -checkedRegEntry :: (MonadFail m, HasTypeRepr f) - => TypeRepr tp -> Some f -> m (f tp) -checkedRegEntry tp (Some r) = - case testEquality tp (getTypeRepr r) of - Just Refl -> return r - Nothing -> fail $ unwords ["Unexpected type for protocol value. Expected", show tp, "but got", show (getTypeRepr r)] - -fromProtoValue :: IsSymExprBuilder sym => Simulator p sym -> P.Value -> IO (Some (RegEntry sym)) -fromProtoValue sim v = do - sym <- getInterface sim - case v^.P.value_code of - P.ReferenceValue -> parseRegEntryRef sim (v^.P.value_index) - P.TrueValue -> return $ Some $ RegEntry BoolRepr $ truePred sym - P.FalseValue -> return $ Some $ RegEntry BoolRepr $ falsePred sym - P.NatValue -> do - let i = decodeUnsigned (v^.P.value_data) - Some . RegEntry NatRepr <$> natLit sym (fromInteger i) - P.IntegerValue -> do - let i = decodeSigned (v^.P.value_data) - Some . RegEntry IntegerRepr <$> intLit sym i - P.RationalValue -> do - r <- decodeRational (v^.P.value_data) - Some . RegEntry RealValRepr <$> realLit sym r - P.BitvectorValue -> do - let width = v^.P.value_width - case someNat (toInteger width) of - Just (Some n) | Just LeqProof <- isPosNat n -> do - let i = decodeSigned (v^.P.value_data) - Some . RegEntry (BVRepr n) <$> bvLit sym n (BV.mkBV n i) - _ -> error "Width is too large" - P.StringValue -> do - let s = v^.P.value_string_lit - Some . RegEntry (StringRepr UnicodeRepr) <$> stringLit sym (UnicodeLiteral s) - P.UnitValue -> do - return $ Some $ RegEntry UnitRepr () - P.FnHandleValue -> do - SomeHandle h <- getHandleBinding sim (v^.P.value_index) - return $ Some $ RegEntry (handleType h) (HandleFnVal h) - -toProtoValue :: IsSymExprBuilder sym => Simulator p sym -> RegEntry sym tp -> IO P.Value -toProtoValue sim e@(RegEntry tp v) = - case tp of - BoolRepr - | Just True <- asConstantPred v -> do - return $ mempty & P.value_code .~ P.TrueValue - | Just False <- asConstantPred v -> do - return $ mempty & P.value_code .~ P.FalseValue - - NatRepr | Just x <- asNat v -> do - return $ mempty & P.value_code .~ P.NatValue - & P.value_data .~ toByteString (encodeUnsigned (toInteger x)) - IntegerRepr | Just x <- asInteger v -> do - return $ mempty & P.value_code .~ P.IntegerValue - & P.value_data .~ toByteString (encodeSigned (toInteger x)) - - RealValRepr | Just r <- asRational v -> do - return $ mempty & P.value_code .~ P.RationalValue - & P.value_data .~ toByteString (encodeRational r) - BVRepr w | Just r <- BV.asSigned w <$> asBV v - , wv <- natValue w - , wv <= fromIntegral (maxBound :: Word64) -> do - return $ mempty & P.value_code .~ P.BitvectorValue - & P.value_width .~ fromIntegral wv - & P.value_data .~ toByteString (encodeSigned r) - StringRepr UnicodeRepr - | Just (UnicodeLiteral txt) <- asString v -> do - return $ mempty & P.value_code .~ P.StringValue - & P.value_string_lit .~ txt - UnitRepr -> do - return $ mempty & P.value_code .~ P.UnitValue - FunctionHandleRepr _ _ - | HandleFnVal h <- v -> do - return $ mempty & P.value_code .~ P.FnHandleValue - & P.value_index .~ handleRef h - & P.value_handle_info .~ toProtoHandleInfo h - _ -> do - idx <- newRegEntryRef sim e - return $ mempty & P.value_code .~ P.ReferenceValue - & P.value_index .~ idx - - ----------------------------------------------------------------------- - -data NatReprParseFailure where - NatParseNegative :: Integer -> NatReprParseFailure - NotNatValue :: P.ValueCode -> NatReprParseFailure - -deriving instance Show NatReprParseFailure -instance X.Exception NatReprParseFailure - - -parseNatRepr :: (Monad m, X.MonadThrow m) => P.Value -> m (Some NatRepr) -parseNatRepr v = - case v^.P.value_code of - P.NatValue -> do - let i = decodeUnsigned (v^.P.value_data) - case someNat i of - Just rep -> return rep - Nothing -> X.throwM $ NatParseNegative i - _ -> X.throwM $ NotNatValue (v^.P.value_code) - -{- --- | Convert a protocol buffer value to a specific RegValue. -regValueFromProto :: IsSymInterface sym - => Simulator sym -> P.Value -> TypeRepr tp -> IO (RegValue sym tp) -regValueFromProto sim v tp = do - someReg <- fromProtoValue sim v - RegEntry _ r <- checkedRegEntry tp someReg - return r --} - ------------------------------------------------------------------------- --- convertToCrucibleApp - --- | A binary operation on bitvectores. -type BVBinOp f n r = NatRepr n -> f (BVType n) -> f (BVType n) -> App () f r - --- | A symbolic bitvector expression with some bitwidth. -data SomeBV f = forall n . (1 <= n) => SomeBV (NatRepr n) (f (BVType n)) - -convertToCrucibleApp :: (Applicative m, MonadFail m, HasTypeRepr f, X.MonadThrow m) - => (a -> m (Some f)) - -> (a -> m (Some NatRepr)) - -> P.PrimitiveOp - -> Seq a - -> P.CrucibleType - -> m (Some (App () f)) -convertToCrucibleApp evalVal evalNatRepr prim_op args res_type = do - Some res_tp <- fromProtoType res_type - convertToCrucibleApp' evalVal evalNatRepr prim_op args res_tp - -convertToCrucibleApp' :: forall a f res_tp m - . (Applicative m, MonadFail m, HasTypeRepr f, X.MonadThrow m) - => (a -> m (Some f)) - -> (a -> m (Some NatRepr)) - -- ^ Parse argument as a concrete nat. - -> P.PrimitiveOp - -> Seq a - -> TypeRepr res_tp - -> m (Some (App () f)) -convertToCrucibleApp' evalVal evalNatRepr prim_op args result_type = do - let evalTypedValue :: TypeRepr tp -> a -> m (f tp) - evalTypedValue tp v = checkedRegEntry tp =<< evalVal v - - -- Gets a bitvector value. - let evalBV :: a -> m (SomeBV f) - evalBV v = do - Some r <- evalVal v - case getTypeRepr r of - BVRepr n -> return (SomeBV n r) - _ -> X.throwM $ InvalidArgumentType (show prim_op ++ "evalBV") $ - getTypeRepr r - - let evalCtxIndex :: a -> CtxRepr ctx -> TypeRepr tp -> m (Ctx.Index ctx tp) - evalCtxIndex a ctx_repr ty_repr = do - Some i <- evalNatRepr a - case Ctx.intIndex (fromIntegral (natValue i)) (Ctx.size ctx_repr) of - Just (Some idx) -> - case testEquality (ctx_repr Ctx.! idx) ty_repr of - Just Refl -> return idx - Nothing -> X.throwM $ TypeMismatch - (show prim_op <> " structure index " <> show i) - (ctx_repr Ctx.! idx) ty_repr - Nothing -> X.throwM $ InvalidStructureIndex (show prim_op) - (fromIntegral (natValue i)) - (Ctx.sizeInt $ Ctx.size ctx_repr) - - let defCoerce :: KnownRepr TypeRepr tp => a -> m (f tp) - defCoerce v = evalTypedValue knownRepr v - - let def :: m (App () f tp) -> m (Some (App () f)) - def a = Some <$> a - - let bvBinOp :: (forall n . (1 <= n) => BVBinOp f n (BVType n)) - -> m (Some (App () f)) - bvBinOp f = with2Args prim_op args $ \x y -> do - SomeBV n xr <- evalBV x - yr <- evalTypedValue (getTypeRepr xr) y - return $ Some $ f n xr yr - - let bvRel :: (forall n . (1 <= n) => BVBinOp f n BoolType) - -> m (Some (App () f)) - bvRel f = with2Args prim_op args $ \x y -> do - SomeBV n xr <- evalBV x - yr <- evalTypedValue (getTypeRepr xr) y - return $ Some $ f n xr yr - - case prim_op of - P.BoolNot -> withOneArg prim_op args $ \x -> - def $ Not <$> defCoerce x - P.BoolAnd -> with2Args prim_op args $ \x y -> do - def $ And <$> defCoerce x - <*> defCoerce y - P.BoolXor -> with2Args prim_op args $ \x y -> do - def $ BoolXor <$> defCoerce x - <*> defCoerce y - P.BoolIte -> with3Args prim_op args $ \c x y -> do - def $ BoolIte <$> defCoerce c - <*> defCoerce x - <*> defCoerce y - - P.NatAdd -> with2Args prim_op args $ \x y -> do - def $ NatAdd <$> defCoerce x - <*> defCoerce y - P.NatMul -> with2Args prim_op args $ \x y -> do - def $ NatMul <$> defCoerce x - <*> defCoerce y - P.NatEq -> with2Args prim_op args $ \x y -> do - def $ NatEq <$> defCoerce x - <*> defCoerce y - P.NatLt -> with2Args prim_op args $ \x y -> do - def $ NatLt <$> defCoerce x - <*> defCoerce y - - -------------------------------------------------------------------- - -- Operations on Integers - - P.IntegerAdd -> with2Args prim_op args $ \x y -> do - def $ IntAdd <$> defCoerce x - <*> defCoerce y - P.IntegerSub -> with2Args prim_op args $ \x y -> do - def $ IntSub <$> defCoerce x - <*> defCoerce y - P.IntegerMul -> with2Args prim_op args $ \x y -> do - def $ IntMul <$> defCoerce x - <*> defCoerce y - P.IntegerEq -> with2Args prim_op args $ \x y -> do - def $ IntEq <$> defCoerce x - <*> defCoerce y - P.IntegerLt -> with2Args prim_op args $ \x y -> do - def $ IntLt <$> defCoerce x - <*> defCoerce y - - -------------------------------------------------------------------- - -- Operations on Reals - - P.RealAdd -> with2Args prim_op args $ \x y -> do - def $ RealAdd <$> defCoerce x - <*> defCoerce y - P.RealSub -> with2Args prim_op args $ \x y -> do - def $ RealSub <$> defCoerce x - <*> defCoerce y - P.RealMul -> with2Args prim_op args $ \x y -> do - def $ RealMul <$> defCoerce x - <*> defCoerce y - P.RealIte -> with3Args prim_op args $ \c x y -> do - def $ RealIte <$> defCoerce c - <*> defCoerce x - <*> defCoerce y - P.RealEq -> with2Args prim_op args $ \x y -> do - def $ RealEq <$> defCoerce x - <*> defCoerce y - P.RealLt -> with2Args prim_op args $ \x y -> do - def $ RealLt <$> defCoerce x - <*> defCoerce y - - -------------------------------------------------------------------- - -- Bitvector operations - - P.BVAdd -> bvBinOp BVAdd - P.BVSub -> bvBinOp BVSub - P.BVMul -> bvBinOp BVMul - P.BVUdiv -> bvBinOp BVUdiv - P.BVUrem -> bvBinOp BVUrem - P.BVSdiv -> bvBinOp BVSdiv - P.BVSrem -> bvBinOp BVSrem - P.BVIte -> with3Args prim_op args $ \c x y -> do - cr <- defCoerce c :: m (f BoolType) - SomeBV n xr <- evalBV x - let tp = getTypeRepr xr - yr <- evalTypedValue tp y - return $ Some $ BVIte cr n xr yr - P.BVEq -> bvRel BVEq - P.BVUle -> bvRel BVUle - P.BVUlt -> bvRel BVUlt - P.BVSle -> bvRel BVSle - P.BVSlt -> bvRel BVSlt - P.BVCarry -> bvRel BVCarry - P.BVSCarry -> bvRel BVSCarry - P.BVSBorrow -> bvRel BVSBorrow - - P.BVShl -> bvBinOp BVShl - P.BVLshr -> bvBinOp BVLshr - P.BVAshr -> bvBinOp BVAshr - P.BVNot -> withOneArg prim_op args $ \x -> do - SomeBV n xr <- evalBV x - return $ Some $ BVNot n xr - P.BVAnd -> bvBinOp BVAnd - P.BVOr -> bvBinOp BVOr - P.BVXor -> bvBinOp BVXor - P.BoolToBV -> withOneArg prim_op args $ \x -> do - rx <- evalTypedValue BoolRepr x - case result_type of - BVRepr result_width | Just LeqProof <- isPosNat result_width -> do - return $ Some $ BoolToBV result_width rx - _ -> X.throwM $ InvalidResultType "BoolToBV" result_type - P.BVNonzero -> withOneArg prim_op args $ \x -> do - SomeBV w xr <- evalBV x - return $ Some $ BVNonzero w xr - P.BVConcat -> with2Args prim_op args $ \x y -> do - SomeBV w1 xr <- evalBV x - SomeBV w2 yr <- evalBV y - case isPosNat (addNat w1 w2) of - Just LeqProof -> return $ Some $ BVConcat w1 w2 xr yr - Nothing -> X.throwM $ BadResultWidth "BVConcat" (addNat w1 w2) - P.BVSelect -> with3Args prim_op args $ \idx n x -> do - Some idx_repr <- evalNatRepr idx - Some n_repr <- evalNatRepr n - case isPosNat n_repr of - Nothing -> X.throwM $ BadResultWidth "BVSelect" n_repr - Just LeqProof -> do - SomeBV w xr <- evalBV x - case (addNat idx_repr n_repr) `testLeq` w of - Just LeqProof -> return $ Some $ BVSelect idx_repr n_repr w xr - Nothing -> X.throwM $ - OutOfBounds "BVSelect" (addNat idx_repr n_repr) w - P.BVTrunc -> withOneArg prim_op args $ \x -> do - SomeBV n xr <- evalBV x - case result_type of - BVRepr result_width -> - case isPosNat result_width of - Just LeqProof -> - case incNat result_width `testLeq` n of - Just LeqProof -> return $ Some $ BVTrunc result_width n xr - Nothing -> X.throwM $ OutOfBounds - "BVTrunc (larger than input)" - (incNat result_width) n - Nothing -> X.throwM $ BadResultWidth "BVTrunc" result_width - _ -> X.throwM $ InvalidResultType "BVTrunc" result_type - P.BVZext -> withOneArg prim_op args $ \x -> do - SomeBV n xr <- evalBV x - case result_type of - BVRepr result_width -> - case incNat n `testLeq` result_width of - Just LeqProof -> return $ Some $ BVZext result_width n xr - Nothing -> X.throwM $ OutOfBounds - "BVZext (less than input)" - (incNat n) result_width - _ -> X.throwM $ InvalidResultType "BVZext" result_type - P.BVSext -> withOneArg prim_op args $ \x -> do - SomeBV n xr <- evalBV x - case result_type of - BVRepr result_width -> - case testLeq (incNat n) result_width of - Just LeqProof -> return $ Some $ BVSext result_width n xr - Nothing -> X.throwM $ OutOfBounds - "BVSext (less than input)" - (incNat n) result_width - _ -> X.throwM $ InvalidResultType "BVSext" result_type - - -------------------------------------------------------------------- - -- Conversions - - P.NatToInteger -> withOneArg prim_op args $ \x -> do - def $ NatToInteger <$> defCoerce x - P.IntegerToReal -> withOneArg prim_op args $ \x -> do - def $ IntegerToReal <$> defCoerce x - - -------------------------------------------------------------------- - -- WordMap Operations - - P.WordMapEmpty -> do - case result_type of - WordMapRepr w tp -> - return $ Some $ EmptyWordMap w tp - _ -> X.throwM $ InvalidResultType "WordMapEmpty" result_type - - P.WordMapInsert -> with3Args prim_op args $ \i v m -> do - SomeBV w i' <- evalBV i - Some v' <- evalVal v - case asBaseType (getTypeRepr v') of - AsBaseType bt -> do - m' <- evalTypedValue (WordMapRepr w bt) m - case isPosNat w of - Just LeqProof -> - return $ Some $ InsertWordMap w bt i' v' m' - Nothing -> X.throwM $ BadResultWidth "WordMapInsert word width" w - _ -> X.throwM $ InvalidElementType "WordMapInsert" $ getTypeRepr v' - - P.WordMapLookup -> with2Args prim_op args $ \i m -> do - SomeBV w i' <- evalBV i - case asBaseType result_type of - AsBaseType bt -> do - m' <- evalTypedValue (WordMapRepr w bt) m - case isPosNat w of - Just LeqProof -> return $ Some $ LookupWordMap bt i' m' - Nothing -> X.throwM $ BadResultWidth "WordMapLookup word width" w - _ -> X.throwM $ InvalidElementType "WordMapLookup" result_type - - P.WordMapLookupWithDefault -> with3Args prim_op args $ \i m d -> do - case asBaseType result_type of - AsBaseType bt -> do - SomeBV w i' <- evalBV i - d' <- evalTypedValue result_type d - m' <- evalTypedValue (WordMapRepr w bt) m - case isPosNat w of - Just LeqProof -> - return $ Some $ LookupWordMapWithDefault bt i' m' d' - Nothing -> X.throwM $ BadResultWidth - "WordMapLookupWithDefault word width" w - _ -> X.throwM $ InvalidElementType - "WordMapLookupWithDefault" result_type - - ----------------------------------------------------------------------- - -- Struct Operations - - P.StructLiteral -> do - case result_type of - StructRepr ctx_repr -> do - let sz = Ctx.size ctx_repr - when (Fold.length args /= Ctx.sizeInt sz) $ - X.throwM $ InvalidStructureArgCount "StructLiteral" - (Seq.length args) (Ctx.sizeInt sz) - ctx <- Ctx.generateM (Ctx.size ctx_repr) $ \i -> do - let tp = ctx_repr Ctx.! i - evalTypedValue tp (Seq.index args (Ctx.indexVal i)) - return $ Some $ MkStruct ctx_repr ctx - _ -> X.throwM $ InvalidResultType "StructLiteral" result_type - - P.StructSet -> with3Args prim_op args $ \s i x -> do - case result_type of - StructRepr ctx_repr -> do - sv <- evalTypedValue result_type s - Some xv <- evalVal x - idx <- evalCtxIndex i ctx_repr (getTypeRepr xv) - return $ Some $ SetStruct ctx_repr sv idx xv - _ -> X.throwM $ InvalidResultType "StructSet" result_type - - P.StructGet -> with2Args prim_op args $ \i s -> do - Some sv <- evalVal s - case getTypeRepr sv of - StructRepr ctx_repr -> do - idx <- evalCtxIndex i ctx_repr result_type - return $ Some $ GetStruct sv idx result_type - _ -> X.throwM $ InvalidResultType "StructGet" result_type - - -------------------------------------------------------------------- - -- Maybe Operations - - P.NothingValue -> do - case result_type of - MaybeRepr tp -> return $ Some $ NothingValue tp - _ -> X.throwM $ InvalidResultType "NothingValue" result_type - - P.JustValue -> do - case result_type of - MaybeRepr tp -> withOneArg prim_op args $ \x -> do - xr <- evalTypedValue tp x - return $ Some $ JustValue tp xr - _ -> X.throwM $ InvalidResultType "JustValue" result_type - - -------------------------------------------------------------------- - -- Debugging operations - - P.ShowValue -> do - case result_type of - StringRepr UnicodeRepr -> withOneArg prim_op args $ \x -> do - Some v <- evalVal x - case asBaseType (getTypeRepr v) of - AsBaseType bt -> return $ Some $ ShowValue bt v - NotBaseType -> X.throwM $ InvalidResultType - "ShowValue (expected base type)" $ getTypeRepr v - _ -> X.throwM $ InvalidResultType "ShowValue" result_type - - -------------------------------------------------------------------- - -- Introspection operations - - P.IsConcrete -> do - case result_type of - BoolRepr -> withOneArg prim_op args $ \x -> do - Some v <- evalVal x - case asBaseType (getTypeRepr v) of - AsBaseType bt -> return $ Some $ IsConcrete bt v - NotBaseType -> X.throwM $ InvalidResultType - "IsConcrete (expected base type)" $ getTypeRepr v - _ -> X.throwM $ InvalidResultType "IsConcrete" result_type - - -------------------------------------------------------------------- - -- Vector Operations - - P.VectorLit -> do - case result_type of - VectorRepr tp -> do - xs <- mapM (evalTypedValue tp) (Fold.toList args) - let v = V.fromList xs - return $ Some $ VectorLit tp v - _ -> X.throwM $ InvalidResultType "VectorLit" result_type - - P.VectorReplicate -> do - case result_type of - VectorRepr tp -> with2Args prim_op args $ \x n -> do - nr <- defCoerce n - xr <- evalTypedValue tp x - return $ Some $ VectorReplicate tp nr xr - _ -> X.throwM $ InvalidResultType "VectorRepr" result_type - - P.VectorSize -> withOneArg prim_op args $ \x -> do - Some xr <- evalVal x - case getTypeRepr xr of - VectorRepr _tp -> return $ Some $ VectorSize xr - _ -> X.throwM $ InvalidResultType "VectorSize" result_type - - P.VectorIsEmpty -> withOneArg prim_op args $ \x -> do - Some xr <- evalVal x - case getTypeRepr xr of - VectorRepr _tp -> return $ Some $ VectorIsEmpty xr - _ -> X.throwM $ InvalidResultType "VectorIsEmpty" result_type - - P.VectorGetEntry -> with2Args prim_op args $ \x n -> do - Some xr <- evalVal x - nr <- evalTypedValue NatRepr n - case getTypeRepr xr of - VectorRepr tp -> return $ Some $ VectorGetEntry tp xr nr - _ -> X.throwM $ InvalidResultType "VectorGetEntry" result_type - - P.VectorSetEntry -> with3Args prim_op args $ \x n a -> do - Some xr <- evalVal x - nr <- evalTypedValue NatRepr n - Some ar <- evalVal a - case getTypeRepr xr of - VectorRepr tp -> - case testEquality tp (getTypeRepr ar) of - Just Refl -> return $ Some $ VectorSetEntry tp xr nr ar - _ -> X.throwM $ TypeMismatch "VectorSetEntry" tp $ getTypeRepr ar - _ -> X.throwM $ InvalidArgumentType "VectorSetEntry" $ getTypeRepr xr diff --git a/crucible-server/src/Lang/Crucible/Server/Verification/Harness.hs b/crucible-server/src/Lang/Crucible/Server/Verification/Harness.hs deleted file mode 100644 index 60b4ca67f..000000000 --- a/crucible-server/src/Lang/Crucible/Server/Verification/Harness.hs +++ /dev/null @@ -1,760 +0,0 @@ ------------------------------------------------------------------------ --- | --- Module : Lang.Crucible.Server.Verification.Harness --- Copyright : (c) Galois, Inc 2017 --- Maintainer : Rob Dockins --- Stability : provisional --- License : BSD3 --- --- Support for manipulating compositional verification harnesses. ------------------------------------------------------------------------- - -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} - -module Lang.Crucible.Server.Verification.Harness - ( -- * Verification Harness data types - Offset - , HarnessVarType(..) - , harnessToCryptolType - , HarnessVarDecl(..) - , HarnessVar(..) - , Phase(..) - , VerificationSetupStep(..) - , VerificationPhase(..) - , Endianness(..) - , VerificationHarness(..) - , displayHarness - - -- * Parsing and preparing verification harnesses - , ProcessedHarness - , TCExpr - , processHarness - ) where - -import Control.Exception -import Control.Lens -import Control.Monad.State.Strict -import Control.Monad.Reader -import Control.Monad.Writer.Strict ---import Control.Monad -import qualified Data.ByteString as BS -import Data.Foldable -import qualified Data.Map as Map -import Data.Set (Set) -import qualified Data.Set as Set -import Data.Sequence (Seq) -import qualified Data.Sequence as Seq -import Data.String -import Data.Text (Text) -import qualified Data.Text as T -import Data.Tuple -import Data.Word - -import qualified Cryptol.ModuleSystem.Base as MB -import qualified Cryptol.ModuleSystem.Renamer as MR -import qualified Cryptol.ModuleSystem.Monad as MM -import qualified Cryptol.Parser.AST as CP -import qualified Cryptol.Parser as CP -import qualified Cryptol.Parser.Names as CP -import qualified Cryptol.TypeCheck.AST as CT ---import qualified Cryptol.TypeCheck.Monad as CT -import qualified Cryptol.Utils.Ident as C -import qualified Cryptol.Utils.PP as PP - - - -import qualified Lang.Crucible.Proto as P - -import Verifier.SAW.SharedTerm -import Lang.Crucible.Server.CryptolEnv - -type Offset = Word64 - --- | The types of values that can be involved in a verification harness -data HarnessVarType - = HarnessVarWord Word64 - -- ^ A bitvector variable, with the given width. - -- INVARIANT: the width is a multple of 8. - | HarnessVarArray Word64 Word64 - -- ^ A variable representing an array of bitvectors, - -- with the given number of elements and word width. - -- INVARIANT: the width is a multple of 8. - --- | Compute the Cryptol type that corresponds to the given --- harness type. -harnessToCryptolType :: HarnessVarType -> CT.Type -harnessToCryptolType (HarnessVarWord n) = - CT.tWord (CT.tNum n) -harnessToCryptolType (HarnessVarArray elems n) = - CT.tSeq (CT.tNum elems) (CT.tWord (CT.tNum n)) - -instance PP.PP HarnessVarType where - ppPrec i = PP.ppPrec i . harnessToCryptolType - --- | A harness variable declaration, consisting of an identifier --- and a harness type. -data HarnessVarDecl id - = HarnessVarDecl - { harnessVarIdent :: id - , harnessVarType :: HarnessVarType - } - -instance PP.PP id => PP.PP (HarnessVarDecl id) where - ppPrec _i x = PP.pp (harnessVarIdent x) PP.<+> PP.text "::" PP.<+> PP.pp (harnessVarType x) - - --- | A variable that can appear in harness setup steps. -data HarnessVar id - = CryptolVar id - -- ^ A user-declared variable - | ReturnAddressVar - -- ^ The special built-in variable representing the - -- return address - | StackPointerVar - -- ^ The special built-in variable representing the - -- current stack pointer - deriving (Eq, Ord, Functor) - -instance PP.PP id => PP.PP (HarnessVar id) where - ppPrec i x = - case x of - CryptolVar nm -> PP.ppPrec i nm - ReturnAddressVar -> PP.text "return" - StackPointerVar -> PP.text "stack" - --- | Verification setup steps capture the steps that are necessary --- to setup/check the state of registers and memory before/after --- running a verification, or when using a specification as an override. --- --- Each of the setup steps below cause a harness variable to be set to --- a particular value. The semantics of this are such that, if the variable --- is already set to some value, an equality constraint is generated to state --- that the old value is equal to the new value. -data VerificationSetupStep id ex - = BindVariable (HarnessVar id) ex - -- ^ The given harness variable is assigned the given expression. - - | DeclareFreshVariable id - -- ^ Create a fresh symbolic value and bind it to the named harness variable. - - | RegisterVal Offset (HarnessVar id) - -- ^ Fetch the value of the given register offset into the given harness variable. - -- The number of bytes fetched from the register file is determined by the type - -- of the harness variable. - - | MemPointsTo (HarnessVar id) Offset (HarnessVar id) - -- ^ The first harness var argument is interpreted as a base pointer value; the given - -- offset is added to this value, and the value in memory is fetched and bound to the - -- value of the second harness variable. - deriving (Functor) - -instance (PP.PP id, PP.PP ex) => PP.PP (VerificationSetupStep id ex) where - ppPrec _i (BindVariable var ex) = - PP.pp var PP.<+> PP.text ":=" PP.<+> PP.pp ex - ppPrec _ (DeclareFreshVariable var) = - PP.pp var PP.<+> PP.text ":=" PP.<+> PP.text "" - ppPrec _i (RegisterVal off var) = - PP.text "reg[" PP.<.> PP.integer (fromIntegral off) PP.<.> PP.text "] :=" PP.<+> PP.pp var - ppPrec _i (MemPointsTo base off var) = - PP.pp base PP.<+> PP.text "+" PP.<+> PP.integer (fromIntegral off) PP.<+> PP.text "|->" PP.<+> PP.pp var - --- | A verification phase represents either the pre or post condition of a verification. --- In either case, some fresh variables may be introduced, and their values bound using --- the verification setup steps. Finally, some general logical conditions can be asserted --- as pre/post conditions. In preconditions, such conditions will be assumed, whereas they --- will be asserted as proof obligations in postconditions. -data VerificationPhase id ex - = VerificationPhase - { phaseVars :: Seq (HarnessVarDecl id) - , phaseSetup :: Seq (VerificationSetupStep id ex) - , phaseConds :: Seq ex - } - deriving (Functor) - -instance (PP.PP id, PP.PP ex) => PP.PP (VerificationPhase id ex) where - ppPrec _i phase = - PP.text "== Variables ==" - PP.$$ - PP.vcat (map PP.pp $ toList (phaseVars phase)) - PP.$$ - PP.text "== Setup ==" - PP.$$ - PP.vcat (map PP.pp $ toList (phaseSetup phase)) - PP.$$ - PP.text "== Conditions ==" - PP.$$ - PP.vcat (map PP.pp $ toList (phaseConds phase)) - --- | Is the architecture big or little endian? -data Endianness - = LittleEndian - | BigEndian - deriving (Eq, Ord, Show) - --- | A verification harness represents a function specification. --- These harness may be used in two different modes --- --- First, they can be used to perform a verification. In this case, --- the prestate phase is used to set up a fresh memory and register --- state, before symbolically executing the program. After the program --- termiantes, the poststate phase is used to fetch values from the final --- register and memory state and to collect proof obligations. --- --- Secondly, verification harness can be used to construct "override" functions. --- These functions render the function specification as callable subroutines --- that simply implement the specification semantics. In this mode, the prestate --- is used to fetch values from the register file and memory and collect proof --- obligiations (that the call site satisfies the preconditions). Then, the --- poststate phase is used to update the memory and register file. Any generated --- equalities or postconditions are asserted, and control is returned to the caller. -data VerificationHarness id ex - = VerificationHarness - { verificationOverrideName :: Text -- ^ Human-readable name - , verificationRegFileWidth :: Word64 -- ^ Number of bits required to address a register - , verificationAddressWidth :: Word64 -- ^ Number of bits in a pointer for the architecture (must be a multiple of 8) - , verificationEndianness :: Endianness -- ^ Big or little endian? - , verificationPrestate :: VerificationPhase id ex -- ^ Function prestate - , verificationPoststate :: VerificationPhase id ex -- ^ Function poststate - , verificationOutput :: Maybe ex -- ^ Optional function output (for term extraction) - } - deriving (Functor) - -instance (PP.PP id, PP.PP ex) => PP.PP (VerificationHarness id ex) where - ppPrec _i harness = - PP.text ("==== Harness: " ++ (T.unpack (verificationOverrideName harness)) ++ " ====") - PP.$$ - PP.text ( "Address width: " ++ show (verificationAddressWidth harness) ++ - " " ++ - "Register file width: " ++ show (verificationRegFileWidth harness) ++ - " " ++ - "Endianness: " ++ show (verificationEndianness harness)) - PP.$$ - PP.text "=== Prestate ===" - PP.$$ - PP.pp (verificationPrestate harness) - PP.$$ - PP.text "=== Poststate ===" - PP.$$ - PP.pp (verificationPoststate harness) - PP.<.> - case (verificationOutput harness) of - Nothing -> PP.empty - Just o -> PP.empty PP.$$ - PP.text "=== Output ===" - PP.$$ PP.pp o - -type ParseExpr = CP.Expr CP.PName -type TCExpr = (CT.Type, CT.Expr) -type M = ReaderT (String -> IO (), SharedContext) (StateT CryptolEnv IO) -type ProcessedHarness = VerificationHarness CT.Name TCExpr - -io :: IO a -> M a -io = lift . lift - -runM :: (String -> IO ()) -> SharedContext -> CryptolEnv -> M a -> IO (CryptolEnv, a) -runM hout sc cryEnv m = swap <$> runStateT (runReaderT m (hout,sc)) cryEnv - --- | Take the wire format for harness and plug the various pieces into --- the processed verification harness data structure. --- --- Among other tasks, this involve parsing and typechecking any embedded --- Cryptol expressions in the verification setup steps. This may have --- the effect of adding new Cryptol variables to the supplied CryptolEnv. -processHarness :: - (String -> IO ()) -> - SharedContext -> - CryptolEnv -> - P.VerificationHarness -> - IO (CryptolEnv, ProcessedHarness) -processHarness hout sc env h = runM hout sc env (doProcessHarness h) - - -doProcessHarness :: - P.VerificationHarness -> - M ProcessedHarness -doProcessHarness rawHarness = - do let addrWidth = rawHarness^.P.verificationHarness_address_width - let regFileWidth = rawHarness^.P.verificationHarness_reg_file_width - let endianness = case rawHarness^.P.verificationHarness_endianness of - P.BigEndian -> BigEndian - P.LittleEndian -> LittleEndian - - mapM_ loadCryptolSource (rawHarness^.P.verificationHarness_cryptol_sources) - - prestate <- processPhase Prestate addrWidth endianness - (rawHarness^.P.verificationHarness_prestate_specification) - poststate <- processPhase Poststate addrWidth endianness - (rawHarness^.P.verificationHarness_poststate_specification) - output <- processOutputExpr (rawHarness^.P.verificationHarness_output_expr) - unless (addrWidth `mod` 8 == 0 && addrWidth > 0) - (fail $ "Invalid address width: " ++ show addrWidth) - return VerificationHarness - { verificationOverrideName = rawHarness^.P.verificationHarness_name - , verificationPrestate = prestate - , verificationPoststate = poststate - , verificationAddressWidth = addrWidth - , verificationRegFileWidth = regFileWidth - , verificationEndianness = endianness - , verificationOutput = output - } - -loadCryptolSource :: Text -> M () -loadCryptolSource fname = - do (_,sc) <- ask - cenv <- get - let im = Import - { iModule = Left $ T.unpack fname - , iAs = Nothing - , iSpec = Nothing - } - cenv' <- io $ importModule sc cenv im - put cenv' - -displayHarness :: - PP.PP id => - PP.PP ex => - VerificationHarness id ex -> - Text -displayHarness harness = - T.pack . PP.render . PP.pp $ harness - -processOutputExpr :: - Text -> - M (Maybe TCExpr) -processOutputExpr rawex - | T.null rawex = return Nothing - | otherwise = Just <$> - do cryEnv <- get - pex <- parseCryptolExpr "extraction output term" rawex - (cryEnv', sch, ex) <- io $ inferTerm cryEnv pex - put cryEnv' - case CT.isMono sch of - Nothing -> fail "Expected monomorphic type in extraction output term" - Just ty -> return (ty, ex) - -processPhase :: - Phase -> - Word64 -> - Endianness -> - P.StateSpecification -> - M (VerificationPhase CT.Name TCExpr) -processPhase phase addrWidth _endianness rawPhase = - tcPhase phase addrWidth =<< parsePhase phase addrWidth rawPhase - -parsePhase :: - Phase -> - Word64 -> - P.StateSpecification -> - M (VerificationPhase C.Ident ParseExpr) -parsePhase phase addrWidth rawPhase = - do vars <- mapM parseVar (rawPhase^.P.stateSpecification_variables) - specialDecls <- specialPhaseDecls phase addrWidth - regs <- mapM parseRegAssign (rawPhase^.P.stateSpecification_register_assignments) - mems <- mapM parseMemAssign (rawPhase^.P.stateSpecification_memory_assignments) - binds <- mapM parseVarBinding (rawPhase^.P.stateSpecification_variable_bindings) - conds <- mapM (parseCondition phase) (rawPhase^.P.stateSpecification_conditions) - return VerificationPhase - { phaseVars = vars <> specialDecls - , phaseSetup = regs <> mems <> binds - , phaseConds = conds - } - --- | Certain special variables are automatically brought into scopte in the prestate --- of a function verification. These are the stack pointer (which is usually located --- in a register which is known according to the platform ABI) and the return address, --- which is generally found either in a distinguished location on the stack or in --- a distinguished register. -specialPhaseDecls :: - Phase -> - Word64 -> - M (Seq (HarnessVarDecl C.Ident)) -specialPhaseDecls Prestate addrWidth = - do let htp = HarnessVarWord addrWidth - return $ Seq.fromList - [ HarnessVarDecl (fromString "stack") htp - , HarnessVarDecl (fromString "return") htp - ] -specialPhaseDecls Poststate _ = - return mempty - -parseVar :: - P.VariableSpecification -> - M (HarnessVarDecl C.Ident) -parseVar vspec = - do let v = C.mkIdent (vspec^.P.variableSpecification_name) - tp <- case toList (vspec^.P.variableSpecification_dimensions) of - [elems,width] | width `mod` 8 == 0 -> - return $ HarnessVarArray elems width - [width] | width `mod` 8 == 0 -> - return $ HarnessVarWord width - dims -> - io $ throwIO $ userError $ - "Variable " <> T.unpack (C.identText v) <> - " declared with disallowed dimensions: " <> - show dims - return HarnessVarDecl - { harnessVarIdent = v - , harnessVarType = tp - } - -parseVariableReference :: - P.VariableReference -> - M (HarnessVar C.Ident) -parseVariableReference vref = - case vref^.P.variableReference_code of - P.StackPointerVar -> return StackPointerVar - P.ReturnAddressVar -> return ReturnAddressVar - P.UserVar -> return . CryptolVar . C.mkIdent $ vref^.P.variableReference_var_name - -parseRegAssign :: - P.RegisterAssignment -> - M (VerificationSetupStep C.Ident ParseExpr) -parseRegAssign asgn = - do let off = asgn^.P.registerAssignment_reg_offset - var <- parseVariableReference (asgn^.P.registerAssignment_value) - return $ RegisterVal off var - -parseMemAssign :: - P.MemoryAssignment -> - M (VerificationSetupStep C.Ident ParseExpr) -parseMemAssign asgn = - do base <- parseVariableReference (asgn^.P.memoryAssignment_base) - let off = asgn^.P.memoryAssignment_offset - val <- parseVariableReference (asgn^.P.memoryAssignment_value) - return $ MemPointsTo base off val - -parseVarBinding :: - P.VariableBinding -> - M (VerificationSetupStep C.Ident ParseExpr) -parseVarBinding bnd = - do var <- parseVariableReference (bnd^.P.variableBinding_var) - let msg = "Variable binding of '" ++ show (PP.pp var) ++ "'" - expr <- parseCryptolExpr msg (bnd^.P.variableBinding_expr) - return $ BindVariable var expr - -parseCondition :: - Phase -> - Text -> - M ParseExpr -parseCondition phase expr = - do let msg = "logical condition of " ++ phaseName phase ++ " phase" - parseCryptolExpr msg expr - -parseCryptolExpr :: - String -> - Text -> - M ParseExpr -parseCryptolExpr nm expr = - case CP.parseExpr expr of - Left parseErr -> fail msg - where - msg = unlines [ "" - , "Parse failure while parsing Cryptol expression in " ++ nm ++ ":" - , " " ++ show expr - , show (CP.ppError parseErr) - ] - Right ex -> return ex - -data Phase = Prestate | Poststate - -phaseName :: Phase -> String -phaseName Prestate = "prestate" -phaseName Poststate = "poststate" - --- | Given verification phase that has been parsed off the wire, we need to --- typecheck the raw Cryptol AST. We first declare all the phase variables --- with their associated types. Then we typecheck the setup steps, and reorder --- them (see reorderSteps). Finally, logical conditions are typechecked. -tcPhase :: - Phase -> - Word64 -> - VerificationPhase C.Ident ParseExpr -> - M (VerificationPhase CT.Name TCExpr) -tcPhase phase addrWidth parsedPhase = - do vars' <- traverse declareVar (phaseVars parsedPhase) - tcSteps <- traverse (tcSetupStep addrWidth) (phaseSetup parsedPhase) - let varSetupSteps = fmap (DeclareFreshVariable . harnessVarIdent) vars' - steps' <- reorderSteps (declaredVarSet phase vars') (varSetupSteps <> tcSteps) - conds' <- traverse tcCond (phaseConds parsedPhase) - return VerificationPhase - { phaseVars = vars' - , phaseSetup = steps' - , phaseConds = conds' - } - - -declaredVarSet :: - Phase -> - Seq (HarnessVarDecl CT.Name) -> - Set CT.Name -declaredVarSet _phase names = foldr insVar mempty names - where - insVar x s = Set.insert (harnessVarIdent x) s - -declareVar :: - HarnessVarDecl C.Ident -> - M (HarnessVarDecl CT.Name) -declareVar (HarnessVarDecl ident harnessTp) = - do let tp = harnessTypeToCryptolType harnessTp - cryenv <- get - let (name, cryenv') = declareIdent ident tp cryenv - put cryenv' - return $ HarnessVarDecl name harnessTp - -tcSetupStep :: - Word64 -> - VerificationSetupStep C.Ident ParseExpr -> - M (VerificationSetupStep CT.Name (CP.Expr CT.Name, TCExpr)) -tcSetupStep _addrWidth (DeclareFreshVariable var) = - do (var', _tp) <- tcVar var - return $ DeclareFreshVariable var' -tcSetupStep addrWidth (BindVariable hvar ex) = - do (hvar', tp) <- tcHarnessVar addrWidth hvar - ex' <- tcExpr ex tp - return $ BindVariable hvar' ex' -tcSetupStep addrWidth (RegisterVal offset hvar) = - do (hvar', _tp) <- tcHarnessVar addrWidth hvar --- FIXME, check type, should have tp == [addrWidth] - return $ RegisterVal offset hvar' -tcSetupStep addrWidth (MemPointsTo base offset val) = - do (base', _baseTp) <- tcHarnessVar addrWidth base - (val' , _valTp) <- tcHarnessVar addrWidth val --- FIXME, check types: --- should have baseTp == [addrWidth] --- valTp... does it need any checks? - return $ MemPointsTo base' offset val' - -addressType :: Word64 -> CT.Type -addressType n = CT.tWord (CT.tNum n) - -tcHarnessVar :: - Word64 -> - HarnessVar C.Ident -> - M (HarnessVar CT.Name, CT.Type) -tcHarnessVar addrWidth var = - case var of - ReturnAddressVar -> - do let tp = addressType addrWidth - return (ReturnAddressVar, tp) - StackPointerVar -> - do let tp = addressType addrWidth - return (StackPointerVar, tp) - CryptolVar ident -> - do (nm,tp) <- tcVar ident - return (CryptolVar nm, tp) - - -tcVar :: - C.Ident -> - M (CT.Name, CT.Type) -tcVar ident = - do (hout,_) <- ask - cryEnv <- get - let nameEnv = eExtraNames cryEnv - let modEnv = eModuleEnv cryEnv - (res, ws) <- io $ MM.runModuleM (defaultEvalOpts, BS.readFile, modEnv) - (MM.interactive (MB.rename C.interactiveName nameEnv (MR.renameVar (CP.mkUnqual ident)))) - unless (null ws) $ io $ - mapM_ (hout . show . PP.pp) ws - case res of - Left err -> fail $ "Cryptol error:\n" ++ show (PP.pp err) - Right (nm, modEnv') -> - case Map.lookup nm (eExtraTypes cryEnv) of - Just (CT.Forall [] [] ty) -> - do put cryEnv{ eModuleEnv = modEnv' } - return (nm, ty) - _ -> - fail ("User harness variable not in scope: " ++ show ident) - -tcExpr :: - ParseExpr -> - CT.Type -> - M (CP.Expr CT.Name, TCExpr) -tcExpr pex tp = - do cryEnv <- get - (cryEnv1, reexpr) <- io $ renameTerm cryEnv pex - (cryEnv2, tcexpr) <- io $ checkTerm cryEnv1 reexpr tp - put cryEnv2 - return (reexpr, (tp,tcexpr)) - - -tcCond :: - ParseExpr -> - M TCExpr -tcCond pex = snd <$> tcExpr pex CT.tBit - - -harnessTypeToCryptolType :: - HarnessVarType -> - CT.Schema -harnessTypeToCryptolType tp = CT.Forall [] [] monotype - where - monotype = case tp of - HarnessVarWord sz -> - CT.tSeq (CT.tNum sz) $ - CT.tBit - HarnessVarArray elems sz -> - CT.tSeq (CT.tNum elems) $ - CT.tSeq (CT.tNum sz) $ - CT.tBit - -resolveSetupVar :: - HarnessVar CT.Name -> - M CT.Name -resolveSetupVar var = - case var of - CryptolVar nm -> return nm - StackPointerVar -> renameIdent (fromString "stack") - ReturnAddressVar -> renameIdent (fromString "return") - - where - renameIdent ident = - do (hout,_) <- ask - cryEnv <- get - let nameEnv = eExtraNames cryEnv - let modEnv = eModuleEnv cryEnv - (res, ws) <- io $ MM.runModuleM (defaultEvalOpts, BS.readFile, modEnv) - (MM.interactive (MB.rename C.interactiveName nameEnv (MR.renameVar (CP.mkUnqual ident)))) - unless (null ws) $ io $ - mapM_ (hout . show . PP.pp) ws - case res of - Left err -> fail $ "Cryptol error:\n" ++ show (PP.pp err) - Right (nm, modEnv') -> - do put cryEnv{ eModuleEnv = modEnv' } - return nm - -setupStepDef :: - VerificationSetupStep CT.Name (CP.Expr CT.Name, TCExpr) -> - M CT.Name -setupStepDef (RegisterVal _ var) = resolveSetupVar var -setupStepDef (MemPointsTo _ _ var) = resolveSetupVar var -setupStepDef (BindVariable var _) = resolveSetupVar var -setupStepDef (DeclareFreshVariable var) = return var - -setupStepUses :: - Set CT.Name -> - VerificationSetupStep CT.Name (CP.Expr CT.Name, TCExpr) -> - M (Set CT.Name) -setupStepUses _ (DeclareFreshVariable _) = return mempty -setupStepUses _ (RegisterVal _ _) = return mempty -setupStepUses declaredNames (MemPointsTo base _ _) = - do basenm <- resolveSetupVar base - return $ if Set.member basenm declaredNames then Set.singleton basenm else mempty -setupStepUses declaredNames (BindVariable _ (ex,_)) = - return . Set.intersection declaredNames . CP.namesE $ ex - - -type GraphEdge = (VerificationSetupStep CT.Name TCExpr, CT.Name, Set CT.Name) - -setupStepGraphEdge :: - Set CT.Name -> - VerificationSetupStep CT.Name (CP.Expr CT.Name, TCExpr) -> - M GraphEdge -setupStepGraphEdge declaredNames step = - do def <- setupStepDef step - us <- setupStepUses declaredNames step - return (fmap snd step, def, us) - - --- | This function reorders verification setps to ensure that, --- whenever possible, variables are defined before they are used --- (which minimizes the creation of fresh variables); and then to --- prefer variable binding statements, then register lookup --- statements, then memory points-to statements for defining the --- values of variables. This generally improves the results of --- symbolic execution by making variable bindings more concrete. --- --- This process works by scanning the verification setup steps in order, --- and selecting the "best" step to perform next, and removing it from the --- list. A verification step can only be performed if all the variables --- it depends on are already defined. This process continues until no more --- steps can be performed. If there are any remaining steps still in the work --- list, this means that some variables have no definition, or are part --- of a cycle of definitions. --- --- If a literal cycle of definitions is actually desired, the front-end should --- introduce a "DeclareFreshVariable" step to break the cycle. -reorderSteps :: - Set CT.Name {- ^ All delcared names in scope -} -> - Seq (VerificationSetupStep CT.Name (CP.Expr CT.Name, TCExpr)) {- ^ setup setups to reorder -} -> - M (Seq (VerificationSetupStep CT.Name TCExpr)) -reorderSteps declaredNames steps = - do grEdges <- mapM (setupStepGraphEdge declaredNames) steps - (definedNames, steps') <- runWriterT (processEdges mempty grEdges) - let undefinedNames = Set.difference declaredNames definedNames - unless (Set.null undefinedNames) - (fail (show (PP.text "The following harness variables were declared, but" - PP.$$ - PP.text "either have no definition, or have cyclic definitions:" - PP.$$ - PP.nest 4 (PP.vcat (map PP.pp (toList undefinedNames)))))) - return steps' - - -processEdges :: - Set CT.Name -> - Seq GraphEdge -> - WriterT (Seq (VerificationSetupStep CT.Name TCExpr)) M (Set CT.Name) -processEdges definedNames edges = go Nothing mempty edges - - where - betterCandidate _ Nothing = True - - -- selecting a value from memory or registers is to be preferred to declaring - -- a fresh symbolic value - betterCandidate (RegisterVal _ _) (Just (DeclareFreshVariable _,_,_)) = True - betterCandidate (MemPointsTo{}) (Just (DeclareFreshVariable _,_,_)) = True - - -- selecting from a register is generally a better way to define a value than - -- selecting from memory - betterCandidate (RegisterVal _ _) (Just (MemPointsTo{},_,_)) = True - - betterCandidate _ _ = False - - - processEdge (step,_,_) = tell (Seq.singleton step) - - maybeSeq Nothing = mempty - maybeSeq (Just x) = Seq.singleton x - - go candidate zs xs = case Seq.viewl xs of - edge@(step,def,us) Seq.:< xs' - -- Drop variable declarations if they declare names that have - -- already been given definitions - | DeclareFreshVariable v <- step - , v `Set.member` definedNames - -> go candidate zs xs' - - -- Immediately select a variable definition step if all the variables - -- it refers to are already defined - | Set.isSubsetOf us definedNames - , BindVariable _ _ <- step - -> do processEdge edge - processEdges (Set.insert def definedNames) (zs <> maybeSeq candidate <> xs') - - -- Tentatively select a non-variable-binding step if all the variables it - -- refers to are already defined - | Set.isSubsetOf us definedNames - , betterCandidate step candidate - -> go (Just edge) (zs <> maybeSeq candidate) xs' - - -- In all other cases, continue searching down the worklist - | otherwise - -> go candidate (zs Seq.|> edge) xs' - - -- We've reached the end of the worklist. Process the candidate edge we tenatively - -- chose earlier, or finish if no candidate was chosen. - Seq.EmptyL -> case candidate of - Just edge@(_,def,_) -> - do processEdge edge - processEdges (Set.insert def definedNames) zs - Nothing -> - do return definedNames diff --git a/crucible-server/src/Lang/Crucible/Server/Verification/Override.hs b/crucible-server/src/Lang/Crucible/Server/Verification/Override.hs deleted file mode 100644 index 53a14d030..000000000 --- a/crucible-server/src/Lang/Crucible/Server/Verification/Override.hs +++ /dev/null @@ -1,923 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ViewPatterns #-} - ------------------------------------------------------------------------ --- | --- Module : Lang.Crucible.Server.Verification.Override --- Copyright : (c) Galois, Inc 2017 --- Maintainer : Rob Dockins --- Stability : provisional --- License : BSD3 --- --- Support for using verification harnesses at call sites in "override" --- mode. ------------------------------------------------------------------------- - -module Lang.Crucible.Server.Verification.Override - ( -- * High-level interface to harness overrides - VerifState - , verifStateRepr - , VerificationOverrideFnHandle - , verifFnRepr - , verificationHarnessOverrideHandle - - -- * Low-level interface - , N - , SAWBack - , Subst - , SubstTerm(..) - , termToSubstTerm - , computeVarTypes - , assertEquiv - , assumeEquiv - , computeVariableSubstitution - , phaseUpdate - , assumeConditions - , assertConditions - , simulateHarness - ) where - -#if !MIN_VERSION_base(4,13,0) -import Control.Monad.Fail( MonadFail ) -#endif - -import Control.Lens (folded) -import Control.Monad -import qualified Control.Monad.Catch as X -import Control.Monad.IO.Class -import Data.Foldable -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as Map -import Data.Sequence (Seq) -import qualified Data.Sequence as Seq -import qualified Data.Text as T -import Data.Word - -import qualified Data.BitVector.Sized as BV -import qualified Data.Parameterized.Context as Ctx -import Data.Parameterized.Some - -import qualified Cryptol.TypeCheck.AST as CT -import qualified Cryptol.Utils.PP as PP - -import What4.Interface -import What4.Expr.Builder (Flags, FloatReal) -import What4.FunctionName -import What4.Partial -import qualified What4.Solver.Yices as Yices -import What4.WordMap - -import Lang.Crucible.Backend -import qualified Lang.Crucible.Backend.SAWCore as SAW -import Lang.Crucible.Types -import Lang.Crucible.FunctionHandle -import Lang.Crucible.Simulator.CallFrame (SomeHandle(..)) -import Lang.Crucible.Simulator.RegMap -import Lang.Crucible.Simulator.OverrideSim -import Lang.Crucible.Simulator.SimError - -import qualified Verifier.SAW.Simulator.SBV as SBV (sbvSolveBasic, toWord) -import qualified Data.SBV.Dynamic as SBV (svAsInteger) - -import Verifier.SAW.Conversion -import Verifier.SAW.Rewriter -import Verifier.SAW.SharedTerm -import Verifier.SAW.TypedAST - -import Lang.Crucible.Server.CryptolEnv -import Lang.Crucible.Server.MultipartOperations -import Lang.Crucible.Server.Simulator ---import Lang.Crucible.Server.TypedTerm -import Lang.Crucible.Server.Verification.Harness - - -type VerifState rw w = - EmptyCtx ::> - BVType w ::> -- PC - WordMapType rw (BaseBVType 8) ::> -- Register file - WordMapType w (BaseBVType 8) -- Memory - - -type VerificationOverrideFnHandle rw w = - FnHandle (VerifState rw w) (StructType (VerifState rw w)) - -verifStateRepr :: (1 <= w, 1 <= rw) => NatRepr rw -> NatRepr w -> CtxRepr (VerifState rw w) -verifStateRepr rw w = Ctx.empty Ctx.:> BVRepr w Ctx.:> WordMapRepr rw knownRepr Ctx.:> WordMapRepr w knownRepr - -verifFnRepr :: (1 <= w, 1 <= rw) => - NatRepr rw -> - NatRepr w -> - TypeRepr (FunctionHandleType (VerifState rw w) (StructType (VerifState rw w))) -verifFnRepr rw w = FunctionHandleRepr (verifStateRepr rw w) (StructRepr (verifStateRepr rw w)) - --- | Given a processed harness, compute a verification override, bind it to --- a fresh function handle, and return that handle. The address bus width --- and register file width are fixed by the given NatReprs. -verificationHarnessOverrideHandle :: - (1 <= w, 1 <= rw) => - Simulator p (SAWBack n) -> - NatRepr rw -> - NatRepr w -> - CryptolEnv -> - ProcessedHarness -> - IO (VerificationOverrideFnHandle rw w) -verificationHarnessOverrideHandle sim rw w cryEnv harness = - do sc <- SAW.sawBackendSharedContext =<< getInterface sim - let nm = functionNameFromText (verificationOverrideName harness) - simOverrideHandle sim (verifStateRepr rw w) (StructRepr (verifStateRepr rw w)) - (mkOverride' nm (StructRepr (verifStateRepr rw w)) - (verificationHarnessOverride sim rw w sc cryEnv harness)) - -type SAWBack n = SAW.SAWCoreBackend n Yices.Connection (Flags FloatReal) -type N p n r args ret a = OverrideSim p (SAWBack n) () r args ret a - ----------------------------------------------------------------------- - -data OverrideFailure where - InvalidReturnType :: String -> TypeRepr want -> TypeRepr got -> OverrideFailure - InvalidArgumentTypes :: String -> CtxRepr args1 -> CtxRepr args2 -> OverrideFailure - BadWidth :: String -> Word64 -> OverrideFailure - NegativeWidth :: String -> Word64 -> OverrideFailure - WidthNotModulo8 :: String -> Word64 -> OverrideFailure - -deriving instance Show OverrideFailure -instance X.Exception OverrideFailure - ----------------------------------------------------------------------- - --- | Define the behavior of a verification override. First, bind the values of all the --- verification harness variables from the prestate. -verificationHarnessOverride :: - (1 <= w, 1 <= rw) => - Simulator p (SAWBack n) -> - NatRepr rw -> - NatRepr w -> - SharedContext -> - CryptolEnv -> - ProcessedHarness -> - N p n r (VerifState rw w) ret (RegValue (SAWBack n) (StructType (VerifState rw w))) -verificationHarnessOverride sim rw w sc cryEnv harness = - do args <- getOverrideArgs - case args of - RegMap (Ctx.Empty Ctx.:> (regValue -> _pc) Ctx.:> (regValue -> regs) Ctx.:> (regValue -> mem)) -> - do let prestateVarTypes = computeVarTypes Prestate harness - let poststateVarTypes = computeVarTypes Poststate harness `Map.union` prestateVarTypes - let endianness = verificationEndianness harness - let sub0 = Map.empty - sym <- getSymInterface - - (sub,cryEnv') <- computeVariableSubstitution sim sym rw w sc endianness cryEnv - prestateVarTypes (verificationPrestate harness) regs mem sub0 - assertConditions sc cryEnv' (verificationPrestate harness) - - (_sub'',cryEnv'',regs',mem') <- phaseUpdate sim sym rw w sc poststateVarTypes endianness - (verificationPoststate harness) (sub,cryEnv',regs,mem) - assumeConditions sc cryEnv'' (verificationPoststate harness) - - pc' <- lookupWord sym w ReturnAddressVar sub - return (Ctx.Empty Ctx.:> RV pc' Ctx.:> RV regs' Ctx.:> RV mem') - - -- _ -> fail "Impossible! failed to deconstruct verification override arguments" - -assertConditions :: - SharedContext -> - CryptolEnv -> - VerificationPhase CT.Name TCExpr -> - N p n r args ret () -assertConditions sc cryEnv phase = - do sym <- getSymInterface - forM_ (toList (phaseConds phase)) $ \(tp, ex) -> liftIO $ - do unless (CT.tIsBit tp) $ fail "Verification harness precondition does not have type 'Bit'" - tm <- translateExpr sc cryEnv ex - x <- SAW.bindSAWTerm sym BaseBoolRepr tm - assert sym x (AssertFailureSimError "Verification override precondition" "") - - -assumeConditions :: - SharedContext -> - CryptolEnv -> - VerificationPhase CT.Name TCExpr -> - N p n r args ret () -assumeConditions sc cryEnv phase = - do sym <- getSymInterface - forM_ (toList (phaseConds phase)) $ \(tp, ex) -> liftIO $ - do unless (CT.tIsBit tp) $ fail "Verification harness postcondition does not have type 'Bit'" - tm <- translateExpr sc cryEnv ex - x <- SAW.bindSAWTerm sym BaseBoolRepr tm - loc <- getCurrentProgramLoc sym - addAssumption sym (LabeledPred x (AssumptionReason loc "Verification postcondition")) - -createFreshHarnessVar :: - SAWBack n -> - HarnessVar CT.Name -> - HarnessVarType -> - IO (SubstTerm (SAWBack n), Term) -createFreshHarnessVar sym var (HarnessVarWord n) = - do Just (Some valSize) <- return (someNat (toInteger n)) - Just LeqProof <- return (isPosNat valSize) - sc <- SAW.sawBackendSharedContext sym - sawtp <- scBitvector sc (fromIntegral n) - let nm = show (PP.pp var) - tm <- SAW.sawCreateVar sym nm sawtp - bv <- SAW.bindSAWTerm sym (BaseBVRepr valSize) tm - return (SubstWord bv, tm) - -createFreshHarnessVar sym var (HarnessVarArray elems n) = - do Just (Some valSize) <- return (someNat (toInteger n)) - Just LeqProof <- return (isPosNat valSize) - sc <- SAW.sawBackendSharedContext sym - elemtp <- scBitvector sc (fromIntegral n) - elems' <- scNat sc (fromIntegral elems) - sawtp <- scVecType sc elems' elemtp - let nm = show (PP.pp var) - tm <- SAW.sawCreateVar sym nm sawtp - tms <- forM [0..elems-1] $ \i -> - do i' <- scNat sc (fromIntegral i) - scAt sc elems' elemtp tm i' - bvs <- mapM (SAW.bindSAWTerm sym (BaseBVRepr valSize)) tms - return (SubstArray valSize (Seq.fromList bvs), tm) - -withValidSize :: X.MonadThrow m => - String -> Word64 - -> (forall x. 1 <= x => NatRepr x -> m a) -> m a -withValidSize nm sz f = - case someNat (toInteger sz) of - Nothing -> X.throwM $ BadWidth nm sz - Just (Some w) -> - case isPosNat w of - Nothing -> X.throwM $ NegativeWidth nm sz - Just LeqProof -> - f w - -phaseUpdate :: forall p n r args ret w rw. - (1 <= w, 1 <= rw) => - Simulator p (SAWBack n) -> - SAWBack n -> - NatRepr rw -> - NatRepr w -> - SharedContext -> - Map (HarnessVar CT.Name) HarnessVarType -> - Endianness -> - VerificationPhase CT.Name TCExpr -> - ( Subst (SAWBack n) - , CryptolEnv - , WordMap (SAWBack n) rw (BaseBVType 8) - , WordMap (SAWBack n) w (BaseBVType 8) - ) -> - N p n r args ret - ( Subst (SAWBack n) - , CryptolEnv - , WordMap (SAWBack n) rw (BaseBVType 8) - , WordMap (SAWBack n) w (BaseBVType 8) - ) -phaseUpdate sim sym rw w sc varTypes endianness phase = \x -> foldM go x (toList (phaseSetup phase)) - where - - updateSub var tm x sub cryEnv regs mem = - do let cryEnv' = case var of - CryptolVar nm -> - cryEnv{ eTermEnv = Map.insert nm tm (eTermEnv cryEnv) } - _ -> cryEnv - let sub' = Map.insert var x sub - return (sub', cryEnv', regs, mem) - - go (sub,cryEnv,regs,mem) step = case step of - DeclareFreshVariable var -> - let hvar = CryptolVar var in - case Map.lookup hvar sub of - Just _ -> - -- If the variable already has a definition, just discard this directive - do return (sub,cryEnv,regs,mem) - Nothing -> - case Map.lookup hvar varTypes of - Just htp -> - do (subTm,tm) <- liftIO $ createFreshHarnessVar sym hvar htp - updateSub hvar tm subTm sub cryEnv regs mem - Nothing -> - fail (show (PP.text "Impossible! Unknown type for variable: " PP.<+> PP.pp var)) - - BindVariable var (_tp,ex) -> - case Map.lookup var varTypes of - Just htp -> - do tm <- liftIO $ translateExpr sc cryEnv ex - x <- termToSubstTerm sym sc htp tm - case Map.lookup var sub of - Nothing -> - do updateSub var tm x sub cryEnv regs mem - Just tm' -> - do assumeEquiv sym htp tm tm' - return (sub, cryEnv, regs, mem) - Nothing -> - fail (show (PP.text "Impossible! Unknown type for variable: " PP.<+> PP.pp var)) - - RegisterVal offset var -> - case Map.lookup var varTypes of - Just (HarnessVarWord n) -> - withValidSize (show $ PP.pp var) n $ \valSize -> do - case Map.lookup var sub of - Just substTm -> - do bv <- substTermAsBV sym valSize substTm - regs' <- writeReg sim rw offset n endianness (SomeBV bv) regs - return (sub,cryEnv,regs',mem) - Nothing -> - do (substTm, tm) <- liftIO $ createFreshHarnessVar sym var (HarnessVarWord n) - bv <- substTermAsBV sym valSize substTm - regs' <- writeReg sim rw offset n endianness (SomeBV bv) regs - updateSub var tm substTm sub cryEnv regs' mem - - Just (HarnessVarArray _ _ ) -> - fail (show (PP.text "Cannot write array types to registers for variable: " PP.<+> PP.pp var)) - Nothing -> - fail (show (PP.text "Impossible! Unknown type for variable: " PP.<+> PP.pp var)) - - MemPointsTo base offset val -> - case Map.lookup base sub of - Just basetm -> - case Map.lookup val varTypes of - Just (HarnessVarWord n) -> - do baseAddr <- substTermAsBV sym w basetm - off <- liftIO $ bvLit sym w (BV.trunc' w (BV.word64 offset)) - addr <- liftIO (bvAdd sym baseAddr off) - withValidSize ("MemPointsTo word " <> (show $ PP.pp val)) n $ \x -> - case Map.lookup val sub of - Just valtm -> - do bv <- substTermAsBV sym x valtm - mem' <- writeMap sim w addr n endianness (SomeBV bv) mem - return (sub,cryEnv,regs,mem') - Nothing -> - do (valtm, tm) <- liftIO $ createFreshHarnessVar sym val (HarnessVarWord n) - bv <- substTermAsBV sym x valtm - mem' <- writeMap sim w addr n endianness (SomeBV bv) mem - updateSub val tm valtm sub cryEnv regs mem' - - Just (HarnessVarArray elems n) -> - do baseAddr <- substTermAsBV sym w basetm - off <- liftIO $ bvLit sym w (BV.trunc' w (BV.word64 offset)) - addr <- liftIO (bvAdd sym baseAddr off) - withValidSize ("MemPointsTo array " <> (show $ PP.pp val)) n $ \x -> - case Map.lookup val sub of - Just valtm -> - do mem' <- writeArray sim sym w addr endianness elems n x valtm mem - return (sub,cryEnv,regs,mem') - Nothing -> - do (valtm, tm) <- liftIO $ createFreshHarnessVar sym val (HarnessVarArray elems n) - mem' <- writeArray sim sym w addr endianness elems n x valtm mem - updateSub val tm valtm sub cryEnv regs mem' - - Nothing -> - fail (show (PP.text "Impossible! Unknown type for variable: " PP.<+> PP.pp val)) - Nothing -> - fail (show (PP.text "Base pointer not defined" PP.<+> PP.pp base)) - -substTermAsArray :: - (MonadIO m, MonadFail m, 1 <= x) => - SAWBack n -> - Word64 -> - NatRepr x -> - SubstTerm (SAWBack n) -> - m (Seq (SymBV (SAWBack n) x)) -substTermAsArray _sym elems x (SubstArray x' vs) - | Just Refl <- testEquality x x' - , Seq.length vs == fromIntegral elems - = return vs - -substTermAsArray sym elems x (SubstTerm tm) - = liftIO $ - do sc <- SAW.sawBackendSharedContext sym - elemtp <- scBitvector sc (fromIntegral (natValue x)) - elems' <- scNat sc (fromIntegral elems) - tms <- forM [0..elems-1] $ \i -> - do i' <- scNat sc (fromIntegral i) - v <- scAt sc elems' elemtp tm i' - SAW.bindSAWTerm sym (BaseBVRepr x) v - return (Seq.fromList tms) - -substTermAsArray _sym _elems _x _ - = fail "Expected array value" - -readArray :: - (1 <= w, 1 <= x) => - Simulator p (SAWBack n) -> - SAWBack n -> - NatRepr w -> - SymBV (SAWBack n) w -> - Endianness -> - Word64 -> - Word64 -> - NatRepr x -> - WordMap (SAWBack n) w (BaseBVType 8) -> - N p n r args ret (Seq (SymBV (SAWBack n) x)) -readArray sim sym w addr endianness elems n x mem = - Seq.fromList <$> (forM [ 0 .. elems-1 ] $ \i -> - do off <- liftIO $ bvLit sym w (BV.trunc' w (BV.word64 (i * (n `div` 8)))) - addr' <- liftIO $ bvAdd sym addr off - SomeBV v <- readMap sim w addr' n endianness mem - case testEquality (bvWidth v) x of - Just Refl -> return v - Nothing -> fail "Size mismatch in readArray") - - -writeArray :: - (1 <= w, 1 <= x) => - Simulator p (SAWBack n) -> - SAWBack n -> - NatRepr w -> - SymBV (SAWBack n) w -> - Endianness -> - Word64 -> - Word64 -> - NatRepr x -> - SubstTerm (SAWBack n) -> - WordMap (SAWBack n) w (BaseBVType 8) -> - N p n r args ret (WordMap (SAWBack n) w (BaseBVType 8)) -writeArray sim sym w addr endianness elems n x val mem0 = - do vals <- substTermAsArray sym elems x val - foldM - (\mem (i,v) -> - do off <- liftIO $ bvLit sym w (BV.trunc' w (BV.word64 (i * (n `div` 8)))) - addr' <- liftIO $ bvAdd sym addr off - liftIO (sendTextResponse sim (T.pack ("WriteArray: " ++ show (printSymExpr addr')))) - writeMap sim w addr' n endianness (SomeBV v) mem - ) - mem0 - (zip [ 0 .. (elems-1) ] (toList vals)) - - - -lookupWord :: - (1 <= w) => - SAWBack n -> - NatRepr w -> - HarnessVar CT.Name -> - Subst (SAWBack n) -> - N p n r args ret (SymBV (SAWBack n) w) -lookupWord sym w var sub = - case Map.lookup var sub of - Just subtm -> substTermAsBV sym w subtm - Nothing -> fail (show (PP.text "Undefined variable" PP.<+> PP.pp var)) - -computeVarTypes :: - Phase -> - ProcessedHarness -> - Map (HarnessVar CT.Name) HarnessVarType -computeVarTypes ph harness = Map.fromList pairs - - where - pairs = (ReturnAddressVar, addrType) : (StackPointerVar, addrType) : map f (toList decls) - addrType = HarnessVarWord (verificationAddressWidth harness) - f x = (CryptolVar (harnessVarIdent x), harnessVarType x) - decls = phaseVars phase - phase = case ph of - Prestate -> verificationPrestate harness - Poststate -> verificationPoststate harness - - -type Subst sym = Map (HarnessVar CT.Name) (SubstTerm sym) - -data SubstTerm sym where - SubstTerm :: Term -> SubstTerm sym - SubstWord :: (1 <= w) => SymExpr sym (BaseBVType w) -> SubstTerm sym - SubstArray :: (1 <= w) => NatRepr w -> Seq (SymExpr sym (BaseBVType w)) -> SubstTerm sym - -computeVariableSubstitution :: forall p n r args ret w rw. - (1 <= rw, 1 <= w) => - Simulator p (SAWBack n) -> - SAWBack n -> - NatRepr rw -> - NatRepr w -> - SharedContext -> - Endianness -> - CryptolEnv -> - Map (HarnessVar CT.Name) HarnessVarType -> - VerificationPhase CT.Name TCExpr -> - WordMap (SAWBack n) rw (BaseBVType 8) -> - WordMap (SAWBack n) w (BaseBVType 8) -> - Subst (SAWBack n) -> - N p n r args ret (Subst (SAWBack n), CryptolEnv) -computeVariableSubstitution sim sym rw w sc endianness cryEnv0 varTypes phase regs mem sub0 = - foldM go (sub0, cryEnv0) (toList (phaseSetup phase)) - - where - updateSub var tm x sub cryEnv = - do let cryEnv' = case var of - CryptolVar nm -> - cryEnv{ eTermEnv = Map.insert nm tm (eTermEnv cryEnv) } - _ -> cryEnv - let sub' = Map.insert var x sub - return (sub', cryEnv') - - go (sub, cryEnv) step = case step of - DeclareFreshVariable var -> - let hvar = CryptolVar var in - case Map.lookup hvar sub of - Just _ -> return (sub,cryEnv) - Nothing -> - case Map.lookup hvar varTypes of - Just htp -> - do (subTm, tm) <- liftIO $ createFreshHarnessVar sym hvar htp - updateSub hvar tm subTm sub cryEnv - Nothing -> - fail (show (PP.text "Impossible! Unknown type for variable: " PP.<+> PP.pp var)) - - BindVariable var (_tp,ex) -> - case Map.lookup var varTypes of - Just htp -> - do tm <- liftIO $ translateExpr sc cryEnv ex - x <- termToSubstTerm sym sc htp tm - case Map.lookup var sub of - Nothing -> - do updateSub var tm x sub cryEnv - Just tm' -> - do assertEquiv sym htp tm tm' - return (sub, cryEnv) - Nothing -> - fail (show (PP.text "Impossible! Unknown type for variable: " PP.<+> PP.pp var)) - - RegisterVal off var -> - case Map.lookup var varTypes of - Just (HarnessVarWord n) -> - do SomeBV x <- readReg sim rw off n endianness regs - tm <- liftIO $ SAW.toSC sym x - case Map.lookup var sub of - Nothing -> - do updateSub var tm (SubstWord x) sub cryEnv - Just tm' -> - do assertEquiv sym (HarnessVarWord n) tm tm' - return (sub,cryEnv) - - Just (HarnessVarArray _ _ ) -> - fail (show (PP.text "Cannot read array types from registers for variable: " PP.<+> PP.pp var)) - Nothing -> - fail (show (PP.text "Impossible! Unknown type for variable: " PP.<+> PP.pp var)) - - MemPointsTo base offset var -> - case Map.lookup var varTypes of - Just (HarnessVarWord n) -> - do -- FIXME check that base is actually a address pointer - case Map.lookup base sub of - Just basetm -> - do baseAddr <- substTermAsBV sym w basetm - off <- liftIO $ bvLit sym w (BV.trunc' w (BV.word64 offset)) - addr <- liftIO (bvAdd sym baseAddr off) - SomeBV x <- readMap sim w addr n endianness mem - tm <- liftIO $ SAW.toSC sym x - case Map.lookup var sub of - Nothing -> - do updateSub var tm (SubstWord x) sub cryEnv - Just tm' -> - do assertEquiv sym (HarnessVarWord n) tm tm' - return (sub,cryEnv) - - Nothing -> - fail (show (PP.text "Base pointer not defined" - PP.<+> PP.pp base)) - - Just (HarnessVarArray elems n) -> - case Map.lookup base sub of - Just basetm -> - do baseAddr <- substTermAsBV sym w basetm - off <- liftIO $ bvLit sym w (BV.trunc' w (BV.word64 offset)) - addr <- liftIO (bvAdd sym baseAddr off) - withValidSize ("MemPointsTo array.2 " <> (show $ PP.pp base)) n $ \valSize -> do - vals <- readArray sim sym w addr endianness elems n valSize mem - tm <- liftIO $ arrayAsTerm sym n vals - case Map.lookup var sub of - Nothing -> - updateSub var tm (SubstArray valSize vals) sub cryEnv - Just tm' -> - do assertEquiv sym (HarnessVarArray elems n) tm tm' - return (sub,cryEnv) - - Nothing -> - fail (show (PP.text "Base pointer not defined" - PP.<+> PP.pp base)) - - Nothing -> - fail (show (PP.text "Impossible! Unknown type for variable: " PP.<+> PP.pp var)) - -arrayAsTerm :: - SAWBack n -> - Word64 -> - Seq (SymBV (SAWBack n) x) -> - IO Term -arrayAsTerm sym n vals = - do sc <- SAW.sawBackendSharedContext sym - elemtp <- scBitvector sc (fromIntegral n) - scVector sc elemtp =<< mapM (SAW.toSC sym) (toList vals) - -termToSubstTerm :: - SAWBack n -> - SharedContext -> - HarnessVarType -> - Term -> - N p n r args ret (SubstTerm (SAWBack n)) -termToSubstTerm sym sc (HarnessVarWord n) tm = - do x <- liftIO $ termAsConcrete sc tm - case x of - Just i -> withValidSize "substTerm" n $ \w -> do - bv <- liftIO $ bvLit sym w (BV.mkBV w i) - return (SubstWord bv) - Nothing -> return (SubstTerm tm) - --- FIXME? try to extract concrete values? -termToSubstTerm _ _ (HarnessVarArray _ _) tm = return (SubstTerm tm) - - -substTermAsBV :: - (1 <= x, MonadIO m, MonadFail m) => - SAWBack n -> - NatRepr x -> - SubstTerm (SAWBack n) -> - m (SymBV (SAWBack n) x) -substTermAsBV sym w (SubstTerm tm) = - do liftIO $ SAW.bindSAWTerm sym (BaseBVRepr w) tm -substTermAsBV _sym w (SubstWord x) = - case testEquality w (bvWidth x) of - Just Refl -> return x - Nothing -> fail ("BV width mismatch " ++ show (w,bvWidth x)) -substTermAsBV _sym _w (SubstArray _ _) = - fail "Expected a bitvector term, but got an array" - --- Try to render the given SAWCore term, assumed to represent --- a bitvector, as a concrete value. -termAsConcrete :: - SharedContext -> - Term -> - IO (Maybe Integer) -termAsConcrete sc tm = - do ss <- basic_ss sc - tm' <- rewriteSharedTerm sc ss tm - case getAllExts tm' of - [] -> do sbv <- SBV.toWord =<< SBV.sbvSolveBasic sc Map.empty mempty tm' - return (SBV.svAsInteger sbv) - _ -> return Nothing - -defRewrites :: SharedContext -> Ident -> IO [RewriteRule] -defRewrites sc ident = - do mdef <- scFindDef sc ident - case mdef of - Nothing -> return [] - Just def -> scDefRewriteRules sc def - -basic_ss :: SharedContext -> IO Simpset -basic_ss sc = do - rs1 <- concat <$> traverse (defRewrites sc) (defs ++ defs') - rs2 <- scEqsRewriteRules sc eqs - return $ addConvs procs (addRules (rs1 ++ rs2) emptySimpset) - where - eqs = map (mkIdent preludeName) - [ "not_not", "bvAddZeroL", "bvAddZeroR", "ite_eq" - , "and_True1", "and_True2", "and_False1", "and_False2", "and_idem" - , "or_triv1", "and_triv1", "or_triv2", "and_triv2" - ] - defs = map (mkIdent preludeName) - [ "not", "and", "or", "xor", "boolEq", "ite", "addNat", "mulNat" - , "compareNat", "equalNat" - , "bitvector" - ] - defs' = map (mkIdent (mkModuleName ["Cryptol"])) - ["seq", "ecEq", "ecNotEq"] - procs = [tupleConversion, recordConversion] ++ - bvConversions ++ natConversions ++ vecConversions - - -readReg :: - (1 <= rw) => - Simulator p (SAWBack n) -> - NatRepr rw -> - Offset -> - Word64 -> - Endianness -> - WordMap (SAWBack n) rw (BaseBVType 8) -> - N p n r args ret (SomeBV (SAWBack n)) -readReg sim rw offset size endianness regs = - do sym <- getSymInterface - addr <- liftIO $ bvLit sym rw (BV.trunc' rw (BV.word64 offset)) - readMap sim rw addr size endianness regs - -writeReg :: - (1 <= rw) => - Simulator p (SAWBack n) -> - NatRepr rw -> - Offset -> - Word64 -> - Endianness -> - SomeBV (SAWBack n) -> - WordMap (SAWBack n) rw (BaseBVType 8) -> - N p n r args ret (WordMap (SAWBack n) rw (BaseBVType 8)) -writeReg sim rw offset size endianness val regs = - do sym <- getSymInterface - addr <- liftIO $ bvLit sym rw (BV.trunc' rw (BV.word64 offset)) - writeMap sim rw addr size endianness val regs - -writeMap :: - (1 <= x) => - Simulator p (SAWBack n) -> - NatRepr x -> - SymBV (SAWBack n) x -> - Word64 -> - Endianness -> - SomeBV (SAWBack n) -> - WordMap (SAWBack n) x (BaseBVType 8) -> - N p n r args ret (WordMap (SAWBack n) x (BaseBVType 8)) -writeMap sim x addr size endianness (SomeBV val) wordmap - | r == 0 - , Just (Some valWidth) <- (someNat (toInteger size)) - , cond1 <- testEquality valWidth (bvWidth val) - , Just Refl <- cond1 - , Just LeqProof <- (isPosNat valWidth) - = do sym <- getSymInterface - SomeHandle h <- liftIO $ - getPredefinedHandle sim (MultiPartStoreHandle (fromIntegral (natValue x)) 8 (fromIntegral bytes)) $ - SomeHandle <$> multipartStoreFn sim x (knownRepr :: NatRepr 8) valWidth (fromIntegral bytes) - let argsTy = (Ctx.Empty Ctx.:> - BoolRepr Ctx.:> - BVRepr x Ctx.:> - BVRepr valWidth Ctx.:> retTy) - retTy = WordMapRepr x (BaseBVRepr (knownRepr :: NatRepr 8)) - case testEquality (handleArgTypes h) argsTy of - Just Refl -> - case testEquality (handleReturnType h) retTy of - Just Refl -> do - let endianBool = case endianness of - BigEndian -> truePred sym - LittleEndian -> falsePred sym - let args = Ctx.Empty Ctx.:> RegEntry knownRepr endianBool - Ctx.:> RegEntry (BVRepr x) addr - Ctx.:> RegEntry (BVRepr valWidth) val - Ctx.:> RegEntry (WordMapRepr x (BaseBVRepr knownRepr)) wordmap - regValue <$> callFnVal (HandleFnVal h) (RegMap args) - Nothing -> X.throwM $ InvalidReturnType opstr retTy (handleReturnType h) - Nothing -> X.throwM $ InvalidArgumentTypes opstr argsTy (handleArgTypes h) - | otherwise = fail ("Invalid arguments to writeMap") - where - (bytes,r) = divMod size 8 - opstr = "writeMap " <> show size <> "@" <> show addr - - -readMap :: - (1 <= x) => - Simulator p (SAWBack n) -> - NatRepr x -> - SymBV (SAWBack n) x -> - Word64 -> - Endianness -> - WordMap (SAWBack n) x (BaseBVType 8) -> - N p n r args ret (SomeBV (SAWBack n)) -readMap sim x addr size endianness wordmap - | r == 0 = - case someNat (toInteger size) of - Nothing -> X.throwM $ BadWidth opstr size - Just (Some valWidth) -> do - case isPosNat valWidth of - Nothing -> X.throwM $ NegativeWidth opstr size - Just LeqProof -> do - SomeHandle h <- - liftIO $ getPredefinedHandle sim - (MultiPartLoadHandle (fromIntegral (natValue x)) - 8 (fromIntegral bytes)) $ - SomeHandle <$> (multipartLoadFn sim x - (knownRepr :: NatRepr 8) - valWidth (fromIntegral bytes)) - let argsTy = Ctx.Empty Ctx.:> - BoolRepr Ctx.:> - BVRepr x Ctx.:> - WordMapRepr x (BaseBVRepr (knownRepr :: NatRepr 8)) Ctx.:> - MaybeRepr (BVRepr (knownRepr :: NatRepr 8)) - retTy = BVRepr valWidth - case testEquality (handleArgTypes h) argsTy of - Nothing -> X.throwM $ InvalidArgumentTypes opstr argsTy (handleArgTypes h) - Just Refl -> - case testEquality (handleReturnType h) retTy of - Nothing -> X.throwM $ InvalidReturnType opstr retTy (handleReturnType h) - Just Refl -> do - sym <- getSymInterface - let endianBool = case endianness of - BigEndian -> truePred sym - LittleEndian -> falsePred sym - let args = Ctx.Empty Ctx.:> RegEntry knownRepr endianBool - Ctx.:> RegEntry (BVRepr x) addr - Ctx.:> RegEntry (WordMapRepr x (BaseBVRepr knownRepr)) wordmap - Ctx.:> RegEntry (MaybeRepr (BVRepr knownRepr)) Unassigned - SomeBV . regValue <$> callFnVal (HandleFnVal h) (RegMap args) - | otherwise = X.throwM $ WidthNotModulo8 opstr size - where - (bytes,r) = divMod size 8 - opstr = "readMap " <> show size <> "@" <> show addr - - -data SomeBV sym where - SomeBV :: forall sym w. (1 <= w) => SymExpr sym (BaseBVType w) -> SomeBV sym - - -assumeEquiv :: - (MonadIO m, MonadFail m) => - SAWBack n -> - HarnessVarType -> - Term -> - SubstTerm (SAWBack n) -> - m () -assumeEquiv sym hvt tm subTm = - case hvt of - HarnessVarWord n - | Just (Some w) <- someNat (toInteger n) - , Just LeqProof <- isPosNat w - -> do tm' <- liftIO $ SAW.bindSAWTerm sym (BaseBVRepr w) tm - subTm' <- substTermAsBV sym w subTm - eq <- liftIO $ bvEq sym tm' subTm' - loc <- liftIO $ getCurrentProgramLoc sym - liftIO $ addAssumption sym (LabeledPred eq (AssumptionReason loc "Equality condition")) - | otherwise -> fail ("Invalid word width in assumeEquiv" ++ show n) - - HarnessVarArray elems n - | Just (Some w) <- someNat (toInteger n) - , Just LeqProof <- isPosNat w - -> do vals <- substTermAsArray sym elems w (SubstTerm tm) - vals' <- substTermAsArray sym elems w subTm - eq <- liftIO (andAllOf sym folded =<< - zipWithM (\v v' -> bvEq sym v v') (toList vals) (toList vals')) - loc <- liftIO $ getCurrentProgramLoc sym - liftIO $ addAssumption sym (LabeledPred eq (AssumptionReason loc "Equality condition")) - | otherwise -> fail ("Invalid word width in assumeEquiv" ++ show n) - -assertEquiv :: - (MonadIO m, MonadFail m) => - SAWBack n -> - HarnessVarType -> - Term -> - SubstTerm (SAWBack n) -> - m () -assertEquiv sym hvt tm subTm = - case hvt of - HarnessVarWord n - | Just (Some w) <- someNat (toInteger n) - , Just LeqProof <- isPosNat w - -> do tm' <- liftIO $ SAW.bindSAWTerm sym (BaseBVRepr w) tm - subTm' <- substTermAsBV sym w subTm - eq <- liftIO $ bvEq sym tm' subTm' - liftIO $ assert sym eq (AssertFailureSimError "Equality condition failed" "") - | otherwise -> fail ("Invalid word width in assertEquiv" ++ show n) - - HarnessVarArray elems n - | Just (Some w) <- someNat (toInteger n) - , Just LeqProof <- isPosNat w - -> do vals <- substTermAsArray sym elems w (SubstTerm tm) - vals' <- substTermAsArray sym elems w subTm - eq <- liftIO (andAllOf sym folded =<< - zipWithM (\v v' -> bvEq sym v v') (toList vals) (toList vals')) - liftIO $ assert sym eq (AssertFailureSimError "Equality condition failed" "") - | otherwise -> fail ("Invalid word width in assertEquiv" ++ show n) - -simulateHarness :: - (1 <= w, 1 <= rw) => - Simulator p (SAWBack n) -> - NatRepr rw -> - NatRepr w -> - SharedContext -> - CryptolEnv -> - ProcessedHarness -> - SymBV (SAWBack n) w {- ^ PC -} -> - SymBV (SAWBack n) w {- ^ Stack pointer -} -> - SymBV (SAWBack n) w {- ^ Return address -} -> - FnVal (SAWBack n) (VerifState rw w) (StructType (VerifState rw w)) -> - OverrideSim p (SAWBack n) () r args ret () -simulateHarness sim rw w sc cryEnv harness pc stack ret fn = - do sym <- liftIO $ getInterface sim - let prestateVarTypes = computeVarTypes Prestate harness - let poststateVarTypes = computeVarTypes Poststate harness `Map.union` prestateVarTypes - let endianness = verificationEndianness harness - let sub0 = Map.fromList - [ (StackPointerVar, SubstWord stack) - , (ReturnAddressVar, SubstWord ret) - ] - regs0 <- liftIO $ emptyWordMap sym rw knownRepr - mem0 <- liftIO $ emptyWordMap sym w knownRepr - (sub, cryEnv', regs, mem) <- phaseUpdate sim sym rw w sc prestateVarTypes endianness - (verificationPrestate harness) (sub0,cryEnv,regs0,mem0) - assumeConditions sc cryEnv' (verificationPrestate harness) - - - res <- callFnVal' fn (Ctx.Empty Ctx.:> RV pc Ctx.:> RV regs Ctx.:> RV mem) - - case res of - Ctx.Empty Ctx.:> RV _pc' Ctx.:> RV regs' Ctx.:> RV mem' -> - do (_sub', cryEnv'') <- computeVariableSubstitution sim sym rw w sc endianness cryEnv' - poststateVarTypes (verificationPoststate harness) regs' mem' sub - - assertConditions sc cryEnv'' (verificationPoststate harness) - - -- FIXME, ugh, it's annoying to deal with this... - --traverse (\x -> liftIO $ translateExpr sc cryEnv'' (snd x)) (verificationOutput harness) - -#if !MIN_VERSION_GLASGOW_HASKELL(8,10,0,0) - _ -> fail "Impossible! failed to deconstruct verification result!" -#endif diff --git a/scripts/stack-test-coverage.sh b/scripts/stack-test-coverage.sh index 8dc6b5efa..0dfdc993b 100755 --- a/scripts/stack-test-coverage.sh +++ b/scripts/stack-test-coverage.sh @@ -12,5 +12,5 @@ stack test --coverage stack hpc report \ crucible crucible-syntax crux-llvm \ crucible-jvm crucible-llvm crucible-saw \ - crucible-server crux what4 \ + crux what4 \ what4-abc what4-blt