mirror of
https://github.com/GaloisInc/macaw.git
synced 2024-12-29 00:59:09 +03:00
Merge branch 'master' of github.com:GaloisInc/macaw into HEAD
This commit is contained in:
Tristan Ravitch
commit
bd686c3c2e
@ -42,7 +42,7 @@ install:
|
||||
script:
|
||||
- travis_wait stack --no-terminal --skip-ghc-check setup
|
||||
- cd x86/tests
|
||||
- stack build macaw-x86
|
||||
- stack build macaw-x86 macaw-x86-symbolic
|
||||
- stack test macaw-x86
|
||||
- cd ../..
|
||||
# - cabal check
|
||||
|
||||
@ -132,6 +132,7 @@ addUpperBound v u bnds
|
||||
BVValue _ c | c <= u -> Right bnds
|
||||
| otherwise -> Left "Constant given upper bound that is statically less than given bounds"
|
||||
RelocatableValue{} -> Left "Relocatable value does not have upper bounds."
|
||||
SymbolValue{} -> Left "Symbol value does not have upper bounds."
|
||||
AssignedValue a ->
|
||||
case assignRhs a of
|
||||
EvalApp (UExt x _) -> addUpperBound x u bnds
|
||||
|
||||
@ -42,9 +42,10 @@ refineProcState :: RefineConstraints arch
|
||||
-> AbsValue (ArchAddrWidth arch) tp -- ^ Abstract value to assign value.
|
||||
-> AbsProcessorState (ArchReg arch) ids
|
||||
-> AbsProcessorState (ArchReg arch) ids
|
||||
refineProcState (BoolValue _) _av regs = regs -- Skip refinment for literal values
|
||||
refineProcState (BVValue _n _val) _av regs = regs -- Skip refinment for literal values
|
||||
refineProcState (RelocatableValue _ _) _av regs = regs -- Skip refinment for relocatable values
|
||||
refineProcState (BoolValue _) _av regs = regs -- Skip refinement for literal values
|
||||
refineProcState (BVValue _n _val) _av regs = regs -- Skip refinement for literal values
|
||||
refineProcState (RelocatableValue _ _) _av regs = regs -- Skip refinement for relocatable values
|
||||
refineProcState (SymbolValue _ _) _av regs = regs -- Skip refinement for this case.
|
||||
refineProcState (Initial r) av regs =
|
||||
regs & (absInitialRegs . boundValue r) %~ flip meet av
|
||||
refineProcState (AssignedValue (Assignment a_id rhs)) av regs
|
||||
|
||||
@ -30,7 +30,6 @@ import Data.Parameterized.Map (MapF)
|
||||
import qualified Data.Parameterized.Map as MapF
|
||||
import Data.Parameterized.NatRepr
|
||||
import Data.Parameterized.Nonce
|
||||
import Data.Parameterized.Some
|
||||
import Data.Parameterized.TraversableFC
|
||||
import Data.STRef
|
||||
|
||||
|
||||
@ -144,6 +144,7 @@ import GHC.TypeLits
|
||||
import Numeric (showHex)
|
||||
import Text.PrettyPrint.ANSI.Leijen hiding ((<$>), (<>))
|
||||
|
||||
import Data.Parameterized.Classes
|
||||
import Data.Parameterized.NatRepr
|
||||
|
||||
import qualified Data.Macaw.Memory.Permissions as Perm
|
||||
@ -158,6 +159,17 @@ data AddrWidthRepr w
|
||||
| (w ~ 64) => Addr64
|
||||
-- ^ A 64-bit address
|
||||
|
||||
instance TestEquality AddrWidthRepr where
|
||||
testEquality Addr32 Addr32 = Just Refl
|
||||
testEquality Addr64 Addr64 = Just Refl
|
||||
testEquality _ _ = Nothing
|
||||
|
||||
instance OrdF AddrWidthRepr where
|
||||
compareF Addr32 Addr32 = EQF
|
||||
compareF Addr32 Addr64 = LTF
|
||||
compareF Addr64 Addr32 = GTF
|
||||
compareF Addr64 Addr64 = EQF
|
||||
|
||||
-- | The nat representation of this address.
|
||||
addrWidthNatRepr :: AddrWidthRepr w -> NatRepr w
|
||||
addrWidthNatRepr Addr32 = knownNat
|
||||
|
||||
@ -47,8 +47,8 @@ import Data.Foldable
|
||||
import Data.Map.Strict (Map)
|
||||
import qualified Data.Map.Strict as Map
|
||||
import Data.Parameterized.Context as Ctx
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Text as Text
|
||||
--import qualified Data.Set as Set
|
||||
--import qualified Data.Text as Text
|
||||
import Data.Word
|
||||
import qualified Lang.Crucible.Analysis.Postdom as C
|
||||
import qualified Lang.Crucible.CFG.Core as C
|
||||
@ -82,6 +82,7 @@ import Data.Macaw.Symbolic.MemOps
|
||||
|
||||
data MacawSimulatorState sym = MacawSimulatorState
|
||||
|
||||
{-
|
||||
mkMemSegmentBinding :: (1 <= w)
|
||||
=> C.HandleAllocator s
|
||||
-> NatRepr w
|
||||
@ -103,6 +104,7 @@ mkMemBaseVarMap halloc mem = do
|
||||
, M.segmentBase seg /= 0
|
||||
]
|
||||
Map.fromList <$> traverse (mkMemSegmentBinding halloc (M.memWidth mem)) (Set.toList baseIndices)
|
||||
-}
|
||||
|
||||
-- | Create a Crucible CFG from a list of blocks
|
||||
mkCrucCFG :: forall s arch ids
|
||||
@ -290,7 +292,7 @@ evalMacawExprExtension sym _iTypes _logFn f e0 =
|
||||
PtrToBits w x -> doPtrToBits sym w =<< f x
|
||||
BitsToPtr _w x -> MM.llvmPointer_bv sym =<< f x
|
||||
|
||||
MacawNullPtr w | LeqProof <- lemma1_16 w -> MM.mkNullPointer sym w
|
||||
MacawNullPtr w | LeqProof <- addrWidthIsPos w -> MM.mkNullPointer sym (M.addrWidthNatRepr w)
|
||||
|
||||
type EvalStmtFunc f p sym ext =
|
||||
forall rtp blocks r ctx tp'.
|
||||
@ -321,7 +323,7 @@ execMacawStmtExtension archStmtFn mvar globs callH s0 st =
|
||||
MacawCondReadMem w mr p x d -> doCondReadMem st mvar globs w mr p x d
|
||||
MacawWriteMem w mr x v -> doWriteMem st mvar globs w mr x v
|
||||
|
||||
MacawGlobalPtr addr -> doGetGlobal st mvar globs addr
|
||||
MacawGlobalPtr w addr -> M.addrWidthClass w $ doGetGlobal st mvar globs addr
|
||||
|
||||
MacawFreshSymbolic t -> -- XXX: user freshValue
|
||||
do nm <- case userSymbol "macawFresh" of
|
||||
|
||||
@ -47,18 +47,18 @@ module Data.Macaw.Symbolic.CrucGen
|
||||
, valueToCrucible
|
||||
, evalArchStmt
|
||||
, MemSegmentMap
|
||||
, lemma1_16
|
||||
-- * Additional exports
|
||||
, runCrucGen
|
||||
, setMachineRegs
|
||||
, addTermStmt
|
||||
, parsedBlockLabel
|
||||
, ArchAddrWidthRepr
|
||||
, addrWidthIsPos
|
||||
) where
|
||||
|
||||
import Control.Lens hiding (Empty, (:>))
|
||||
import Control.Monad.Except
|
||||
import Control.Monad.ST
|
||||
import GHC.TypeLits(KnownNat)
|
||||
import Control.Monad.State.Strict
|
||||
import Data.Bits
|
||||
import qualified Data.Macaw.CFG as M
|
||||
@ -76,6 +76,7 @@ import qualified Data.Parameterized.Map as MapF
|
||||
import Data.Parameterized.TraversableF
|
||||
import Data.Parameterized.TraversableFC
|
||||
import qualified Data.Parameterized.TH.GADT as U
|
||||
import Data.Proxy
|
||||
|
||||
|
||||
import qualified Data.Sequence as Seq
|
||||
@ -105,6 +106,8 @@ type ArchAddrCrucibleType arch = MM.LLVMPointerType (M.ArchAddrWidth arch)
|
||||
type MacawFunctionArgs arch = EmptyCtx ::> ArchRegStruct arch
|
||||
type MacawFunctionResult arch = ArchRegStruct arch
|
||||
|
||||
type ArchAddrWidthRepr arch = M.AddrWidthRepr (M.ArchAddrWidth arch)
|
||||
|
||||
type family MacawArchStmtExtension (arch :: *) :: (C.CrucibleType -> *) -> C.CrucibleType -> *
|
||||
|
||||
type MacawArchConstraints arch =
|
||||
@ -113,14 +116,11 @@ type MacawArchConstraints arch =
|
||||
, C.PrettyApp (MacawArchStmtExtension arch)
|
||||
, M.MemWidth (M.RegAddrWidth (M.ArchReg arch))
|
||||
, M.PrettyF (M.ArchReg arch)
|
||||
, KnownNat (M.ArchAddrWidth arch)
|
||||
, 16 <= M.ArchAddrWidth arch
|
||||
)
|
||||
|
||||
------------------------------------------------------------------------
|
||||
-- CrucPersistentState
|
||||
|
||||
|
||||
-- | Architecture-specific information needed to translate from Macaw to Crucible
|
||||
data MacawSymbolicArchFunctions arch
|
||||
= MacawSymbolicArchFunctions
|
||||
@ -144,6 +144,10 @@ data MacawSymbolicArchFunctions arch
|
||||
-- ^ Generate crucible for architecture-specific terminal statement.
|
||||
}
|
||||
|
||||
crucGenAddrWidth :: MacawSymbolicArchFunctions arch -> ArchAddrWidthRepr arch
|
||||
crucGenAddrWidth fns =
|
||||
crucGenArchConstraints fns $ M.addrWidthRepr Proxy
|
||||
|
||||
-- | Return types of registers in Crucible
|
||||
crucArchRegTypes ::
|
||||
MacawSymbolicArchFunctions arch ->
|
||||
@ -167,8 +171,7 @@ type ArchNatRepr a = NatRepr (M.ArchAddrWidth a)
|
||||
|
||||
data MacawExprExtension (arch :: *)
|
||||
(f :: C.CrucibleType -> *)
|
||||
(tp :: C.CrucibleType)
|
||||
where
|
||||
(tp :: C.CrucibleType) where
|
||||
MacawOverflows :: (1 <= w)
|
||||
=> !MacawOverflowOp
|
||||
-> !(NatRepr w)
|
||||
@ -178,11 +181,11 @@ data MacawExprExtension (arch :: *)
|
||||
-> MacawExprExtension arch f C.BoolType
|
||||
|
||||
-- | Treat a pointer as a number.
|
||||
PtrToBits ::
|
||||
(1 <= w) =>
|
||||
!(NatRepr w) ->
|
||||
!(f (MM.LLVMPointerType w)) ->
|
||||
MacawExprExtension arch f (C.BVType w)
|
||||
PtrToBits
|
||||
:: (1 <= w)
|
||||
=> !(NatRepr w)
|
||||
-> !(f (MM.LLVMPointerType w))
|
||||
-> MacawExprExtension arch f (C.BVType w)
|
||||
|
||||
-- | Treat a number as a pointer.
|
||||
-- We can never read from this pointer.
|
||||
@ -193,11 +196,9 @@ data MacawExprExtension (arch :: *)
|
||||
MacawExprExtension arch f (MM.LLVMPointerType w)
|
||||
|
||||
-- | A null pointer.
|
||||
MacawNullPtr ::
|
||||
(16 <= M.ArchAddrWidth arch) =>
|
||||
!(ArchNatRepr arch) ->
|
||||
MacawExprExtension arch f (BVPtr arch)
|
||||
|
||||
MacawNullPtr
|
||||
:: !(ArchAddrWidthRepr arch)
|
||||
-> MacawExprExtension arch f (BVPtr arch)
|
||||
|
||||
instance C.PrettyApp (MacawExprExtension arch) where
|
||||
ppApp f a0 =
|
||||
@ -211,13 +212,17 @@ instance C.PrettyApp (MacawExprExtension arch) where
|
||||
|
||||
MacawNullPtr _ -> sexpr "null_ptr" []
|
||||
|
||||
addrWidthIsPos :: M.AddrWidthRepr w -> LeqProof 1 w
|
||||
addrWidthIsPos M.Addr32 = LeqProof
|
||||
addrWidthIsPos M.Addr64 = LeqProof
|
||||
|
||||
instance C.TypeApp (MacawExprExtension arch) where
|
||||
appType x =
|
||||
case x of
|
||||
MacawOverflows {} -> C.knownRepr
|
||||
PtrToBits w _ -> C.BVRepr w
|
||||
BitsToPtr w _ -> MM.LLVMPointerRepr w
|
||||
MacawNullPtr w | LeqProof <- lemma1_16 w -> MM.LLVMPointerRepr w
|
||||
MacawOverflows {} -> C.knownRepr
|
||||
PtrToBits w _ -> C.BVRepr w
|
||||
BitsToPtr w _ -> MM.LLVMPointerRepr w
|
||||
MacawNullPtr w | LeqProof <- addrWidthIsPos w -> MM.LLVMPointerRepr (M.addrWidthNatRepr w)
|
||||
|
||||
|
||||
------------------------------------------------------------------------
|
||||
@ -230,9 +235,7 @@ data MacawStmtExtension (arch :: *)
|
||||
|
||||
-- | Read from memory.
|
||||
MacawReadMem ::
|
||||
(16 <= M.ArchAddrWidth arch) =>
|
||||
|
||||
!(ArchNatRepr arch) ->
|
||||
!(ArchAddrWidthRepr arch) ->
|
||||
|
||||
-- Info about memory (endianness, size)
|
||||
!(M.MemRepr tp) ->
|
||||
@ -245,44 +248,37 @@ data MacawStmtExtension (arch :: *)
|
||||
|
||||
-- | Read from memory, if the condition is True.
|
||||
-- Otherwise, just return the given value.
|
||||
MacawCondReadMem ::
|
||||
(16 <= M.ArchAddrWidth arch) =>
|
||||
|
||||
!(ArchNatRepr arch) ->
|
||||
|
||||
MacawCondReadMem
|
||||
:: !(ArchAddrWidthRepr arch)
|
||||
-- Info about memory (endianness, size)
|
||||
!(M.MemRepr tp) ->
|
||||
|
||||
-> !(M.MemRepr tp)
|
||||
-- Condition
|
||||
!(f C.BoolType) ->
|
||||
|
||||
-> !(f C.BoolType)
|
||||
-- Pointer to read from
|
||||
!(f (ArchAddrCrucibleType arch)) ->
|
||||
|
||||
-> !(f (ArchAddrCrucibleType arch))
|
||||
-- Default value, returned if the condition is False.
|
||||
!(f (ToCrucibleType tp)) ->
|
||||
|
||||
MacawStmtExtension arch f (ToCrucibleType tp)
|
||||
-> !(f (ToCrucibleType tp))
|
||||
-> MacawStmtExtension arch f (ToCrucibleType tp)
|
||||
|
||||
-- | Write to memory
|
||||
MacawWriteMem ::
|
||||
(16 <= M.ArchAddrWidth arch) =>
|
||||
!(ArchNatRepr arch) ->
|
||||
!(M.MemRepr tp) ->
|
||||
!(f (ArchAddrCrucibleType arch)) ->
|
||||
!(f (ToCrucibleType tp)) ->
|
||||
MacawStmtExtension arch f C.UnitType
|
||||
MacawWriteMem
|
||||
:: !(ArchAddrWidthRepr arch)
|
||||
-> !(M.MemRepr tp)
|
||||
-> !(f (ArchAddrCrucibleType arch))
|
||||
-> !(f (ToCrucibleType tp))
|
||||
-> MacawStmtExtension arch f C.UnitType
|
||||
|
||||
-- | Get the pointer associated with the given global address.
|
||||
MacawGlobalPtr ::
|
||||
(16 <= M.ArchAddrWidth arch, M.MemWidth (M.ArchAddrWidth arch)) =>
|
||||
!(M.MemAddr (M.ArchAddrWidth arch)) ->
|
||||
MacawStmtExtension arch f (BVPtr arch)
|
||||
MacawGlobalPtr
|
||||
:: !(ArchAddrWidthRepr arch)
|
||||
-> !(M.MemAddr (M.ArchAddrWidth arch))
|
||||
-> MacawStmtExtension arch f (BVPtr arch)
|
||||
|
||||
|
||||
-- | Generate a fresh symbolic variable of the given type.
|
||||
MacawFreshSymbolic ::
|
||||
!(M.TypeRepr tp) -> MacawStmtExtension arch f (ToCrucibleType tp)
|
||||
MacawFreshSymbolic
|
||||
:: !(M.TypeRepr tp)
|
||||
-> MacawStmtExtension arch f (ToCrucibleType tp)
|
||||
|
||||
-- | Call a function.
|
||||
MacawCall ::
|
||||
@ -310,32 +306,28 @@ data MacawStmtExtension (arch :: *)
|
||||
|
||||
-- | Equality for pointer or bit-vector.
|
||||
PtrEq ::
|
||||
(16 <= M.ArchAddrWidth arch) =>
|
||||
!(ArchNatRepr arch) ->
|
||||
!(ArchAddrWidthRepr arch) ->
|
||||
!(f (BVPtr arch)) ->
|
||||
!(f (BVPtr arch)) ->
|
||||
MacawStmtExtension arch f C.BoolType
|
||||
|
||||
-- | Unsigned comparison for pointer/bit-vector.
|
||||
PtrLeq ::
|
||||
(16 <= M.ArchAddrWidth arch) =>
|
||||
!(ArchNatRepr arch) ->
|
||||
!(ArchAddrWidthRepr arch) ->
|
||||
!(f (BVPtr arch)) ->
|
||||
!(f (BVPtr arch)) ->
|
||||
MacawStmtExtension arch f C.BoolType
|
||||
|
||||
-- | Unsigned comparison for pointer/bit-vector.
|
||||
PtrLt ::
|
||||
(16 <= M.ArchAddrWidth arch) =>
|
||||
!(ArchNatRepr arch) ->
|
||||
!(ArchAddrWidthRepr arch) ->
|
||||
!(f (BVPtr arch)) ->
|
||||
!(f (BVPtr arch)) ->
|
||||
MacawStmtExtension arch f C.BoolType
|
||||
|
||||
-- | Mux for pointers or bit-vectors.
|
||||
PtrMux ::
|
||||
(16 <= M.ArchAddrWidth arch) =>
|
||||
!(ArchNatRepr arch) ->
|
||||
!(ArchAddrWidthRepr arch) ->
|
||||
!(f C.BoolType) ->
|
||||
!(f (BVPtr arch)) ->
|
||||
!(f (BVPtr arch)) ->
|
||||
@ -343,16 +335,14 @@ data MacawStmtExtension (arch :: *)
|
||||
|
||||
-- | Add a pointer to a bit-vector, or two bit-vectors.
|
||||
PtrAdd ::
|
||||
(16 <= M.ArchAddrWidth arch) =>
|
||||
!(ArchNatRepr arch) ->
|
||||
!(ArchAddrWidthRepr arch) ->
|
||||
!(f (BVPtr arch)) ->
|
||||
!(f (BVPtr arch)) ->
|
||||
MacawStmtExtension arch f (BVPtr arch)
|
||||
|
||||
-- | Subtract two pointers, two bit-vectors, or bit-vector from a pointer.
|
||||
PtrSub ::
|
||||
(16 <= M.ArchAddrWidth arch) =>
|
||||
!(ArchNatRepr arch) ->
|
||||
!(ArchAddrWidthRepr arch) ->
|
||||
!(f (BVPtr arch)) ->
|
||||
!(f (BVPtr arch)) ->
|
||||
MacawStmtExtension arch f (BVPtr arch)
|
||||
@ -361,8 +351,7 @@ data MacawStmtExtension (arch :: *)
|
||||
-- but sometimes we need to support "and"-ing a pointer with a constant,
|
||||
-- which happens when trying to align a pointer.
|
||||
PtrAnd ::
|
||||
(16 <= M.ArchAddrWidth arch) =>
|
||||
!(ArchNatRepr arch) ->
|
||||
!(ArchAddrWidthRepr arch) ->
|
||||
!(f (BVPtr arch)) ->
|
||||
!(f (BVPtr arch)) ->
|
||||
MacawStmtExtension arch f (BVPtr arch)
|
||||
@ -391,7 +380,7 @@ instance (C.PrettyApp (MacawArchStmtExtension arch),
|
||||
MacawReadMem _ r a -> sexpr "macawReadMem" [pretty r, f a]
|
||||
MacawCondReadMem _ r c a d -> sexpr "macawCondReadMem" [pretty r, f c, f a, f d ]
|
||||
MacawWriteMem _ r a v -> sexpr "macawWriteMem" [pretty r, f a, f v]
|
||||
MacawGlobalPtr x -> sexpr "global" [ text (show x) ]
|
||||
MacawGlobalPtr _ x -> sexpr "global" [ text (show x) ]
|
||||
|
||||
MacawFreshSymbolic r -> sexpr "macawFreshSymbolic" [ text (show r) ]
|
||||
MacawCall _ regs -> sexpr "macawCall" [ f regs ]
|
||||
@ -416,9 +405,8 @@ instance C.TypeApp (MacawArchStmtExtension arch)
|
||||
appType (MacawReadMem _ r _) = memReprToCrucible r
|
||||
appType (MacawCondReadMem _ r _ _ _) = memReprToCrucible r
|
||||
appType (MacawWriteMem _ _ _ _) = C.knownRepr
|
||||
appType (MacawGlobalPtr a)
|
||||
| let w = M.addrWidthNatRepr (M.addrWidthRepr a)
|
||||
, LeqProof <- lemma1_16 w = MM.LLVMPointerRepr w
|
||||
appType (MacawGlobalPtr w _)
|
||||
| LeqProof <- addrWidthIsPos w = MM.LLVMPointerRepr (M.addrWidthNatRepr w)
|
||||
appType (MacawFreshSymbolic r) = typeToCrucible r
|
||||
appType (MacawCall regTypes _) = C.StructRepr regTypes
|
||||
appType (MacawArchStmtExtension f) = C.appType f
|
||||
@ -426,16 +414,10 @@ instance C.TypeApp (MacawArchStmtExtension arch)
|
||||
appType PtrEq {} = C.knownRepr
|
||||
appType PtrLt {} = C.knownRepr
|
||||
appType PtrLeq {} = C.knownRepr
|
||||
appType (PtrAdd w _ _) | LeqProof <- lemma1_16 w = MM.LLVMPointerRepr w
|
||||
appType (PtrAnd w _ _) | LeqProof <- lemma1_16 w = MM.LLVMPointerRepr w
|
||||
appType (PtrSub w _ _) | LeqProof <- lemma1_16 w = MM.LLVMPointerRepr w
|
||||
appType (PtrMux w _ _ _) | LeqProof <- lemma1_16 w = MM.LLVMPointerRepr w
|
||||
|
||||
lemma1_16 :: (16 <= w) => p w -> LeqProof 1 w
|
||||
lemma1_16 w = leqTrans p (leqProof knownNat w)
|
||||
where
|
||||
p :: LeqProof 1 16
|
||||
p = leqProof knownNat knownNat
|
||||
appType (PtrAdd w _ _) | LeqProof <- addrWidthIsPos w = MM.LLVMPointerRepr (M.addrWidthNatRepr w)
|
||||
appType (PtrAnd w _ _) | LeqProof <- addrWidthIsPos w = MM.LLVMPointerRepr (M.addrWidthNatRepr w)
|
||||
appType (PtrSub w _ _) | LeqProof <- addrWidthIsPos w = MM.LLVMPointerRepr (M.addrWidthNatRepr w)
|
||||
appType (PtrMux w _ _ _) | LeqProof <- addrWidthIsPos w = MM.LLVMPointerRepr (M.addrWidthNatRepr w)
|
||||
|
||||
------------------------------------------------------------------------
|
||||
-- MacawExt
|
||||
@ -514,10 +496,8 @@ instance MonadState (CrucGenState arch ids s) (CrucGen arch ids s) where
|
||||
put s = CrucGen $ \_ cont -> cont s ()
|
||||
|
||||
-- | A NatRepr corresponding to the architecture width.
|
||||
archAddrWidth :: CrucGen arch ids s (NatRepr (M.ArchAddrWidth arch))
|
||||
archAddrWidth =
|
||||
do archFns <- translateFns <$> get
|
||||
crucGenArchConstraints archFns (return knownRepr)
|
||||
archAddrWidth :: CrucGen arch ids s (ArchAddrWidthRepr arch)
|
||||
archAddrWidth = crucGenAddrWidth . translateFns <$> get
|
||||
|
||||
-- | Get current position
|
||||
getPos :: CrucGen arch ids s C.Position
|
||||
@ -676,8 +656,8 @@ appToCrucible app = do
|
||||
M.BoolTypeRepr -> appAtom (C.BaseIsEq C.BaseBoolRepr xv yv)
|
||||
M.BVTypeRepr n ->
|
||||
do rW <- archAddrWidth
|
||||
case testEquality n rW of
|
||||
Just Refl -> evalMacawStmt (PtrEq n xv yv)
|
||||
case testEquality n (M.addrWidthNatRepr rW) of
|
||||
Just Refl -> evalMacawStmt (PtrEq rW xv yv)
|
||||
Nothing ->
|
||||
appAtom =<< C.BVEq n <$> toBits n xv <*> toBits n yv
|
||||
M.TupleTypeRepr _ -> fail "XXX: Equality on tuples not yet done."
|
||||
@ -691,8 +671,8 @@ appToCrucible app = do
|
||||
M.BoolTypeRepr -> appAtom (C.BaseIte C.BaseBoolRepr cond tv fv)
|
||||
M.BVTypeRepr n ->
|
||||
do rW <- archAddrWidth
|
||||
case testEquality n rW of
|
||||
Just Refl -> evalMacawStmt (PtrMux n cond tv fv)
|
||||
case testEquality n (M.addrWidthNatRepr rW) of
|
||||
Just Refl -> evalMacawStmt (PtrMux rW cond tv fv)
|
||||
Nothing -> appBVAtom n =<<
|
||||
C.BVIte cond n <$> toBits n tv <*> toBits n fv
|
||||
M.TupleTypeRepr _ -> fail "XXX: Mux on tuples not yet done."
|
||||
@ -728,8 +708,8 @@ appToCrucible app = do
|
||||
do xv <- v2c x
|
||||
yv <- v2c y
|
||||
aw <- archAddrWidth
|
||||
case testEquality w aw of
|
||||
Just Refl -> evalMacawStmt (PtrAdd w xv yv)
|
||||
case testEquality w (M.addrWidthNatRepr aw) of
|
||||
Just Refl -> evalMacawStmt (PtrAdd aw xv yv)
|
||||
Nothing -> appBVAtom w =<< C.BVAdd w <$> toBits w xv <*> toBits w yv
|
||||
|
||||
-- Here we assume that this does not make sense for pointers.
|
||||
@ -744,8 +724,8 @@ appToCrucible app = do
|
||||
do xv <- v2c x
|
||||
yv <- v2c y
|
||||
aw <- archAddrWidth
|
||||
case testEquality w aw of
|
||||
Just Refl -> evalMacawStmt (PtrSub w xv yv)
|
||||
case testEquality w (M.addrWidthNatRepr aw) of
|
||||
Just Refl -> evalMacawStmt (PtrSub aw xv yv)
|
||||
Nothing -> appBVAtom w =<< C.BVSub w <$> toBits w xv <*> toBits w yv
|
||||
|
||||
M.BVSbb w x y c -> do
|
||||
@ -758,23 +738,23 @@ appToCrucible app = do
|
||||
|
||||
M.BVMul w x y -> bitOp2 w (C.BVMul w) x y
|
||||
|
||||
M.BVUnsignedLe x y ->
|
||||
do let w = M.typeWidth x
|
||||
ptrW <- archAddrWidth
|
||||
xv <- v2c x
|
||||
yv <- v2c y
|
||||
case testEquality w ptrW of
|
||||
Just Refl -> evalMacawStmt (PtrLeq w xv yv)
|
||||
Nothing -> appAtom =<< C.BVUle w <$> toBits w xv <*> toBits w yv
|
||||
M.BVUnsignedLe x y -> do
|
||||
let w = M.typeWidth x
|
||||
ptrW <- archAddrWidth
|
||||
xv <- v2c x
|
||||
yv <- v2c y
|
||||
case testEquality w (M.addrWidthNatRepr ptrW) of
|
||||
Just Refl -> evalMacawStmt (PtrLeq ptrW xv yv)
|
||||
Nothing -> appAtom =<< C.BVUle w <$> toBits w xv <*> toBits w yv
|
||||
|
||||
M.BVUnsignedLt x y ->
|
||||
do let w = M.typeWidth x
|
||||
ptrW <- archAddrWidth
|
||||
xv <- v2c x
|
||||
yv <- v2c y
|
||||
case testEquality w ptrW of
|
||||
Just Refl -> evalMacawStmt (PtrLt w xv yv)
|
||||
Nothing -> appAtom =<< C.BVUlt w <$> toBits w xv <*> toBits w yv
|
||||
M.BVUnsignedLt x y -> do
|
||||
let w = M.typeWidth x
|
||||
ptrW <- archAddrWidth
|
||||
xv <- v2c x
|
||||
yv <- v2c y
|
||||
case testEquality w (M.addrWidthNatRepr ptrW) of
|
||||
Just Refl -> evalMacawStmt (PtrLt ptrW xv yv)
|
||||
Nothing -> appAtom =<< C.BVUlt w <$> toBits w xv <*> toBits w yv
|
||||
|
||||
M.BVSignedLe x y ->
|
||||
do let w = M.typeWidth x
|
||||
@ -797,13 +777,13 @@ appToCrucible app = do
|
||||
|
||||
M.BVComplement w x -> appBVAtom w =<< C.BVNot w <$> v2c' w x
|
||||
|
||||
M.BVAnd w x y ->
|
||||
do xv <- v2c x
|
||||
yv <- v2c y
|
||||
aw <- archAddrWidth
|
||||
case testEquality w aw of
|
||||
Just Refl -> evalMacawStmt (PtrAnd w xv yv)
|
||||
Nothing -> appBVAtom w =<< C.BVAnd w <$> toBits w xv <*> toBits w yv
|
||||
M.BVAnd w x y -> do
|
||||
xv <- v2c x
|
||||
yv <- v2c y
|
||||
aw <- archAddrWidth
|
||||
case testEquality w (M.addrWidthNatRepr aw) of
|
||||
Just Refl -> evalMacawStmt (PtrAnd aw xv yv)
|
||||
Nothing -> appBVAtom w =<< C.BVAnd w <$> toBits w xv <*> toBits w yv
|
||||
|
||||
M.BVOr w x y -> bitOp2 w (C.BVOr w) x y
|
||||
M.BVXor w x y -> bitOp2 w (C.BVXor w) x y
|
||||
@ -836,8 +816,6 @@ appToCrucible app = do
|
||||
M.Bsr w x -> do
|
||||
undefined w x
|
||||
|
||||
|
||||
|
||||
valueToCrucible :: M.Value arch ids tp
|
||||
-> CrucGen arch ids s (CR.Atom s (ToCrucibleType tp))
|
||||
valueToCrucible v = do
|
||||
@ -847,20 +825,12 @@ valueToCrucible v = do
|
||||
M.BVValue w c -> fromBits w =<< bvLit w c
|
||||
M.BoolValue b -> crucibleValue (C.BoolLit b)
|
||||
|
||||
M.RelocatableValue w addr ->
|
||||
do rW <- archAddrWidth
|
||||
case testEquality w rW of
|
||||
Just Refl
|
||||
| M.addrBase addr == 0 && M.addrOffset addr == 0 ->
|
||||
evalMacawExt (MacawNullPtr w)
|
||||
| otherwise -> evalMacawStmt (MacawGlobalPtr addr)
|
||||
Nothing ->
|
||||
fail $ unlines [ "Unexpected relocatable value width"
|
||||
, "*** Expected: " ++ show rW
|
||||
, "*** Width: " ++ show w
|
||||
, "*** Base: " ++ show (M.addrBase addr)
|
||||
, "*** Offset: " ++ show (M.addrOffset addr)
|
||||
]
|
||||
M.RelocatableValue w addr
|
||||
| M.addrBase addr == 0 && M.addrOffset addr == 0 ->
|
||||
evalMacawExt (MacawNullPtr w)
|
||||
| otherwise -> evalMacawStmt (MacawGlobalPtr w addr)
|
||||
M.SymbolValue{} -> do
|
||||
error "macaw-symbolic does not yet support symbol values."
|
||||
|
||||
M.Initial r ->
|
||||
getRegValue r
|
||||
@ -1207,7 +1177,7 @@ instance TestEqualityFC (MacawExprExtension arch) where
|
||||
$(U.structuralTypeEquality [t|MacawExprExtension|]
|
||||
[ (U.DataArg 1 `U.TypeApp` U.AnyType, [|f|])
|
||||
, (U.ConType [t|NatRepr |] `U.TypeApp` U.AnyType, [|testEquality|])
|
||||
|
||||
, (U.ConType [t|ArchAddrWidthRepr|] `U.TypeApp` U.AnyType, [|testEquality|])
|
||||
])
|
||||
|
||||
instance OrdFC (MacawExprExtension arch) where
|
||||
@ -1216,7 +1186,7 @@ instance OrdFC (MacawExprExtension arch) where
|
||||
[ (U.DataArg 1 `U.TypeApp` U.AnyType, [|f|])
|
||||
, (U.ConType [t|NatRepr|] `U.TypeApp` U.AnyType, [|compareF|])
|
||||
, (U.ConType [t|ArchNatRepr|] `U.TypeApp` U.AnyType, [|compareF|])
|
||||
|
||||
, (U.ConType [t|ArchAddrWidthRepr|] `U.TypeApp` U.AnyType, [|compareF|])
|
||||
])
|
||||
|
||||
instance FunctorFC (MacawExprExtension arch) where
|
||||
|
||||
@ -67,7 +67,7 @@ import Lang.Crucible.LLVM.MemModel.Generic(ppPtr)
|
||||
import Lang.Crucible.LLVM.DataLayout(EndianForm(..))
|
||||
import Lang.Crucible.LLVM.Bytes(toBytes)
|
||||
|
||||
import Data.Macaw.Symbolic.CrucGen(lemma1_16)
|
||||
import Data.Macaw.Symbolic.CrucGen (addrWidthIsPos)
|
||||
import Data.Macaw.Symbolic.PersistentState(ToCrucibleType)
|
||||
import Data.Macaw.CFG.Core(MemRepr(BVMemRepr))
|
||||
import qualified Data.Macaw.Memory as M
|
||||
@ -105,8 +105,12 @@ doMakeCall k st mvar regs =
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
addrWidthAtLeast16 :: M.AddrWidthRepr w -> LeqProof 16 w
|
||||
addrWidthAtLeast16 M.Addr32 = LeqProof
|
||||
addrWidthAtLeast16 M.Addr64 = LeqProof
|
||||
|
||||
doGetGlobal ::
|
||||
(IsSymInterface sym, 16 <= w, M.MemWidth w) =>
|
||||
(IsSymInterface sym, M.MemWidth w) =>
|
||||
CrucibleState s sym ext rtp blocks r ctx {- ^ Simulator state -} ->
|
||||
GlobalVar Mem {- ^ Model of memory -} ->
|
||||
Map M.RegionIndex (RegValue sym (LLVMPointerType w)) {- ^ Region ptrs -} ->
|
||||
@ -124,10 +128,11 @@ doGetGlobal st mvar globs addr =
|
||||
Just region ->
|
||||
do mem <- getMem st mvar
|
||||
let sym = stateSymInterface st
|
||||
let w = M.addrWidthNatRepr (M.addrWidthRepr addr)
|
||||
off <- bvLit sym w (M.memWordInteger (M.addrOffset addr))
|
||||
res <- let ?ptrWidth = w
|
||||
in doPtrAddOffset sym mem region off
|
||||
let w = M.addrWidthRepr addr
|
||||
LeqProof <- pure $ addrWidthAtLeast16 w
|
||||
let ?ptrWidth = M.addrWidthNatRepr w
|
||||
off <- bvLit sym ?ptrWidth (M.memWordInteger (M.addrOffset addr))
|
||||
res <- doPtrAddOffset sym mem region off
|
||||
return (res, st)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
@ -137,10 +142,10 @@ doGetGlobal st mvar globs addr =
|
||||
-- state, we don't actually do it.
|
||||
type PtrOp sym w a =
|
||||
forall s ext rtp blocks r ctx.
|
||||
(IsSymInterface sym, 16 <= w) =>
|
||||
IsSymInterface sym =>
|
||||
CrucibleState s sym ext rtp blocks r ctx {- ^ Simulator state -} ->
|
||||
GlobalVar Mem {- ^ Memory model -} ->
|
||||
NatRepr w {- ^ Width of pointer -} ->
|
||||
M.AddrWidthRepr w {- ^ Width of pointer -} ->
|
||||
RegEntry sym (LLVMPointerType w) {- ^ Argument 1 -} ->
|
||||
RegEntry sym (LLVMPointerType w) {- ^ Argument 2 -} ->
|
||||
IO (a, CrucibleState s sym ext rtp blocks r ctx)
|
||||
@ -154,11 +159,18 @@ binOpLabel lab x y =
|
||||
, "}"
|
||||
]
|
||||
|
||||
mkUndefinedPtr :: (IsSymInterface sym, 1 <= w) =>
|
||||
sym -> String -> NatRepr w -> IO (LLVMPtr sym w)
|
||||
mkUndefinedPtr sym nm w =
|
||||
do base <- mkUndefined sym ("ptr_base_" ++ nm) BaseNatRepr
|
||||
off <- mkUndefinedBV sym ("ptr_offset_" ++ nm) w
|
||||
return (LLVMPointer base off)
|
||||
|
||||
doPtrMux :: Pred sym -> PtrOp sym w (LLVMPtr sym w)
|
||||
doPtrMux c = ptrOp $ \sym _ w xPtr xBits yPtr yBits x y ->
|
||||
do both_bits <- andPred sym xBits yBits
|
||||
both_ptrs <- andPred sym xPtr yPtr
|
||||
undef <- mkUndefinedPtr sym "ptr_mux" w
|
||||
undef <- mkUndefinedPtr sym "ptr_mux" (M.addrWidthNatRepr w)
|
||||
cases sym (binOpLabel "ptr_mux" x y) muxLLVMPtr (Just undef)
|
||||
[ both_bits ~>
|
||||
endCase =<< llvmPointer_bv sym =<< bvIte sym c (asBits x) (asBits y)
|
||||
@ -171,26 +183,27 @@ doPtrAdd = ptrOp $ \sym _ w xPtr xBits yPtr yBits x y ->
|
||||
do both_bits <- andPred sym xBits yBits
|
||||
ptr_bits <- andPred sym xPtr yBits
|
||||
bits_ptr <- andPred sym xBits yPtr
|
||||
|
||||
let nw = M.addrWidthNatRepr w
|
||||
a <- cases sym (binOpLabel "ptr_add" x y) muxLLVMPtr Nothing
|
||||
[ both_bits ~>
|
||||
endCase =<< llvmPointer_bv sym =<< bvAdd sym (asBits x) (asBits y)
|
||||
|
||||
, ptr_bits ~> endCase =<< ptrAdd sym w x (asBits y)
|
||||
, bits_ptr ~> endCase =<< ptrAdd sym w y (asBits x)
|
||||
, ptr_bits ~> endCase =<< ptrAdd sym nw x (asBits y)
|
||||
, bits_ptr ~> endCase =<< ptrAdd sym nw y (asBits x)
|
||||
]
|
||||
return a
|
||||
|
||||
isValidPtr ::
|
||||
(IsSymInterface sym, 16 <= w) =>
|
||||
(IsSymInterface sym) =>
|
||||
sym ->
|
||||
RegValue sym Mem ->
|
||||
NatRepr w ->
|
||||
M.AddrWidthRepr w ->
|
||||
LLVMPtr sym w ->
|
||||
IO (Pred sym)
|
||||
isValidPtr sym mem w p =
|
||||
do let ?ptrWidth = w
|
||||
LeqProof <- return (lemma1_16 w)
|
||||
do LeqProof <- pure $ addrWidthIsPos w
|
||||
LeqProof <- pure $ addrWidthAtLeast16 w
|
||||
let ?ptrWidth = M.addrWidthNatRepr w
|
||||
isValidPointer sym p mem
|
||||
|
||||
doPtrSub :: PtrOp sym w (LLVMPtr sym w)
|
||||
@ -198,12 +211,13 @@ doPtrSub = ptrOp $ \sym mem w xPtr xBits yPtr yBits x y ->
|
||||
do both_bits <- andPred sym xBits yBits
|
||||
ptr_bits <- andPred sym xPtr yBits
|
||||
ptr_ptr <- andPred sym xPtr yPtr
|
||||
let nw = M.addrWidthNatRepr w
|
||||
|
||||
cases sym (binOpLabel "ptr_sub" x y) muxLLVMPtr Nothing
|
||||
[ both_bits ~>
|
||||
endCase =<< llvmPointer_bv sym =<< bvSub sym (asBits x) (asBits y)
|
||||
|
||||
, ptr_bits ~> endCase =<< ptrSub sym w x (asBits y)
|
||||
, ptr_bits ~> endCase =<< ptrSub sym nw x (asBits y)
|
||||
|
||||
, ptr_ptr ~>
|
||||
do okP1 <- isValidPtr sym mem w x
|
||||
@ -215,10 +229,11 @@ doPtrSub = ptrOp $ \sym mem w xPtr xBits yPtr yBits x y ->
|
||||
]
|
||||
|
||||
doPtrAnd :: PtrOp sym w (LLVMPtr sym w)
|
||||
doPtrAnd = ptrOp $ \sym mem w xPtr xBits yPtr yBits x y ->
|
||||
let doPtrAlign amt isP isB v
|
||||
doPtrAnd = ptrOp $ \sym _mem w xPtr xBits yPtr yBits x y ->
|
||||
let nw = M.addrWidthNatRepr w
|
||||
doPtrAlign amt isP isB v
|
||||
| amt == 0 = return v
|
||||
| amt == natValue w = mkNullPointer sym w
|
||||
| amt == natValue nw = mkNullPointer sym nw
|
||||
| Just 0 <- asNat (ptrBase v) = llvmPointer_bv sym =<<
|
||||
bvAndBits sym (asBits x) (asBits y)
|
||||
|
||||
@ -234,26 +249,25 @@ doPtrAnd = ptrOp $ \sym mem w xPtr xBits yPtr yBits x y ->
|
||||
nm <- mkName "align_amount"
|
||||
least <- freshConstant sym nm (BaseBVRepr n)
|
||||
|
||||
Just LeqProof <- return (testLeq n w)
|
||||
let mostBits = subNat w n
|
||||
Just LeqProof <- return (testLeq n nw)
|
||||
let mostBits = subNat nw n
|
||||
Just LeqProof <- return (testLeq (knownNat @1) mostBits)
|
||||
most <- bvLit sym mostBits 0
|
||||
|
||||
bts <- bvConcat sym most least
|
||||
|
||||
Refl <- return (minusPlusCancel w n)
|
||||
Refl <- return (minusPlusCancel nw n)
|
||||
|
||||
endCase =<< ptrSub sym w v bts
|
||||
endCase =<< ptrSub sym nw v bts
|
||||
-- We don't check for the validity of the pointer:
|
||||
-- this is done upon use.
|
||||
]
|
||||
in
|
||||
case (isAlignMask x, isAlignMask y) of
|
||||
(Just yes, _) -> doPtrAlign yes yPtr yBits y
|
||||
(_, Just yes) -> doPtrAlign yes xPtr xBits x
|
||||
_ -> do v1 <- doPtrToBits sym w x
|
||||
v2 <- doPtrToBits sym w y
|
||||
llvmPointer_bv sym =<< bvAndBits sym v1 v2
|
||||
in case (isAlignMask x, isAlignMask y) of
|
||||
(Just yes, _) -> doPtrAlign yes yPtr yBits y
|
||||
(_, Just yes) -> doPtrAlign yes xPtr xBits x
|
||||
_ -> do v1 <- doPtrToBits sym nw x
|
||||
v2 <- doPtrToBits sym nw y
|
||||
llvmPointer_bv sym =<< bvAndBits sym v1 v2
|
||||
|
||||
|
||||
|
||||
@ -290,21 +304,22 @@ doPtrEq = ptrOp $ \sym mem w xPtr xBits yPtr yBits x y ->
|
||||
do both_bits <- andPred sym xBits yBits
|
||||
both_ptrs <- andPred sym xPtr yPtr
|
||||
undef <- mkUndefinedBool sym "ptr_eq"
|
||||
let nw = M.addrWidthNatRepr w
|
||||
cases sym (binOpLabel "ptr_eq" x y) itePred (Just undef)
|
||||
[ both_bits ~> endCase =<< bvEq sym (asBits x) (asBits y)
|
||||
, both_ptrs ~>
|
||||
do okP1 <- isValidPtr sym mem w x
|
||||
okP2 <- isValidPtr sym mem w y
|
||||
ok <- andPred sym okP1 okP2
|
||||
endCaseCheck ok "Comparing invalid pointers" =<< ptrEq sym w x y
|
||||
endCaseCheck ok "Comparing invalid pointers" =<< ptrEq sym nw x y
|
||||
]
|
||||
|
||||
doReadMem ::
|
||||
(IsSymInterface sym, 16 <= ptrW) =>
|
||||
IsSymInterface sym =>
|
||||
CrucibleState s sym ext rtp blocks r ctx {- ^ Simulator state -} ->
|
||||
GlobalVar Mem ->
|
||||
Map M.RegionIndex (RegValue sym (LLVMPointerType ptrW)) {- ^ Region ptrs -} ->
|
||||
NatRepr ptrW ->
|
||||
M.AddrWidthRepr ptrW ->
|
||||
MemRepr ty ->
|
||||
RegEntry sym (LLVMPointerType ptrW) ->
|
||||
IO ( RegValue sym (ToCrucibleType ty)
|
||||
@ -318,16 +333,18 @@ doReadMem st mvar globs w (BVMemRepr bytes endian) ptr0 =
|
||||
ty = bitvectorType (toBytes (widthVal bytes))
|
||||
bitw = natMultiply (knownNat @8) bytes
|
||||
|
||||
LeqProof <- return (lemma1_16 w)
|
||||
LeqProof <- return (leqMulPos (knownNat @8) bytes)
|
||||
|
||||
ptr <- tryGlobPtr sym mem globs w (regValue ptr0)
|
||||
|
||||
let ?ptrWidth = M.addrWidthNatRepr w
|
||||
ok <- isValidPtr sym mem w ptr
|
||||
check sym ok "doReadMem"
|
||||
$ "Reading through an invalid pointer: " ++ show (ppPtr ptr)
|
||||
|
||||
val <- let ?ptrWidth = w in loadRaw sym mem ptr ty
|
||||
LeqProof <- pure $ addrWidthIsPos w
|
||||
LeqProof <- pure $ addrWidthAtLeast16 w
|
||||
val <- loadRaw sym mem ptr ty
|
||||
a <- case valToBits bitw val of
|
||||
Just a -> return a
|
||||
Nothing -> fail "[doReadMem] We read an unexpected value"
|
||||
@ -337,11 +354,11 @@ doReadMem st mvar globs w (BVMemRepr bytes endian) ptr0 =
|
||||
|
||||
|
||||
doCondReadMem ::
|
||||
(IsSymInterface sym, 16 <= ptrW) =>
|
||||
IsSymInterface sym =>
|
||||
CrucibleState s sym ext rtp blocks r ctx {- ^ Simulator state -} ->
|
||||
GlobalVar Mem {- ^ Memory model -} ->
|
||||
Map M.RegionIndex (RegValue sym (LLVMPointerType ptrW)) {- ^ Region ptrs -} ->
|
||||
NatRepr ptrW {- ^ Width of ptr -} ->
|
||||
M.AddrWidthRepr ptrW {- ^ Width of ptr -} ->
|
||||
MemRepr ty {- ^ What/how we are reading -} ->
|
||||
RegEntry sym BoolType {- ^ Condition -} ->
|
||||
RegEntry sym (LLVMPointerType ptrW) {- ^ Pointer -} ->
|
||||
@ -358,7 +375,6 @@ doCondReadMem st mvar globs w (BVMemRepr bytes endian) cond0 ptr0 def0 =
|
||||
ty = bitvectorType (toBytes (widthVal bytes))
|
||||
bitw = natMultiply (knownNat @8) bytes
|
||||
|
||||
LeqProof <- return (lemma1_16 w)
|
||||
LeqProof <- return (leqMulPos (knownNat @8) bytes)
|
||||
|
||||
ptr <- tryGlobPtr sym mem globs w (regValue ptr0)
|
||||
@ -367,7 +383,9 @@ doCondReadMem st mvar globs w (BVMemRepr bytes endian) cond0 ptr0 def0 =
|
||||
$ "Conditional read through an invalid pointer: " ++
|
||||
show (ppPtr ptr)
|
||||
|
||||
val <- let ?ptrWidth = w in loadRawWithCondition sym mem ptr ty
|
||||
LeqProof <- pure $ addrWidthIsPos w
|
||||
LeqProof <- pure $ addrWidthAtLeast16 w
|
||||
val <- let ?ptrWidth = M.addrWidthNatRepr w in loadRawWithCondition sym mem ptr ty
|
||||
|
||||
let useDefault msg =
|
||||
do notC <- notPred sym cond
|
||||
@ -387,11 +405,11 @@ doCondReadMem st mvar globs w (BVMemRepr bytes endian) cond0 ptr0 def0 =
|
||||
|
||||
|
||||
doWriteMem ::
|
||||
(IsSymInterface sym, 16 <= ptrW) =>
|
||||
IsSymInterface sym =>
|
||||
CrucibleState s sym ext rtp blocks r ctx {- ^ Simulator state -} ->
|
||||
GlobalVar Mem {- ^ Memory model -} ->
|
||||
Map M.RegionIndex (RegValue sym (LLVMPointerType ptrW)) {- ^ Region ptrs -} ->
|
||||
NatRepr ptrW {- ^ Width of ptr -} ->
|
||||
M.AddrWidthRepr ptrW {- ^ Width of ptr -} ->
|
||||
MemRepr ty {- ^ What/how we are writing -} ->
|
||||
RegEntry sym (LLVMPointerType ptrW) {- ^ Pointer -} ->
|
||||
RegEntry sym (ToCrucibleType ty) {- ^ Write this value -} ->
|
||||
@ -405,7 +423,8 @@ doWriteMem st mvar globs w (BVMemRepr bytes endian) ptr0 val =
|
||||
let sym = stateSymInterface st
|
||||
ty = bitvectorType (toBytes (widthVal bytes))
|
||||
|
||||
LeqProof <- return (lemma1_16 w)
|
||||
LeqProof <- pure $ addrWidthIsPos w
|
||||
LeqProof <- pure $ addrWidthAtLeast16 w
|
||||
LeqProof <- return (leqMulPos (knownNat @8) bytes)
|
||||
|
||||
ptr <- tryGlobPtr sym mem globs w (regValue ptr0)
|
||||
@ -413,16 +432,12 @@ doWriteMem st mvar globs w (BVMemRepr bytes endian) ptr0 val =
|
||||
check sym ok "doWriteMem"
|
||||
$ "Write to an invalid location: " ++ show (ppPtr ptr)
|
||||
|
||||
let ?ptrWidth = w
|
||||
let ?ptrWidth = M.addrWidthNatRepr w
|
||||
let v0 = regValue val
|
||||
v = LLVMValInt (ptrBase v0) (asBits v0)
|
||||
mem1 <- storeRaw sym mem ptr ty v
|
||||
return ((), setMem st mvar mem1)
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Utilities
|
||||
|
||||
@ -455,14 +470,14 @@ ptrOp ::
|
||||
( (1 <= w) =>
|
||||
sym ->
|
||||
RegValue sym Mem ->
|
||||
NatRepr w ->
|
||||
M.AddrWidthRepr w ->
|
||||
Pred sym -> Pred sym -> Pred sym -> Pred sym ->
|
||||
LLVMPtr sym w -> LLVMPtr sym w -> IO a
|
||||
) ->
|
||||
PtrOp sym w a
|
||||
ptrOp k st mvar w x0 y0 =
|
||||
do mem <- getMem st mvar
|
||||
LeqProof <- return (lemma1_16 w)
|
||||
LeqProof <- return (addrWidthIsPos w)
|
||||
let sym = stateSymInterface st
|
||||
x = regValue x0
|
||||
y = regValue y0
|
||||
@ -560,13 +575,6 @@ checkEndian mem endian =
|
||||
, " *** Read : " ++ show need ]
|
||||
|
||||
|
||||
mkUndefinedPtr :: (IsSymInterface sym, 1 <= w) =>
|
||||
sym -> String -> NatRepr w -> IO (LLVMPtr sym w)
|
||||
mkUndefinedPtr sym nm w =
|
||||
do base <- mkUndefined sym ("ptr_base_" ++ nm) BaseNatRepr
|
||||
off <- mkUndefinedBV sym ("ptr_offset_" ++ nm) w
|
||||
return (LLVMPointer base off)
|
||||
|
||||
-- | A fresh boolean variable
|
||||
mkUndefinedBool ::
|
||||
(IsSymInterface sym) => sym -> String -> IO (RegValue sym BoolType)
|
||||
@ -608,18 +616,19 @@ which is statically known to be a constant, we consult
|
||||
the global map to see if we know about a correpsonding
|
||||
addres.. If so, we use that for the memory operation. -}
|
||||
tryGlobPtr ::
|
||||
(IsSymInterface sym, 16 <= w) =>
|
||||
IsSymInterface sym =>
|
||||
sym ->
|
||||
RegValue sym Mem ->
|
||||
Map M.RegionIndex (RegValue sym (LLVMPointerType w)) {- ^ Region ptrs -} ->
|
||||
NatRepr w ->
|
||||
M.AddrWidthRepr w ->
|
||||
LLVMPtr sym w ->
|
||||
IO (LLVMPtr sym w)
|
||||
tryGlobPtr sym mem globs w val
|
||||
| Just 0 <- asNat (ptrBase val)
|
||||
, Just r <- Map.lookup literalAddrRegion globs
|
||||
, LeqProof <- lemma1_16 w
|
||||
= let ?ptrWidth = w
|
||||
, LeqProof <- addrWidthIsPos w
|
||||
, LeqProof <- addrWidthAtLeast16 w =
|
||||
let ?ptrWidth = M.addrWidthNatRepr w
|
||||
in doPtrAddOffset sym mem r (asBits val)
|
||||
| otherwise = return val
|
||||
where
|
||||
@ -635,6 +644,3 @@ isAlignMask v =
|
||||
let (zeros,ones) = break (testBit k) (take w [ 0 .. ])
|
||||
guard (all (testBit k) ones)
|
||||
return (fromIntegral (length zeros))
|
||||
|
||||
|
||||
|
||||
|
||||
@ -101,8 +101,6 @@ getReg ::
|
||||
forall n t f. (Idx n (ArchRegContext M.X86_64) t) => RegAssign f -> f t
|
||||
getReg x = x ^. (field @n)
|
||||
|
||||
|
||||
|
||||
x86RegName :: M.X86Reg tp -> C.SolverSymbol
|
||||
x86RegName M.X86_IP = C.systemSymbol "!ip"
|
||||
x86RegName (M.X86_GP r) = C.systemSymbol $ "!" ++ show r
|
||||
@ -250,4 +248,3 @@ x86_64MacawSymbolicFns =
|
||||
x86_64MacawEvalFn ::
|
||||
C.IsSymInterface sym => SymFuns sym -> MacawArchEvalFn sym M.X86_64
|
||||
x86_64MacawEvalFn fs (X86PrimFn x) s = semantics fs x s
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user