From 2ea54c5b129cbcced45bd62819c6303ff9f8eb2c Mon Sep 17 00:00:00 2001
From: Langston Barrett <langston.barrett@gmail.com>
Date: Fri, 27 Sep 2019 09:46:21 -0700
Subject: [PATCH] More typechecking for ghost variables

---
 src/SAWScript/Crucible/JVM/Override.hs      |  1 +
 src/SAWScript/Crucible/LLVM/MethodSpecIR.hs | 10 +++++++++-
 src/SAWScript/Crucible/LLVM/Override.hs     |  7 +++++++
 3 files changed, 17 insertions(+), 1 deletion(-)

diff --git a/src/SAWScript/Crucible/JVM/Override.hs b/src/SAWScript/Crucible/JVM/Override.hs
index aae17ff2cd..d1336a6494 100644
--- a/src/SAWScript/Crucible/JVM/Override.hs
+++ b/src/SAWScript/Crucible/JVM/Override.hs
@@ -616,6 +616,7 @@ valueToSC _sym loc failMsg _tval _val =
 
 ------------------------------------------------------------------------
 
+-- | NOTE: The two 'Term' arguments must have the same type.
 matchTerm ::
   SharedContext   {- ^ context for constructing SAW terms    -} ->
   JVMCrucibleContext {- ^ context for interacting with Crucible -} ->
diff --git a/src/SAWScript/Crucible/LLVM/MethodSpecIR.hs b/src/SAWScript/Crucible/LLVM/MethodSpecIR.hs
index 4c43a02431..da8e9079f9 100644
--- a/src/SAWScript/Crucible/LLVM/MethodSpecIR.hs
+++ b/src/SAWScript/Crucible/LLVM/MethodSpecIR.hs
@@ -32,6 +32,7 @@ Stability   : provisional
 module SAWScript.Crucible.LLVM.MethodSpecIR where
 
 import           Control.Lens
+import           Control.Monad (when)
 import           Data.Functor.Compose (Compose(..))
 import           Data.IORef
 import           Data.Monoid ((<>))
@@ -41,6 +42,8 @@ import qualified Text.LLVM.PP as L
 import qualified Text.PrettyPrint.ANSI.Leijen as PPL hiding ((<$>), (<>))
 import qualified Text.PrettyPrint.HughesPJ as PP
 
+import qualified Cryptol.Utils.PP as Cryptol (pp)
+
 import           Data.Parameterized.All (All(All))
 import           Data.Parameterized.Some (Some(Some))
 import qualified Data.Parameterized.Map as MapF
@@ -185,7 +188,12 @@ showLLVMModule (LLVMModule name m _) =
 instance Crucible.IntrinsicClass (Crucible.SAWCoreBackend n solver (B.Flags B.FloatReal)) MS.GhostValue where
   type Intrinsic (Crucible.SAWCoreBackend n solver (B.Flags B.FloatReal)) MS.GhostValue ctx = TypedTerm
   muxIntrinsic sym _ _namerep _ctx prd thn els =
-    do st <- readIORef (B.sbStateManager sym)
+    do when (ttSchema thn /= ttSchema els) $ fail $ unlines $
+         [ "Attempted to mux ghost variables of different types:"
+         , show (Cryptol.pp (ttSchema thn))
+         , show (Cryptol.pp (ttSchema els))
+         ]
+       st <- readIORef (B.sbStateManager sym)
        let sc  = Crucible.saw_ctx st
        prd' <- Crucible.toSC sym prd
        typ  <- scTypeOf sc (ttTerm thn)
diff --git a/src/SAWScript/Crucible/LLVM/Override.hs b/src/SAWScript/Crucible/LLVM/Override.hs
index 306a46a215..778c1db0ab 100644
--- a/src/SAWScript/Crucible/LLVM/Override.hs
+++ b/src/SAWScript/Crucible/LLVM/Override.hs
@@ -66,6 +66,7 @@ import qualified Text.LLVM.AST as L
 
 import qualified Cryptol.TypeCheck.AST as Cryptol (Schema(..))
 import qualified Cryptol.Eval.Type as Cryptol (TValue(..), evalType)
+import qualified Cryptol.Utils.PP as Cryptol (pp)
 
 import qualified Lang.Crucible.Backend as Crucible
 import qualified Lang.Crucible.Backend.SAWCore as Crucible
@@ -1025,6 +1026,7 @@ typeToSC sc t =
 
 ------------------------------------------------------------------------
 
+-- | NOTE: The two 'Term' arguments must have the same type.
 matchTerm ::
   SharedContext   {- ^ context for constructing SAW terms    -} ->
   LLVMCrucibleContext arch {- ^ context for interacting with Crucible -} ->
@@ -1086,6 +1088,11 @@ learnGhost ::
   OverrideMatcher (LLVM arch) md ()
 learnGhost sc cc loc prepost var expected =
   do actual <- readGlobal var
+     when (ttSchema actual /= ttSchema expected) $ fail $ unlines $
+       [ "Ghost variable had the wrong type:"
+       , "- Expected: " ++ show (Cryptol.pp (ttSchema expected))
+       , "- Actual:   " ++ show (Cryptol.pp (ttSchema actual))
+       ]
      matchTerm sc cc loc prepost (ttTerm actual) (ttTerm expected)
 
 ------------------------------------------------------------------------