--------------------------------------------------------------------
-- |
-- Module           : Lang.Crucible.LLVM.MemModel
-- Description      : Core definitions of the symbolic C memory model
-- Copyright        : (c) Galois, Inc 2015-2016
-- License          : BSD3
-- Maintainer       : Rob Dockins <rdockins@galois.com>
-- Stability        : provisional
------------------------------------------------------------------------

{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances, FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}

{-# OPTIONS_GHC -fno-warn-orphans #-}
module Lang.Crucible.LLVM.MemModel
  ( -- * Memories
    Mem
  , memRepr
  , mkMemVar
  , MemImpl(..)
  , SomePointer(..)
  , GlobalMap
  , emptyMem
  , memEndian
  , memAllocCount
  , memWriteCount
  , G.ppMem
  , doDumpMem
  , BlockSource(..)
  , nextBlock
  , MemOptions(..)
  , IndeterminateLoadBehavior(..)
  , defaultMemOptions
  , laxPointerMemOptions

  -- * Pointers
  , LLVMPointerType
  , pattern LLVMPointerRepr
  , pattern PtrRepr
  , pattern SizeT
  , LLVMPtr
  , pattern LLVMPointer
  , llvmPointerView
  , ptrWidth
  , G.ppPtr
  , G.ppTermExpr
  , llvmPointer_bv
  , Partial.ptrToBv
  , Partial.projectLLVM_bv

    -- * Memory operations
  , doMalloc
  , doMallocUnbounded
  , G.AllocType(..)
  , G.Mutability(..)
  , ME.FuncLookupError(..)
  , ME.ppFuncLookupError
  , doLookupHandle
  , doInstallHandle
  , doMemcpy
  , doMemset
  , doInvalidate
  , doCalloc
  , doFree
  , doAlloca
  , doLoad
  , doStore
  , doArrayStore
  , doArrayStoreUnbounded
  , doArrayConstStore
  , doArrayConstStoreUnbounded
  , loadString
  , loadMaybeString
  , strLen
  , uncheckedMemcpy

    -- * \"Raw\" operations with LLVMVal
  , LLVMVal(..)
  , ppLLVMValWithGlobals
  , FloatSize(..)
  , unpackMemValue
  , packMemValue
  , loadRaw
  , loadArrayConcreteSizeRaw
  , storeRaw
  , condStoreRaw
  , storeConstRaw
  , mallocRaw
  , mallocConstRaw
  , constToLLVMVal
  , constToLLVMValP
  , ptrMessage
  , Partial.PartLLVMVal(..)
  , Partial.assertSafe
  , explodeStringValue

    -- Re-exports from MemModel.Value
  , isZero
  , testEqual
  , llvmValStorableType

    -- * Storage types
  , StorageType
  , storageTypeF
  , StorageTypeF(..)
  , Field
  , storageTypeSize
  , fieldVal
  , fieldPad
  , fieldOffset
  , bitvectorType
  , arrayType
  , mkStructType
  , floatType
  , doubleType
  , x86_fp80Type
  , toStorableType

    -- * Pointer operations
  , ptrToPtrVal
  , mkNullPointer
  , ptrIsNull
  , ptrEq
  , ptrAdd
  , ptrSub
  , ptrDiff
  , doPtrAddOffset
  , doPtrSubtract
  , isValidPointer
  , isAllocatedAlignedPointer
  , muxLLVMPtr
  , G.isAligned

    -- * Disjointness
  , assertDisjointRegions
  , buildDisjointRegionsAssertion
  , buildDisjointRegionsAssertionWithSub

    -- * Globals
  , GlobalSymbol(..)
  , doResolveGlobal
  , registerGlobal
  , allocGlobals
  , allocGlobal
  , isGlobalPointer

    -- * Misc
  , llvmStatementExec
  , G.pushStackFrameMem
  , G.popStackFrameMem
  , G.asMemAllocationArrayStore
  , G.asMemMatchingArrayStore
  , SomeFnHandle(..)
  , G.SomeAlloc(..)
  , G.possibleAllocs
  , G.ppSomeAlloc
  , doConditionalWriteOperation
  , mergeWriteOperations
  , Partial.HasLLVMAnn
  , Partial.LLVMAnnMap
  , Partial.CexExplanation(..)
  , Partial.explainCex

    -- * PtrWidth (re-exports)
  , HasPtrWidth
  , pattern PtrWidth
  , withPtrWidth

    -- * Concretization
  , ML.concPtr
  , ML.concLLVMVal
  , ML.concMem
  , concMemImpl
  ) where

import           Prelude hiding (seq)

import           Control.Lens hiding (Empty, (:>))
import           Control.Monad
import           Control.Monad.IO.Class
import           Control.Monad.Trans (lift)
import           Control.Monad.Trans.State
import           Data.Dynamic
import           Data.IORef
import           Data.Map (Map)
import qualified Data.Map as Map
import           Data.Maybe
import           Data.Text (Text)
import           Data.Word
import qualified GHC.Stack as GHC
import           Numeric.Natural (Natural)
import           System.IO (Handle, hPutStrLn)

import qualified Data.BitVector.Sized as BV
import           Data.Parameterized.Classes
import qualified Data.Parameterized.Context as Ctx
import           Data.Parameterized.NatRepr
import           Data.Parameterized.Some
import qualified Data.Vector as V
import qualified Text.LLVM.AST as L

import           What4.Interface
import           What4.Expr( GroundValue )
import qualified What4.Expr.ArrayUpdateMap as AUM
import           What4.InterpretedFloatingPoint
import           What4.ProgramLoc

import           Lang.Crucible.Backend
import           Lang.Crucible.CFG.Common
import           Lang.Crucible.FunctionHandle
import           Lang.Crucible.Types
import           Lang.Crucible.Simulator.ExecutionTree
import           Lang.Crucible.Simulator.GlobalState
import           Lang.Crucible.Simulator.Intrinsics
import           Lang.Crucible.Simulator.RegMap
import           Lang.Crucible.Simulator.SimError

import           Lang.Crucible.LLVM.DataLayout
import           Lang.Crucible.LLVM.Extension
import           Lang.Crucible.LLVM.Bytes
import           Lang.Crucible.LLVM.Errors.MemoryError
   (MemErrContext, MemoryErrorReason(..), MemoryOp(..), ppMemoryErrorReason)
import qualified Lang.Crucible.LLVM.Errors.MemoryError as ME
import qualified Lang.Crucible.LLVM.Errors.UndefinedBehavior as UB
import           Lang.Crucible.LLVM.MemType
import           Lang.Crucible.LLVM.MemModel.CallStack (CallStack, getCallStack)
import qualified Lang.Crucible.LLVM.MemModel.MemLog as ML
import           Lang.Crucible.LLVM.MemModel.Type
import qualified Lang.Crucible.LLVM.MemModel.Partial as Partial
import qualified Lang.Crucible.LLVM.MemModel.Generic as G
import           Lang.Crucible.LLVM.MemModel.Pointer
import           Lang.Crucible.LLVM.MemModel.Options
import           Lang.Crucible.LLVM.MemModel.Value
import           Lang.Crucible.LLVM.Translation.Constant
import           Lang.Crucible.LLVM.Types
import           Lang.Crucible.LLVM.Utils
import           Lang.Crucible.Panic (panic)


import           GHC.Stack (HasCallStack)

----------------------------------------------------------------------
-- The MemImpl type

newtype BlockSource = BlockSource (IORef Natural)
type GlobalMap sym = Map L.Symbol (SomePointer sym)

nextBlock :: BlockSource -> IO Natural
nextBlock :: BlockSource -> IO Natural
nextBlock (BlockSource IORef Natural
ref) =
  IORef Natural -> (Natural -> (Natural, Natural)) -> IO Natural
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Natural
ref (\Natural
n -> (Natural
nNatural -> Natural -> Natural
forall a. Num a => a -> a -> a
+Natural
1, Natural
n))

-- | The implementation of an LLVM memory, containing an
-- allocation-block source, global map, handle map, and heap.
data MemImpl sym =
  MemImpl
  { forall sym. MemImpl sym -> BlockSource
memImplBlockSource :: BlockSource
  , forall sym. MemImpl sym -> GlobalMap sym
memImplGlobalMap   :: GlobalMap sym
  , forall sym. MemImpl sym -> Map Natural Symbol
memImplSymbolMap   :: Map Natural L.Symbol -- inverse mapping to 'memImplGlobalMap'
  , forall sym. MemImpl sym -> Map Natural Dynamic
memImplHandleMap   :: Map Natural Dynamic
  , forall sym. MemImpl sym -> Mem sym
memImplHeap        :: G.Mem sym
  }

memEndian :: MemImpl sym -> EndianForm
memEndian :: forall sym. MemImpl sym -> EndianForm
memEndian = Mem sym -> EndianForm
forall sym. Mem sym -> EndianForm
G.memEndian (Mem sym -> EndianForm)
-> (MemImpl sym -> Mem sym) -> MemImpl sym -> EndianForm
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MemImpl sym -> Mem sym
forall sym. MemImpl sym -> Mem sym
memImplHeap

memAllocCount :: MemImpl sym -> Int
memAllocCount :: forall sym. MemImpl sym -> Int
memAllocCount = Mem sym -> Int
forall sym. Mem sym -> Int
G.memAllocCount (Mem sym -> Int) -> (MemImpl sym -> Mem sym) -> MemImpl sym -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MemImpl sym -> Mem sym
forall sym. MemImpl sym -> Mem sym
memImplHeap

memWriteCount :: MemImpl sym -> Int
memWriteCount :: forall sym. MemImpl sym -> Int
memWriteCount = Mem sym -> Int
forall sym. Mem sym -> Int
G.memWriteCount (Mem sym -> Int) -> (MemImpl sym -> Mem sym) -> MemImpl sym -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MemImpl sym -> Mem sym
forall sym. MemImpl sym -> Mem sym
memImplHeap

-- | Produce a fresh empty memory.
--   NB, we start counting allocation blocks at '1'.
--   Block number 0 is reserved for representing raw bitvectors.
emptyMem :: EndianForm -> IO (MemImpl sym)
emptyMem :: forall sym. EndianForm -> IO (MemImpl sym)
emptyMem EndianForm
endianness = do
  IORef Natural
blkRef <- Natural -> IO (IORef Natural)
forall a. a -> IO (IORef a)
newIORef Natural
1
  MemImpl sym -> IO (MemImpl sym)
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (MemImpl sym -> IO (MemImpl sym))
-> MemImpl sym -> IO (MemImpl sym)
forall a b. (a -> b) -> a -> b
$ BlockSource
-> GlobalMap sym
-> Map Natural Symbol
-> Map Natural Dynamic
-> Mem sym
-> MemImpl sym
forall sym.
BlockSource
-> GlobalMap sym
-> Map Natural Symbol
-> Map Natural Dynamic
-> Mem sym
-> MemImpl sym
MemImpl (IORef Natural -> BlockSource
BlockSource IORef Natural
blkRef) GlobalMap sym
forall k a. Map k a
Map.empty Map Natural Symbol
forall k a. Map k a
Map.empty Map Natural Dynamic
forall k a. Map k a
Map.empty (EndianForm -> Mem sym
forall sym. EndianForm -> Mem sym
G.emptyMem EndianForm
endianness)

-- | Pretty print a memory state to the given handle.
doDumpMem :: IsExprBuilder sym => Handle -> MemImpl sym -> IO ()
doDumpMem :: forall sym. IsExprBuilder sym => Handle -> MemImpl sym -> IO ()
doDumpMem Handle
h MemImpl sym
mem = do
  Handle -> String -> IO ()
hPutStrLn Handle
h (Doc Any -> String
forall a. Show a => a -> String
show (Mem sym -> Doc Any
forall sym ann. IsExpr (SymExpr sym) => Mem sym -> Doc ann
G.ppMem (MemImpl sym -> Mem sym
forall sym. MemImpl sym -> Mem sym
memImplHeap MemImpl sym
mem)))

----------------------------------------------------------------------
-- Memory operations
--


-- | Assert that some undefined behavior doesn't occur when performing memory
-- model operations
assertUndefined ::
  (IsSymBackend sym bak, Partial.HasLLVMAnn sym) =>
  bak ->
  CallStack ->
  Pred sym ->
  (UB.UndefinedBehavior (RegValue' sym)) {- ^ The undesirable behavior -} ->
  IO ()
assertUndefined :: forall sym bak.
(IsSymBackend sym bak, HasLLVMAnn sym) =>
bak
-> CallStack
-> Pred sym
-> UndefinedBehavior (RegValue' sym)
-> IO ()
assertUndefined bak
bak CallStack
callStack Pred sym
p UndefinedBehavior (RegValue' sym)
ub =
  do let sym :: sym
sym = bak -> sym
forall sym bak. HasSymInterface sym bak => bak -> sym
backendGetSym bak
bak
     Pred sym
p' <- sym
-> CallStack
-> UndefinedBehavior (RegValue' sym)
-> Pred sym
-> IO (Pred sym)
forall sym.
(IsSymInterface sym, HasLLVMAnn sym) =>
sym
-> CallStack
-> UndefinedBehavior (RegValue' sym)
-> Pred sym
-> IO (Pred sym)
Partial.annotateUB sym
sym CallStack
callStack UndefinedBehavior (RegValue' sym)
ub Pred sym
p
     bak -> Pred sym -> SimErrorReason -> IO ()
forall sym bak.
IsSymBackend sym bak =>
bak -> Pred sym -> SimErrorReason -> IO ()
assert bak
bak Pred sym
p' (SimErrorReason -> IO ()) -> SimErrorReason -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> SimErrorReason
AssertFailureSimError String
"Undefined behavior encountered" (Doc Any -> String
forall a. Show a => a -> String
show (UndefinedBehavior (RegValue' sym) -> Doc Any
forall (e :: CrucibleType -> Type) ann.
UndefinedBehavior e -> Doc ann
UB.explain UndefinedBehavior (RegValue' sym)
ub))


assertStoreError ::
  (IsSymBackend sym bak, Partial.HasLLVMAnn sym, 1 <= wptr) =>
  bak ->
  MemErrContext sym wptr ->
  MemoryErrorReason ->
  Pred sym ->
  IO ()
assertStoreError :: forall sym bak (wptr :: Natural).
(IsSymBackend sym bak, HasLLVMAnn sym, 1 <= wptr) =>
bak
-> MemErrContext sym wptr -> MemoryErrorReason -> Pred sym -> IO ()
assertStoreError bak
bak MemErrContext sym wptr
errCtx MemoryErrorReason
rsn Pred sym
p =
  do let sym :: sym
sym = bak -> sym
forall sym bak. HasSymInterface sym bak => bak -> sym
backendGetSym bak
bak
     Pred sym
p' <- sym
-> MemErrContext sym wptr
-> MemoryErrorReason
-> Pred sym
-> IO (Pred sym)
forall sym (w :: Natural).
(IsSymInterface sym, HasLLVMAnn sym, 1 <= w) =>
sym
-> MemoryOp sym w -> MemoryErrorReason -> Pred sym -> IO (Pred sym)
Partial.annotateME sym
sym MemErrContext sym wptr
errCtx MemoryErrorReason
rsn Pred sym
p
     bak -> Pred sym -> SimErrorReason -> IO ()
forall sym bak.
IsSymBackend sym bak =>
bak -> Pred sym -> SimErrorReason -> IO ()
assert bak
bak Pred sym
p' (SimErrorReason -> IO ()) -> SimErrorReason -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> SimErrorReason
AssertFailureSimError String
"Memory store failed" (Doc Any -> String
forall a. Show a => a -> String
show (MemoryErrorReason -> Doc Any
forall ann. MemoryErrorReason -> Doc ann
ppMemoryErrorReason MemoryErrorReason
rsn))

instance IsSymInterface sym => IntrinsicClass sym "LLVM_memory" where
  type Intrinsic sym "LLVM_memory" ctx = MemImpl sym

  -- NB: Here we are assuming the global maps of both memories are identical.
  -- This should be the case as memories are only supposed to allocate globals at
  -- startup, not during program execution.  We could check that the maps match,
  -- but that would be expensive...
  muxIntrinsic :: forall (ctx :: Ctx CrucibleType).
sym
-> IntrinsicTypes sym
-> SymbolRepr "LLVM_memory"
-> CtxRepr ctx
-> Pred sym
-> Intrinsic sym "LLVM_memory" ctx
-> Intrinsic sym "LLVM_memory" ctx
-> IO (Intrinsic sym "LLVM_memory" ctx)
muxIntrinsic sym
_sym IntrinsicTypes sym
_iTypes SymbolRepr "LLVM_memory"
_nm CtxRepr ctx
_ Pred sym
p Intrinsic sym "LLVM_memory" ctx
mem1 Intrinsic sym "LLVM_memory" ctx
mem2 =
     do let MemImpl BlockSource
blockSource GlobalMap sym
gMap1 Map Natural Symbol
sMap1 Map Natural Dynamic
hMap1 Mem sym
m1 = Intrinsic sym "LLVM_memory" ctx
mem1
        let MemImpl BlockSource
_blockSource GlobalMap sym
_gMap2 Map Natural Symbol
_sMap2 Map Natural Dynamic
hMap2 Mem sym
m2 = Intrinsic sym "LLVM_memory" ctx
mem2
        --putStrLn "MEM MERGE"
        Intrinsic sym "LLVM_memory" ctx
-> IO (Intrinsic sym "LLVM_memory" ctx)
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Intrinsic sym "LLVM_memory" ctx
 -> IO (Intrinsic sym "LLVM_memory" ctx))
-> Intrinsic sym "LLVM_memory" ctx
-> IO (Intrinsic sym "LLVM_memory" ctx)
forall a b. (a -> b) -> a -> b
$ BlockSource
-> GlobalMap sym
-> Map Natural Symbol
-> Map Natural Dynamic
-> Mem sym
-> MemImpl sym
forall sym.
BlockSource
-> GlobalMap sym
-> Map Natural Symbol
-> Map Natural Dynamic
-> Mem sym
-> MemImpl sym
MemImpl BlockSource
blockSource GlobalMap sym
gMap1 Map Natural Symbol
sMap1
                   (Map Natural Dynamic -> Map Natural Dynamic -> Map Natural Dynamic
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union Map Natural Dynamic
hMap1 Map Natural Dynamic
hMap2)
                   (Pred sym -> Mem sym -> Mem sym -> Mem sym
forall sym.
IsExpr (SymExpr sym) =>
Pred sym -> Mem sym -> Mem sym -> Mem sym
G.mergeMem Pred sym
p Mem sym
m1 Mem sym
m2)

  pushBranchIntrinsic :: forall (ctx :: Ctx CrucibleType).
sym
-> IntrinsicTypes sym
-> SymbolRepr "LLVM_memory"
-> CtxRepr ctx
-> Intrinsic sym "LLVM_memory" ctx
-> IO (Intrinsic sym "LLVM_memory" ctx)
pushBranchIntrinsic sym
_sym IntrinsicTypes sym
_iTypes SymbolRepr "LLVM_memory"
_nm CtxRepr ctx
_ctx Intrinsic sym "LLVM_memory" ctx
mem =
     do let MemImpl BlockSource
nxt GlobalMap sym
gMap Map Natural Symbol
sMap Map Natural Dynamic
hMap Mem sym
m = Intrinsic sym "LLVM_memory" ctx
mem
        --putStrLn "MEM PUSH BRANCH"
        Intrinsic sym "LLVM_memory" ctx
-> IO (Intrinsic sym "LLVM_memory" ctx)
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Intrinsic sym "LLVM_memory" ctx
 -> IO (Intrinsic sym "LLVM_memory" ctx))
-> Intrinsic sym "LLVM_memory" ctx
-> IO (Intrinsic sym "LLVM_memory" ctx)
forall a b. (a -> b) -> a -> b
$ BlockSource
-> GlobalMap sym
-> Map Natural Symbol
-> Map Natural Dynamic
-> Mem sym
-> MemImpl sym
forall sym.
BlockSource
-> GlobalMap sym
-> Map Natural Symbol
-> Map Natural Dynamic
-> Mem sym
-> MemImpl sym
MemImpl BlockSource
nxt GlobalMap sym
gMap Map Natural Symbol
sMap Map Natural Dynamic
hMap (Mem sym -> MemImpl sym) -> Mem sym -> MemImpl sym
forall a b. (a -> b) -> a -> b
$ Mem sym -> Mem sym
forall sym. Mem sym -> Mem sym
G.branchMem Mem sym
m

  abortBranchIntrinsic :: forall (ctx :: Ctx CrucibleType).
sym
-> IntrinsicTypes sym
-> SymbolRepr "LLVM_memory"
-> CtxRepr ctx
-> Intrinsic sym "LLVM_memory" ctx
-> IO (Intrinsic sym "LLVM_memory" ctx)
abortBranchIntrinsic sym
_sym IntrinsicTypes sym
_iTypes SymbolRepr "LLVM_memory"
_nm CtxRepr ctx
_ctx Intrinsic sym "LLVM_memory" ctx
mem =
     do let MemImpl BlockSource
nxt GlobalMap sym
gMap Map Natural Symbol
sMap Map Natural Dynamic
hMap Mem sym
m = Intrinsic sym "LLVM_memory" ctx
mem
        --putStrLn "MEM ABORT BRANCH"
        Intrinsic sym "LLVM_memory" ctx
-> IO (Intrinsic sym "LLVM_memory" ctx)
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Intrinsic sym "LLVM_memory" ctx
 -> IO (Intrinsic sym "LLVM_memory" ctx))
-> Intrinsic sym "LLVM_memory" ctx
-> IO (Intrinsic sym "LLVM_memory" ctx)
forall a b. (a -> b) -> a -> b
$ BlockSource
-> GlobalMap sym
-> Map Natural Symbol
-> Map Natural Dynamic
-> Mem sym
-> MemImpl sym
forall sym.
BlockSource
-> GlobalMap sym
-> Map Natural Symbol
-> Map Natural Dynamic
-> Mem sym
-> MemImpl sym
MemImpl BlockSource
nxt GlobalMap sym
gMap Map Natural Symbol
sMap Map Natural Dynamic
hMap (Mem sym -> MemImpl sym) -> Mem sym -> MemImpl sym
forall a b. (a -> b) -> a -> b
$ Mem sym -> Mem sym
forall sym. Mem sym -> Mem sym
G.branchAbortMem Mem sym
m

-- | Top-level evaluation function for LLVM extension statements.
--   LLVM extension statements are used to implement the memory model operations.
llvmStatementExec ::
  (Partial.HasLLVMAnn sym, ?memOpts :: MemOptions) =>
  EvalStmtFunc p sym LLVM
llvmStatementExec :: forall sym p.
(HasLLVMAnn sym, ?memOpts::MemOptions) =>
EvalStmtFunc p sym LLVM
llvmStatementExec StmtExtension LLVM (RegEntry sym) tp'
stmt CrucibleState p sym LLVM rtp blocks r ctx
cst =
  let simCtx :: SimContext p sym LLVM
simCtx = CrucibleState p sym LLVM rtp blocks r ctx
cstCrucibleState p sym LLVM rtp blocks r ctx
-> Getting
     (SimContext p sym LLVM)
     (CrucibleState p sym LLVM rtp blocks r ctx)
     (SimContext p sym LLVM)
-> SimContext p sym LLVM
forall s a. s -> Getting a s a -> a
^.Getting
  (SimContext p sym LLVM)
  (CrucibleState p sym LLVM rtp blocks r ctx)
  (SimContext p sym LLVM)
forall p sym ext r f1 (a :: Maybe (Ctx CrucibleType))
       (f2 :: Type -> Type).
Functor f2 =>
(SimContext p sym ext -> f2 (SimContext p sym ext))
-> SimState p sym ext r f1 a -> f2 (SimState p sym ext r f1 a)
stateContext
   in SimContext p sym LLVM
-> (forall {bak}.
    IsSymBackend sym bak =>
    bak
    -> IO
         (RegValue sym tp', CrucibleState p sym LLVM rtp blocks r ctx))
-> IO (RegValue sym tp', CrucibleState p sym LLVM rtp blocks r ctx)
forall personality sym ext a.
SimContext personality sym ext
-> (forall bak. IsSymBackend sym bak => bak -> a) -> a
withBackend SimContext p sym LLVM
simCtx ((forall {bak}.
  IsSymBackend sym bak =>
  bak
  -> IO
       (RegValue sym tp', CrucibleState p sym LLVM rtp blocks r ctx))
 -> IO
      (RegValue sym tp', CrucibleState p sym LLVM rtp blocks r ctx))
-> (forall {bak}.
    IsSymBackend sym bak =>
    bak
    -> IO
         (RegValue sym tp', CrucibleState p sym LLVM rtp blocks r ctx))
-> IO (RegValue sym tp', CrucibleState p sym LLVM rtp blocks r ctx)
forall a b. (a -> b) -> a -> b
$ \bak
bak ->
        StateT
  (CrucibleState p sym LLVM rtp blocks r ctx) IO (RegValue sym tp')
-> CrucibleState p sym LLVM rtp blocks r ctx
-> IO (RegValue sym tp', CrucibleState p sym LLVM rtp blocks r ctx)
forall s (m :: Type -> Type) a. StateT s m a -> s -> m (a, s)
runStateT (bak
-> LLVMStmt (RegEntry sym) tp'
-> StateT
     (CrucibleState p sym LLVM rtp blocks r ctx) IO (RegValue sym tp')
forall p sym bak ext rtp (blocks :: Ctx (Ctx CrucibleType))
       (ret :: CrucibleType) (args :: Ctx CrucibleType)
       (tp :: CrucibleType).
(IsSymBackend sym bak, HasLLVMAnn sym, HasCallStack,
 ?memOpts::MemOptions) =>
bak
-> LLVMStmt (RegEntry sym) tp
-> EvalM p sym ext rtp blocks ret args (RegValue sym tp)
evalStmt bak
bak StmtExtension LLVM (RegEntry sym) tp'
LLVMStmt (RegEntry sym) tp'
stmt) CrucibleState p sym LLVM rtp blocks r ctx
cst

type EvalM p sym ext rtp blocks ret args a =
  StateT (CrucibleState p sym ext rtp blocks ret args) IO a

-- | Actual workhorse function for evaluating LLVM extension statements.
--   The semantics are explicitly organized as a state transformer monad
--   that modifies the global state of the simulator; this captures the
--   memory accessing effects of these statements.
evalStmt :: forall p sym bak ext rtp blocks ret args tp.
  (IsSymBackend sym bak, Partial.HasLLVMAnn sym, GHC.HasCallStack, ?memOpts :: MemOptions) =>
  bak ->
  LLVMStmt (RegEntry sym) tp ->
  EvalM p sym ext rtp blocks ret args (RegValue sym tp)
evalStmt :: forall p sym bak ext rtp (blocks :: Ctx (Ctx CrucibleType))
       (ret :: CrucibleType) (args :: Ctx CrucibleType)
       (tp :: CrucibleType).
(IsSymBackend sym bak, HasLLVMAnn sym, HasCallStack,
 ?memOpts::MemOptions) =>
bak
-> LLVMStmt (RegEntry sym) tp
-> EvalM p sym ext rtp blocks ret args (RegValue sym tp)
evalStmt bak
bak = LLVMStmt (RegEntry sym) tp
-> EvalM p sym ext rtp blocks ret args (RegValue sym tp)
eval
 where
  sym :: sym
sym = bak -> sym
forall sym bak. HasSymInterface sym bak => bak -> sym
backendGetSym bak
bak

  getMem :: GlobalVar Mem ->
            EvalM p sym ext rtp blocks ret args (MemImpl sym)
  getMem :: GlobalVar Mem -> EvalM p sym ext rtp blocks ret args (MemImpl sym)
getMem GlobalVar Mem
mvar =
    do SymGlobalState sym
gs <- Getting
  (SymGlobalState sym)
  (SimState p sym ext rtp (CrucibleLang blocks ret) ('Just args))
  (SymGlobalState sym)
-> StateT
     (SimState p sym ext rtp (CrucibleLang blocks ret) ('Just args))
     IO
     (SymGlobalState sym)
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
use ((ActiveTree p sym ext rtp (CrucibleLang blocks ret) ('Just args)
 -> Const
      (SymGlobalState sym)
      (ActiveTree p sym ext rtp (CrucibleLang blocks ret) ('Just args)))
-> SimState p sym ext rtp (CrucibleLang blocks ret) ('Just args)
-> Const
     (SymGlobalState sym)
     (SimState p sym ext rtp (CrucibleLang blocks ret) ('Just args))
forall p sym ext rtp f1 (a :: Maybe (Ctx CrucibleType)) g
       (b :: Maybe (Ctx CrucibleType)) (f2 :: Type -> Type).
Functor f2 =>
(ActiveTree p sym ext rtp f1 a
 -> f2 (ActiveTree p sym ext rtp g b))
-> SimState p sym ext rtp f1 a -> f2 (SimState p sym ext rtp g b)
stateTree((ActiveTree p sym ext rtp (CrucibleLang blocks ret) ('Just args)
  -> Const
       (SymGlobalState sym)
       (ActiveTree p sym ext rtp (CrucibleLang blocks ret) ('Just args)))
 -> SimState p sym ext rtp (CrucibleLang blocks ret) ('Just args)
 -> Const
      (SymGlobalState sym)
      (SimState p sym ext rtp (CrucibleLang blocks ret) ('Just args)))
-> ((SymGlobalState sym
     -> Const (SymGlobalState sym) (SymGlobalState sym))
    -> ActiveTree p sym ext rtp (CrucibleLang blocks ret) ('Just args)
    -> Const
         (SymGlobalState sym)
         (ActiveTree p sym ext rtp (CrucibleLang blocks ret) ('Just args)))
-> Getting
     (SymGlobalState sym)
     (SimState p sym ext rtp (CrucibleLang blocks ret) ('Just args))
     (SymGlobalState sym)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(TopFrame sym ext (CrucibleLang blocks ret) ('Just args)
 -> Const
      (SymGlobalState sym)
      (TopFrame sym ext (CrucibleLang blocks ret) ('Just args)))
-> ActiveTree p sym ext rtp (CrucibleLang blocks ret) ('Just args)
-> Const
     (SymGlobalState sym)
     (ActiveTree p sym ext rtp (CrucibleLang blocks ret) ('Just args))
forall p sym ext root f1 (args :: Maybe (Ctx CrucibleType))
       (args' :: Maybe (Ctx CrucibleType)) (f2 :: Type -> Type).
Functor f2 =>
(TopFrame sym ext f1 args -> f2 (TopFrame sym ext f1 args'))
-> ActiveTree p sym ext root f1 args
-> f2 (ActiveTree p sym ext root f1 args')
actFrame((TopFrame sym ext (CrucibleLang blocks ret) ('Just args)
  -> Const
       (SymGlobalState sym)
       (TopFrame sym ext (CrucibleLang blocks ret) ('Just args)))
 -> ActiveTree p sym ext rtp (CrucibleLang blocks ret) ('Just args)
 -> Const
      (SymGlobalState sym)
      (ActiveTree p sym ext rtp (CrucibleLang blocks ret) ('Just args)))
-> ((SymGlobalState sym
     -> Const (SymGlobalState sym) (SymGlobalState sym))
    -> TopFrame sym ext (CrucibleLang blocks ret) ('Just args)
    -> Const
         (SymGlobalState sym)
         (TopFrame sym ext (CrucibleLang blocks ret) ('Just args)))
-> (SymGlobalState sym
    -> Const (SymGlobalState sym) (SymGlobalState sym))
-> ActiveTree p sym ext rtp (CrucibleLang blocks ret) ('Just args)
-> Const
     (SymGlobalState sym)
     (ActiveTree p sym ext rtp (CrucibleLang blocks ret) ('Just args))
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(SymGlobalState sym
 -> Const (SymGlobalState sym) (SymGlobalState sym))
-> TopFrame sym ext (CrucibleLang blocks ret) ('Just args)
-> Const
     (SymGlobalState sym)
     (TopFrame sym ext (CrucibleLang blocks ret) ('Just args))
forall sym u (f :: Type -> Type).
Functor f =>
(SymGlobalState sym -> f (SymGlobalState sym))
-> GlobalPair sym u -> f (GlobalPair sym u)
gpGlobals)
       case GlobalVar Mem -> SymGlobalState sym -> Maybe (RegValue sym Mem)
forall (tp :: CrucibleType) sym.
GlobalVar tp -> SymGlobalState sym -> Maybe (RegValue sym tp)
lookupGlobal GlobalVar Mem
mvar SymGlobalState sym
gs of
         Just RegValue sym Mem
mem -> MemImpl sym -> EvalM p sym ext rtp blocks ret args (MemImpl sym)
forall a.
a
-> StateT
     (SimState p sym ext rtp (CrucibleLang blocks ret) ('Just args))
     IO
     a
forall (m :: Type -> Type) a. Monad m => a -> m a
return RegValue sym Mem
MemImpl sym
mem
         Maybe (RegValue sym Mem)
Nothing  ->
           String
-> [String] -> EvalM p sym ext rtp blocks ret args (MemImpl sym)
forall a. HasCallStack => String -> [String] -> a
panic String
"MemModel.evalStmt.getMem"
             [ String
"Global heap value not initialized."
             , String
"*** Global heap variable: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ GlobalVar Mem -> String
forall a. Show a => a -> String
show GlobalVar Mem
mvar
             ]

  setMem :: GlobalVar Mem ->
            MemImpl sym ->
            EvalM p sym ext rtp blocks ret args ()
  setMem :: GlobalVar Mem
-> MemImpl sym -> EvalM p sym ext rtp blocks ret args ()
setMem GlobalVar Mem
mvar MemImpl sym
mem = (ActiveTree p sym ext rtp (CrucibleLang blocks ret) ('Just args)
 -> Identity
      (ActiveTree p sym ext rtp (CrucibleLang blocks ret) ('Just args)))
-> SimState p sym ext rtp (CrucibleLang blocks ret) ('Just args)
-> Identity
     (SimState p sym ext rtp (CrucibleLang blocks ret) ('Just args))
forall p sym ext rtp f1 (a :: Maybe (Ctx CrucibleType)) g
       (b :: Maybe (Ctx CrucibleType)) (f2 :: Type -> Type).
Functor f2 =>
(ActiveTree p sym ext rtp f1 a
 -> f2 (ActiveTree p sym ext rtp g b))
-> SimState p sym ext rtp f1 a -> f2 (SimState p sym ext rtp g b)
stateTree((ActiveTree p sym ext rtp (CrucibleLang blocks ret) ('Just args)
  -> Identity
       (ActiveTree p sym ext rtp (CrucibleLang blocks ret) ('Just args)))
 -> SimState p sym ext rtp (CrucibleLang blocks ret) ('Just args)
 -> Identity
      (SimState p sym ext rtp (CrucibleLang blocks ret) ('Just args)))
-> ((SymGlobalState sym -> Identity (SymGlobalState sym))
    -> ActiveTree p sym ext rtp (CrucibleLang blocks ret) ('Just args)
    -> Identity
         (ActiveTree p sym ext rtp (CrucibleLang blocks ret) ('Just args)))
-> (SymGlobalState sym -> Identity (SymGlobalState sym))
-> SimState p sym ext rtp (CrucibleLang blocks ret) ('Just args)
-> Identity
     (SimState p sym ext rtp (CrucibleLang blocks ret) ('Just args))
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(TopFrame sym ext (CrucibleLang blocks ret) ('Just args)
 -> Identity
      (TopFrame sym ext (CrucibleLang blocks ret) ('Just args)))
-> ActiveTree p sym ext rtp (CrucibleLang blocks ret) ('Just args)
-> Identity
     (ActiveTree p sym ext rtp (CrucibleLang blocks ret) ('Just args))
forall p sym ext root f1 (args :: Maybe (Ctx CrucibleType))
       (args' :: Maybe (Ctx CrucibleType)) (f2 :: Type -> Type).
Functor f2 =>
(TopFrame sym ext f1 args -> f2 (TopFrame sym ext f1 args'))
-> ActiveTree p sym ext root f1 args
-> f2 (ActiveTree p sym ext root f1 args')
actFrame((TopFrame sym ext (CrucibleLang blocks ret) ('Just args)
  -> Identity
       (TopFrame sym ext (CrucibleLang blocks ret) ('Just args)))
 -> ActiveTree p sym ext rtp (CrucibleLang blocks ret) ('Just args)
 -> Identity
      (ActiveTree p sym ext rtp (CrucibleLang blocks ret) ('Just args)))
-> ((SymGlobalState sym -> Identity (SymGlobalState sym))
    -> TopFrame sym ext (CrucibleLang blocks ret) ('Just args)
    -> Identity
         (TopFrame sym ext (CrucibleLang blocks ret) ('Just args)))
-> (SymGlobalState sym -> Identity (SymGlobalState sym))
-> ActiveTree p sym ext rtp (CrucibleLang blocks ret) ('Just args)
-> Identity
     (ActiveTree p sym ext rtp (CrucibleLang blocks ret) ('Just args))
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(SymGlobalState sym -> Identity (SymGlobalState sym))
-> TopFrame sym ext (CrucibleLang blocks ret) ('Just args)
-> Identity
     (TopFrame sym ext (CrucibleLang blocks ret) ('Just args))
forall sym u (f :: Type -> Type).
Functor f =>
(SymGlobalState sym -> f (SymGlobalState sym))
-> GlobalPair sym u -> f (GlobalPair sym u)
gpGlobals ((SymGlobalState sym -> Identity (SymGlobalState sym))
 -> SimState p sym ext rtp (CrucibleLang blocks ret) ('Just args)
 -> Identity
      (SimState p sym ext rtp (CrucibleLang blocks ret) ('Just args)))
-> (SymGlobalState sym -> SymGlobalState sym)
-> EvalM p sym ext rtp blocks ret args ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= GlobalVar Mem
-> RegValue sym Mem -> SymGlobalState sym -> SymGlobalState sym
forall (tp :: CrucibleType) sym.
GlobalVar tp
-> RegValue sym tp -> SymGlobalState sym -> SymGlobalState sym
insertGlobal GlobalVar Mem
mvar RegValue sym Mem
MemImpl sym
mem

  failedAssert :: String -> String -> EvalM p sym ext rtp blocks ret args a
  failedAssert :: forall a. String -> String -> EvalM p sym ext rtp blocks ret args a
failedAssert String
msg String
details =
    IO a
-> StateT
     (SimState p sym ext rtp (CrucibleLang blocks ret) ('Just args))
     IO
     a
forall (m :: Type -> Type) a.
Monad m =>
m a
-> StateT
     (SimState p sym ext rtp (CrucibleLang blocks ret) ('Just args)) m a
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO a
 -> StateT
      (SimState p sym ext rtp (CrucibleLang blocks ret) ('Just args))
      IO
      a)
-> IO a
-> StateT
     (SimState p sym ext rtp (CrucibleLang blocks ret) ('Just args))
     IO
     a
forall a b. (a -> b) -> a -> b
$ bak -> SimErrorReason -> IO a
forall sym bak a.
IsSymBackend sym bak =>
bak -> SimErrorReason -> IO a
addFailedAssertion bak
bak (SimErrorReason -> IO a) -> SimErrorReason -> IO a
forall a b. (a -> b) -> a -> b
$ String -> String -> SimErrorReason
AssertFailureSimError String
msg String
details

  eval :: LLVMStmt (RegEntry sym) tp ->
          EvalM p sym ext rtp blocks ret args (RegValue sym tp)
  eval :: LLVMStmt (RegEntry sym) tp
-> EvalM p sym ext rtp blocks ret args (RegValue sym tp)
eval (LLVM_PushFrame Text
nm GlobalVar Mem
mvar) =
     do MemImpl sym
mem <- GlobalVar Mem -> EvalM p sym ext rtp blocks ret args (MemImpl sym)
getMem GlobalVar Mem
mvar
        let heap' :: Mem sym
heap' = Text -> Mem sym -> Mem sym
forall sym. Text -> Mem sym -> Mem sym
G.pushStackFrameMem Text
nm (MemImpl sym -> Mem sym
forall sym. MemImpl sym -> Mem sym
memImplHeap MemImpl sym
mem)
        GlobalVar Mem
-> MemImpl sym -> EvalM p sym ext rtp blocks ret args ()
setMem GlobalVar Mem
mvar MemImpl sym
mem{ memImplHeap = heap' }

  eval (LLVM_PopFrame GlobalVar Mem
mvar) =
     do MemImpl sym
mem <- GlobalVar Mem -> EvalM p sym ext rtp blocks ret args (MemImpl sym)
getMem GlobalVar Mem
mvar
        let heap' :: Mem sym
heap' = Mem sym -> Mem sym
forall sym. Mem sym -> Mem sym
G.popStackFrameMem (MemImpl sym -> Mem sym
forall sym. MemImpl sym -> Mem sym
memImplHeap MemImpl sym
mem)
        GlobalVar Mem
-> MemImpl sym -> EvalM p sym ext rtp blocks ret args ()
setMem GlobalVar Mem
mvar MemImpl sym
mem{ memImplHeap = heap' }

  eval (LLVM_Alloca NatRepr wptr
_w GlobalVar Mem
mvar (RegEntry sym (BVType wptr) -> RegValue sym (BVType wptr)
forall sym (tp :: CrucibleType). RegEntry sym tp -> RegValue sym tp
regValue -> RegValue sym (BVType wptr)
sz) Alignment
alignment String
loc) =
     do MemImpl sym
mem <- GlobalVar Mem -> EvalM p sym ext rtp blocks ret args (MemImpl sym)
getMem GlobalVar Mem
mvar
        (LLVMPointer sym wptr
ptr, MemImpl sym
mem') <- IO (LLVMPointer sym wptr, MemImpl sym)
-> StateT
     (SimState p sym ext rtp (CrucibleLang blocks ret) ('Just args))
     IO
     (LLVMPointer sym wptr, MemImpl sym)
forall a.
IO a
-> StateT
     (SimState p sym ext rtp (CrucibleLang blocks ret) ('Just args))
     IO
     a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (LLVMPointer sym wptr, MemImpl sym)
 -> StateT
      (SimState p sym ext rtp (CrucibleLang blocks ret) ('Just args))
      IO
      (LLVMPointer sym wptr, MemImpl sym))
-> IO (LLVMPointer sym wptr, MemImpl sym)
-> StateT
     (SimState p sym ext rtp (CrucibleLang blocks ret) ('Just args))
     IO
     (LLVMPointer sym wptr, MemImpl sym)
forall a b. (a -> b) -> a -> b
$ bak
-> MemImpl sym
-> SymBV sym wptr
-> Alignment
-> String
-> IO (LLVMPtr sym wptr, MemImpl sym)
forall sym bak (wptr :: Natural).
(IsSymBackend sym bak, HasPtrWidth wptr, HasLLVMAnn sym,
 ?memOpts::MemOptions) =>
bak
-> MemImpl sym
-> SymBV sym wptr
-> Alignment
-> String
-> IO (LLVMPtr sym wptr, MemImpl sym)
doAlloca bak
bak MemImpl sym
mem RegValue sym (BVType wptr)
SymBV sym wptr
sz Alignment
alignment String
loc
        GlobalVar Mem
-> MemImpl sym -> EvalM p sym ext rtp blocks ret args ()
setMem GlobalVar Mem
mvar MemImpl sym
mem'
        LLVMPointer sym wptr
-> StateT
     (SimState p sym ext rtp (CrucibleLang blocks ret) ('Just args))
     IO
     (LLVMPointer sym wptr)
forall a.
a
-> StateT
     (SimState p sym ext rtp (CrucibleLang blocks ret) ('Just args))
     IO
     a
forall (m :: Type -> Type) a. Monad m => a -> m a
return LLVMPointer sym wptr
ptr

  eval (LLVM_Load GlobalVar Mem
mvar (RegEntry sym (LLVMPointerType wptr)
-> RegValue sym (LLVMPointerType wptr)
forall sym (tp :: CrucibleType). RegEntry sym tp -> RegValue sym tp
regValue -> RegValue sym (LLVMPointerType wptr)
ptr) TypeRepr tp
tpr StorageType
valType Alignment
alignment) =
     do MemImpl sym
mem <- GlobalVar Mem -> EvalM p sym ext rtp blocks ret args (MemImpl sym)
getMem GlobalVar Mem
mvar
        IO (RegValue sym tp)
-> EvalM p sym ext rtp blocks ret args (RegValue sym tp)
forall a.
IO a
-> StateT
     (SimState p sym ext rtp (CrucibleLang blocks ret) ('Just args))
     IO
     a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (RegValue sym tp)
 -> EvalM p sym ext rtp blocks ret args (RegValue sym tp))
-> IO (RegValue sym tp)
-> EvalM p sym ext rtp blocks ret args (RegValue sym tp)
forall a b. (a -> b) -> a -> b
$ bak
-> MemImpl sym
-> RegValue sym (LLVMPointerType wptr)
-> StorageType
-> TypeRepr tp
-> Alignment
-> IO (RegValue sym tp)
forall sym bak (wptr :: Natural) (tp :: CrucibleType).
(IsSymBackend sym bak, HasPtrWidth wptr, HasLLVMAnn sym,
 ?memOpts::MemOptions) =>
bak
-> MemImpl sym
-> LLVMPtr sym wptr
-> StorageType
-> TypeRepr tp
-> Alignment
-> IO (RegValue sym tp)
doLoad bak
bak MemImpl sym
mem RegValue sym (LLVMPointerType wptr)
ptr StorageType
valType TypeRepr tp
tpr Alignment
alignment

  eval (LLVM_MemClear GlobalVar Mem
mvar (RegEntry sym (LLVMPointerType wptr)
-> RegValue sym (LLVMPointerType wptr)
forall sym (tp :: CrucibleType). RegEntry sym tp -> RegValue sym tp
regValue -> RegValue sym (LLVMPointerType wptr)
ptr) Bytes
bytes) =
    do MemImpl sym
mem <- GlobalVar Mem -> EvalM p sym ext rtp blocks ret args (MemImpl sym)
getMem GlobalVar Mem
mvar
       SymExpr sym (BaseBVType 8)
z   <- IO (SymExpr sym (BaseBVType 8))
-> StateT
     (SimState p sym ext rtp (CrucibleLang blocks ret) ('Just args))
     IO
     (SymExpr sym (BaseBVType 8))
forall a.
IO a
-> StateT
     (SimState p sym ext rtp (CrucibleLang blocks ret) ('Just args))
     IO
     a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (SymExpr sym (BaseBVType 8))
 -> StateT
      (SimState p sym ext rtp (CrucibleLang blocks ret) ('Just args))
      IO
      (SymExpr sym (BaseBVType 8)))
-> IO (SymExpr sym (BaseBVType 8))
-> StateT
     (SimState p sym ext rtp (CrucibleLang blocks ret) ('Just args))
     IO
     (SymExpr sym (BaseBVType 8))
forall a b. (a -> b) -> a -> b
$ sym -> NatRepr 8 -> IO (SymExpr sym (BaseBVType 8))
forall (w :: Natural) sym.
(1 <= w, IsExprBuilder sym) =>
sym -> NatRepr w -> IO (SymBV sym w)
bvZero sym
sym NatRepr 8
forall (n :: Natural). KnownNat n => NatRepr n
knownNat
       SymExpr sym (BaseBVType wptr)
len <- IO (SymExpr sym (BaseBVType wptr))
-> StateT
     (SimState p sym ext rtp (CrucibleLang blocks ret) ('Just args))
     IO
     (SymExpr sym (BaseBVType wptr))
forall a.
IO a
-> StateT
     (SimState p sym ext rtp (CrucibleLang blocks ret) ('Just args))
     IO
     a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (SymExpr sym (BaseBVType wptr))
 -> StateT
      (SimState p sym ext rtp (CrucibleLang blocks ret) ('Just args))
      IO
      (SymExpr sym (BaseBVType wptr)))
-> IO (SymExpr sym (BaseBVType wptr))
-> StateT
     (SimState p sym ext rtp (CrucibleLang blocks ret) ('Just args))
     IO
     (SymExpr sym (BaseBVType wptr))
forall a b. (a -> b) -> a -> b
$ sym
-> NatRepr wptr -> BV wptr -> IO (SymExpr sym (BaseBVType wptr))
forall (w :: Natural).
(1 <= w) =>
sym -> NatRepr w -> BV w -> IO (SymBV sym w)
forall sym (w :: Natural).
(IsExprBuilder sym, 1 <= w) =>
sym -> NatRepr w -> BV w -> IO (SymBV sym w)
bvLit sym
sym NatRepr wptr
forall (w :: Natural) (w' :: Natural).
(HasPtrWidth w, w ~ w') =>
NatRepr w'
PtrWidth (NatRepr wptr -> Bytes -> BV wptr
forall (w :: Natural). NatRepr w -> Bytes -> BV w
bytesToBV NatRepr wptr
forall (w :: Natural) (w' :: Natural).
(HasPtrWidth w, w ~ w') =>
NatRepr w'
PtrWidth Bytes
bytes)
       MemImpl sym
mem' <- IO (MemImpl sym)
-> EvalM p sym ext rtp blocks ret args (MemImpl sym)
forall a.
IO a
-> StateT
     (SimState p sym ext rtp (CrucibleLang blocks ret) ('Just args))
     IO
     a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (MemImpl sym)
 -> EvalM p sym ext rtp blocks ret args (MemImpl sym))
-> IO (MemImpl sym)
-> EvalM p sym ext rtp blocks ret args (MemImpl sym)
forall a b. (a -> b) -> a -> b
$ bak
-> NatRepr wptr
-> MemImpl sym
-> RegValue sym (LLVMPointerType wptr)
-> SymExpr sym (BaseBVType 8)
-> SymExpr sym (BaseBVType wptr)
-> IO (MemImpl sym)
forall (w :: Natural) sym bak (wptr :: Natural).
(1 <= w, IsSymBackend sym bak, HasPtrWidth wptr, HasLLVMAnn sym) =>
bak
-> NatRepr w
-> MemImpl sym
-> LLVMPtr sym wptr
-> SymBV sym 8
-> SymBV sym w
-> IO (MemImpl sym)
doMemset bak
bak NatRepr wptr
forall (w :: Natural) (w' :: Natural).
(HasPtrWidth w, w ~ w') =>
NatRepr w'
PtrWidth MemImpl sym
mem RegValue sym (LLVMPointerType wptr)
ptr SymExpr sym (BaseBVType 8)
z SymExpr sym (BaseBVType wptr)
len
       GlobalVar Mem
-> MemImpl sym -> EvalM p sym ext rtp blocks ret args ()
setMem GlobalVar Mem
mvar MemImpl sym
mem'

  eval (LLVM_Store GlobalVar Mem
mvar (RegEntry sym (LLVMPointerType wptr)
-> RegValue sym (LLVMPointerType wptr)
forall sym (tp :: CrucibleType). RegEntry sym tp -> RegValue sym tp
regValue -> RegValue sym (LLVMPointerType wptr)
ptr) TypeRepr tp
tpr StorageType
valType Alignment
alignment (RegEntry sym tp -> RegValue sym tp
forall sym (tp :: CrucibleType). RegEntry sym tp -> RegValue sym tp
regValue -> RegValue sym tp
val)) =
     do MemImpl sym
mem <- GlobalVar Mem -> EvalM p sym ext rtp blocks ret args (MemImpl sym)
getMem GlobalVar Mem
mvar
        MemImpl sym
mem' <- IO (MemImpl sym)
-> EvalM p sym ext rtp blocks ret args (MemImpl sym)
forall a.
IO a
-> StateT
     (SimState p sym ext rtp (CrucibleLang blocks ret) ('Just args))
     IO
     a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (MemImpl sym)
 -> EvalM p sym ext rtp blocks ret args (MemImpl sym))
-> IO (MemImpl sym)
-> EvalM p sym ext rtp blocks ret args (MemImpl sym)
forall a b. (a -> b) -> a -> b
$ bak
-> MemImpl sym
-> RegValue sym (LLVMPointerType wptr)
-> TypeRepr tp
-> StorageType
-> Alignment
-> RegValue sym tp
-> IO (MemImpl sym)
forall sym bak (wptr :: Natural) (tp :: CrucibleType).
(IsSymBackend sym bak, HasPtrWidth wptr, HasLLVMAnn sym,
 ?memOpts::MemOptions) =>
bak
-> MemImpl sym
-> LLVMPtr sym wptr
-> TypeRepr tp
-> StorageType
-> Alignment
-> RegValue sym tp
-> IO (MemImpl sym)
doStore bak
bak MemImpl sym
mem RegValue sym (LLVMPointerType wptr)
ptr TypeRepr tp
tpr StorageType
valType Alignment
alignment RegValue sym tp
val
        GlobalVar Mem
-> MemImpl sym -> EvalM p sym ext rtp blocks ret args ()
setMem GlobalVar Mem
mvar MemImpl sym
mem'

  eval (LLVM_LoadHandle GlobalVar Mem
mvar Maybe Type
ltp (RegEntry sym (LLVMPointerType wptr)
-> RegValue sym (LLVMPointerType wptr)
forall sym (tp :: CrucibleType). RegEntry sym tp -> RegValue sym tp
regValue -> RegValue sym (LLVMPointerType wptr)
ptr) CtxRepr args
args TypeRepr ret
ret) =
     do MemImpl sym
mem <- GlobalVar Mem -> EvalM p sym ext rtp blocks ret args (MemImpl sym)
getMem GlobalVar Mem
mvar
        let gsym :: Maybe String
gsym = Symbol -> String
unsymbol (Symbol -> String) -> Maybe Symbol -> Maybe String
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Natural Symbol
-> RegValue sym (LLVMPointerType wptr) -> Maybe Symbol
forall sym (w :: Natural).
IsSymInterface sym =>
Map Natural Symbol -> LLVMPtr sym w -> Maybe Symbol
isGlobalPointer (MemImpl sym -> Map Natural Symbol
forall sym. MemImpl sym -> Map Natural Symbol
memImplSymbolMap MemImpl sym
mem) RegValue sym (LLVMPointerType wptr)
ptr
        Either FuncLookupError SomeFnHandle
mhandle <- IO (Either FuncLookupError SomeFnHandle)
-> StateT
     (SimState p sym ext rtp (CrucibleLang blocks ret) ('Just args))
     IO
     (Either FuncLookupError SomeFnHandle)
forall a.
IO a
-> StateT
     (SimState p sym ext rtp (CrucibleLang blocks ret) ('Just args))
     IO
     a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (Either FuncLookupError SomeFnHandle)
 -> StateT
      (SimState p sym ext rtp (CrucibleLang blocks ret) ('Just args))
      IO
      (Either FuncLookupError SomeFnHandle))
-> IO (Either FuncLookupError SomeFnHandle)
-> StateT
     (SimState p sym ext rtp (CrucibleLang blocks ret) ('Just args))
     IO
     (Either FuncLookupError SomeFnHandle)
forall a b. (a -> b) -> a -> b
$ sym
-> MemImpl sym
-> RegValue sym (LLVMPointerType wptr)
-> IO (Either FuncLookupError SomeFnHandle)
forall a sym (wptr :: Natural).
(Typeable a, IsSymInterface sym) =>
sym
-> MemImpl sym -> LLVMPtr sym wptr -> IO (Either FuncLookupError a)
doLookupHandle sym
sym MemImpl sym
mem RegValue sym (LLVMPointerType wptr)
ptr
        let mop :: MemoryOp sym wptr
mop = Maybe Type
-> Maybe String
-> RegValue sym (LLVMPointerType wptr)
-> Mem sym
-> MemoryOp sym wptr
forall sym (w :: Natural).
Maybe Type
-> Maybe String -> LLVMPtr sym w -> Mem sym -> MemoryOp sym w
MemLoadHandleOp Maybe Type
ltp Maybe String
gsym RegValue sym (LLVMPointerType wptr)
ptr (MemImpl sym -> Mem sym
forall sym. MemImpl sym -> Mem sym
memImplHeap MemImpl sym
mem)
        let expectedTp :: TypeRepr ('FunctionHandleType args ret)
expectedTp = CtxRepr args
-> TypeRepr ret -> TypeRepr ('FunctionHandleType args ret)
forall (ctx :: Ctx CrucibleType) (ret :: CrucibleType).
CtxRepr ctx
-> TypeRepr ret -> TypeRepr ('FunctionHandleType ctx ret)
FunctionHandleRepr CtxRepr args
args TypeRepr ret
ret
        case Either FuncLookupError SomeFnHandle
mhandle of
           Left FuncLookupError
lookupErr -> IO (FnVal sym args ret)
-> StateT
     (SimState p sym ext rtp (CrucibleLang blocks ret) ('Just args))
     IO
     (FnVal sym args ret)
forall (m :: Type -> Type) a.
Monad m =>
m a
-> StateT
     (SimState p sym ext rtp (CrucibleLang blocks ret) ('Just args)) m a
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (FnVal sym args ret)
 -> StateT
      (SimState p sym ext rtp (CrucibleLang blocks ret) ('Just args))
      IO
      (FnVal sym args ret))
-> IO (FnVal sym args ret)
-> StateT
     (SimState p sym ext rtp (CrucibleLang blocks ret) ('Just args))
     IO
     (FnVal sym args ret)
forall a b. (a -> b) -> a -> b
$
             do SymExpr sym BaseBoolType
p <- sym
-> MemoryOp sym wptr
-> MemoryErrorReason
-> SymExpr sym BaseBoolType
-> IO (SymExpr sym BaseBoolType)
forall sym (w :: Natural).
(IsSymInterface sym, HasLLVMAnn sym, 1 <= w) =>
sym
-> MemoryOp sym w -> MemoryErrorReason -> Pred sym -> IO (Pred sym)
Partial.annotateME sym
sym MemoryOp sym wptr
mop (FuncLookupError -> MemoryErrorReason
BadFunctionPointer FuncLookupError
lookupErr) (sym -> SymExpr sym BaseBoolType
forall sym. IsExprBuilder sym => sym -> Pred sym
falsePred sym
sym)
                ProgramLoc
loc <- sym -> IO ProgramLoc
forall sym. IsExprBuilder sym => sym -> IO ProgramLoc
getCurrentProgramLoc sym
sym
                let err :: SimError
err = ProgramLoc -> SimErrorReason -> SimError
SimError ProgramLoc
loc (String -> String -> SimErrorReason
AssertFailureSimError String
"Failed to load function handle" (Doc Any -> String
forall a. Show a => a -> String
show (FuncLookupError -> Doc Any
forall ann. FuncLookupError -> Doc ann
ME.ppFuncLookupError FuncLookupError
lookupErr)))
                bak -> Assertion sym -> IO ()
forall sym bak.
IsSymBackend sym bak =>
bak -> Assertion sym -> IO ()
addProofObligation bak
bak (SymExpr sym BaseBoolType -> SimError -> Assertion sym
forall pred msg. pred -> msg -> LabeledPred pred msg
LabeledPred SymExpr sym BaseBoolType
p SimError
err)
                AbortExecReason -> IO (FnVal sym args ret)
forall a. AbortExecReason -> IO a
abortExecBecause (SimError -> AbortExecReason
AssertionFailure SimError
err)

           Right (VarargsFnHandle FnHandle (args ::> VectorType AnyType) ret
h) ->
             let err :: StateT
  (SimState p sym ext rtp (CrucibleLang blocks ret) ('Just args))
  IO
  (FnVal sym args ret)
err = String
-> String
-> StateT
     (SimState p sym ext rtp (CrucibleLang blocks ret) ('Just args))
     IO
     (FnVal sym args ret)
forall a. String -> String -> EvalM p sym ext rtp blocks ret args a
failedAssert String
"Failed to load function handle"
                  ([String] -> String
unlines
                   [String
"Expected function handle of type " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> TypeRepr ('FunctionHandleType args ret) -> String
forall a. Show a => a -> String
show TypeRepr ('FunctionHandleType args ret)
expectedTp
                   ,String
"for call to function " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> FunctionName -> String
forall a. Show a => a -> String
show (FnHandle (args ::> VectorType AnyType) ret -> FunctionName
forall (args :: Ctx CrucibleType) (ret :: CrucibleType).
FnHandle args ret -> FunctionName
handleName FnHandle (args ::> VectorType AnyType) ret
h)
                   ,String
"but found varargs handle of non-matching type " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TypeRepr (FunctionHandleType (args ::> VectorType AnyType) ret)
-> String
forall a. Show a => a -> String
show (FnHandle (args ::> VectorType AnyType) ret
-> TypeRepr (FunctionHandleType (args ::> VectorType AnyType) ret)
forall (args :: Ctx CrucibleType) (ret :: CrucibleType).
FnHandle args ret -> TypeRepr (FunctionHandleType args ret)
handleType FnHandle (args ::> VectorType AnyType) ret
h)
                   ]) in
             case FnHandle (args ::> VectorType AnyType) ret
-> CtxRepr (args ::> VectorType AnyType)
forall (args :: Ctx CrucibleType) (ret :: CrucibleType).
FnHandle args ret -> CtxRepr args
handleArgTypes FnHandle (args ::> VectorType AnyType) ret
h of
               Assignment TypeRepr ctx
prefix Ctx.:> VectorRepr TypeRepr tp1
AnyRepr
                 | Just ret :~: ret
Refl <- TypeRepr ret -> TypeRepr ret -> Maybe (ret :~: ret)
forall {k} (f :: k -> Type) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
forall (a :: CrucibleType) (b :: CrucibleType).
TypeRepr a -> TypeRepr b -> Maybe (a :~: b)
testEquality TypeRepr ret
ret (FnHandle (args ::> VectorType AnyType) ret -> TypeRepr ret
forall (args :: Ctx CrucibleType) (ret :: CrucibleType).
FnHandle args ret -> TypeRepr ret
handleReturnType FnHandle (args ::> VectorType AnyType) ret
h)
                 -> CtxRepr args
-> Assignment TypeRepr ctx
-> StateT
     (SimState p sym ext rtp (CrucibleLang blocks ret) ('Just args))
     IO
     (FnVal sym args ret)
-> (forall (addl :: Ctx CrucibleType).
    (args ~ (ctx <+> addl)) =>
    Assignment TypeRepr addl
    -> StateT
         (SimState p sym ext rtp (CrucibleLang blocks ret) ('Just args))
         IO
         (FnVal sym args ret))
-> StateT
     (SimState p sym ext rtp (CrucibleLang blocks ret) ('Just args))
     IO
     (FnVal sym args ret)
forall {k} (f :: k -> Type) (xs :: Ctx k) (prefix :: Ctx k) a.
TestEquality f =>
Assignment f xs
-> Assignment f prefix
-> a
-> (forall (addl :: Ctx k).
    (xs ~ (prefix <+> addl)) =>
    Assignment f addl -> a)
-> a
Ctx.dropPrefix CtxRepr args
args Assignment TypeRepr ctx
prefix StateT
  (SimState p sym ext rtp (CrucibleLang blocks ret) ('Just args))
  IO
  (FnVal sym args ret)
err (FnVal sym args ret
-> StateT
     (SimState p sym ext rtp (CrucibleLang blocks ret) ('Just args))
     IO
     (FnVal sym args ret)
forall a.
a
-> StateT
     (SimState p sym ext rtp (CrucibleLang blocks ret) ('Just args))
     IO
     a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (FnVal sym args ret
 -> StateT
      (SimState p sym ext rtp (CrucibleLang blocks ret) ('Just args))
      IO
      (FnVal sym args ret))
-> (Assignment TypeRepr addl -> FnVal sym args ret)
-> Assignment TypeRepr addl
-> StateT
     (SimState p sym ext rtp (CrucibleLang blocks ret) ('Just args))
     IO
     (FnVal sym args ret)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FnHandle (args ::> VectorType AnyType) ret
-> Assignment TypeRepr addl -> FnVal sym (args <+> addl) ret
forall (args1 :: Ctx CrucibleType) (res :: CrucibleType)
       (addlArgs :: Ctx CrucibleType) sym.
FnHandle (args1 ::> VectorType AnyType) res
-> CtxRepr addlArgs -> FnVal sym (args1 <+> addlArgs) res
VarargsFnVal FnHandle (args ::> VectorType AnyType) ret
h)

               CtxRepr (args ::> VectorType AnyType)
_ -> StateT
  (SimState p sym ext rtp (CrucibleLang blocks ret) ('Just args))
  IO
  (FnVal sym args ret)
err

           Right (SomeFnHandle FnHandle args ret
h)
             | Just FunctionHandleType args ret :~: 'FunctionHandleType args ret
Refl <- TypeRepr (FunctionHandleType args ret)
-> TypeRepr ('FunctionHandleType args ret)
-> Maybe
     (FunctionHandleType args ret :~: 'FunctionHandleType args ret)
forall {k} (f :: k -> Type) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
forall (a :: CrucibleType) (b :: CrucibleType).
TypeRepr a -> TypeRepr b -> Maybe (a :~: b)
testEquality (FnHandle args ret -> TypeRepr (FunctionHandleType args ret)
forall (args :: Ctx CrucibleType) (ret :: CrucibleType).
FnHandle args ret -> TypeRepr (FunctionHandleType args ret)
handleType FnHandle args ret
h) TypeRepr ('FunctionHandleType args ret)
expectedTp -> FnVal sym args ret
-> StateT
     (SimState p sym ext rtp (CrucibleLang blocks ret) ('Just args))
     IO
     (FnVal sym args ret)
forall a.
a
-> StateT
     (SimState p sym ext rtp (CrucibleLang blocks ret) ('Just args))
     IO
     a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (FnHandle args ret -> FnVal sym args ret
forall (args :: Ctx CrucibleType) (res :: CrucibleType) sym.
FnHandle args res -> FnVal sym args res
HandleFnVal FnHandle args ret
h)
             | Bool
otherwise -> String
-> String
-> StateT
     (SimState p sym ext rtp (CrucibleLang blocks ret) ('Just args))
     IO
     (FnVal sym args ret)
forall a. String -> String -> EvalM p sym ext rtp blocks ret args a
failedAssert
                 String
"Failed to load function handle"
                 ([String] -> String
unlines [String
"Expected function handle of type " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> TypeRepr ('FunctionHandleType args ret) -> String
forall a. Show a => a -> String
show TypeRepr ('FunctionHandleType args ret)
expectedTp
                          , String
"for call to function " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> FunctionName -> String
forall a. Show a => a -> String
show (FnHandle args ret -> FunctionName
forall (args :: Ctx CrucibleType) (ret :: CrucibleType).
FnHandle args ret -> FunctionName
handleName FnHandle args ret
h)
                          , String
"but found calling handle of type " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TypeRepr (FunctionHandleType args ret) -> String
forall a. Show a => a -> String
show (FnHandle args ret -> TypeRepr (FunctionHandleType args ret)
forall (args :: Ctx CrucibleType) (ret :: CrucibleType).
FnHandle args ret -> TypeRepr (FunctionHandleType args ret)
handleType FnHandle args ret
h)])

  eval (LLVM_ResolveGlobal NatRepr wptr
_w GlobalVar Mem
mvar (GlobalSymbol Symbol
symbol)) =
     do MemImpl sym
mem <- GlobalVar Mem -> EvalM p sym ext rtp blocks ret args (MemImpl sym)
getMem GlobalVar Mem
mvar
        IO (LLVMPointer sym wptr)
-> StateT
     (SimState p sym ext rtp (CrucibleLang blocks ret) ('Just args))
     IO
     (LLVMPointer sym wptr)
forall a.
IO a
-> StateT
     (SimState p sym ext rtp (CrucibleLang blocks ret) ('Just args))
     IO
     a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (LLVMPointer sym wptr)
 -> StateT
      (SimState p sym ext rtp (CrucibleLang blocks ret) ('Just args))
      IO
      (LLVMPointer sym wptr))
-> IO (LLVMPointer sym wptr)
-> StateT
     (SimState p sym ext rtp (CrucibleLang blocks ret) ('Just args))
     IO
     (LLVMPointer sym wptr)
forall a b. (a -> b) -> a -> b
$ bak -> MemImpl sym -> Symbol -> IO (LLVMPtr sym wptr)
forall sym bak (wptr :: Natural).
(IsSymBackend sym bak, HasPtrWidth wptr, HasCallStack) =>
bak -> MemImpl sym -> Symbol -> IO (LLVMPtr sym wptr)
doResolveGlobal bak
bak MemImpl sym
mem Symbol
symbol

  eval (LLVM_PtrEq GlobalVar Mem
mvar (RegEntry sym (LLVMPointerType wptr)
-> RegValue sym (LLVMPointerType wptr)
forall sym (tp :: CrucibleType). RegEntry sym tp -> RegValue sym tp
regValue -> RegValue sym (LLVMPointerType wptr)
x) (RegEntry sym (LLVMPointerType wptr)
-> RegValue sym (LLVMPointerType wptr)
forall sym (tp :: CrucibleType). RegEntry sym tp -> RegValue sym tp
regValue -> RegValue sym (LLVMPointerType wptr)
y)) = do
     MemImpl sym
mem <- GlobalVar Mem -> EvalM p sym ext rtp blocks ret args (MemImpl sym)
getMem GlobalVar Mem
mvar
     IO (SymExpr sym BaseBoolType)
-> StateT
     (SimState p sym ext rtp (CrucibleLang blocks ret) ('Just args))
     IO
     (SymExpr sym BaseBoolType)
forall a.
IO a
-> StateT
     (SimState p sym ext rtp (CrucibleLang blocks ret) ('Just args))
     IO
     a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (SymExpr sym BaseBoolType)
 -> StateT
      (SimState p sym ext rtp (CrucibleLang blocks ret) ('Just args))
      IO
      (SymExpr sym BaseBoolType))
-> IO (SymExpr sym BaseBoolType)
-> StateT
     (SimState p sym ext rtp (CrucibleLang blocks ret) ('Just args))
     IO
     (SymExpr sym BaseBoolType)
forall a b. (a -> b) -> a -> b
$ do
        SymExpr sym BaseBoolType
v1 <- sym
-> RegValue sym (LLVMPointerType wptr)
-> MemImpl sym
-> IO (SymExpr sym BaseBoolType)
forall sym (wptr :: Natural).
(IsSymInterface sym, HasPtrWidth wptr) =>
sym -> LLVMPtr sym wptr -> MemImpl sym -> IO (Pred sym)
isValidPointer sym
sym RegValue sym (LLVMPointerType wptr)
x MemImpl sym
mem
        SymExpr sym BaseBoolType
v2 <- sym
-> RegValue sym (LLVMPointerType wptr)
-> MemImpl sym
-> IO (SymExpr sym BaseBoolType)
forall sym (wptr :: Natural).
(IsSymInterface sym, HasPtrWidth wptr) =>
sym -> LLVMPtr sym wptr -> MemImpl sym -> IO (Pred sym)
isValidPointer sym
sym RegValue sym (LLVMPointerType wptr)
y MemImpl sym
mem
        SymExpr sym BaseBoolType
v3 <- sym
-> RegValue sym (LLVMPointerType wptr)
-> RegValue sym (LLVMPointerType wptr)
-> Mem sym
-> IO (SymExpr sym BaseBoolType)
forall sym (w :: Natural).
IsSymInterface sym =>
sym -> LLVMPtr sym w -> LLVMPtr sym w -> Mem sym -> IO (Pred sym)
G.notAliasable sym
sym RegValue sym (LLVMPointerType wptr)
x RegValue sym (LLVMPointerType wptr)
y (MemImpl sym -> Mem sym
forall sym. MemImpl sym -> Mem sym
memImplHeap MemImpl sym
mem)

        let callStack :: CallStack
callStack = MemState sym -> CallStack
forall sym. MemState sym -> CallStack
getCallStack (MemImpl sym
mem MemImpl sym
-> Getting (MemState sym) (MemImpl sym) (MemState sym)
-> MemState sym
forall s a. s -> Getting a s a -> a
^. (MemImpl sym -> Mem sym)
-> (Mem sym -> Const (MemState sym) (Mem sym))
-> MemImpl sym
-> Const (MemState sym) (MemImpl sym)
forall (p :: Type -> Type -> Type) (f :: Type -> Type) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to MemImpl sym -> Mem sym
forall sym. MemImpl sym -> Mem sym
memImplHeap ((Mem sym -> Const (MemState sym) (Mem sym))
 -> MemImpl sym -> Const (MemState sym) (MemImpl sym))
-> ((MemState sym -> Const (MemState sym) (MemState sym))
    -> Mem sym -> Const (MemState sym) (Mem sym))
-> Getting (MemState sym) (MemImpl sym) (MemState sym)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MemState sym -> Const (MemState sym) (MemState sym))
-> Mem sym -> Const (MemState sym) (Mem sym)
forall sym (f :: Type -> Type).
Functor f =>
(MemState sym -> f (MemState sym)) -> Mem sym -> f (Mem sym)
ML.memState)
        bak
-> CallStack
-> SymExpr sym BaseBoolType
-> UndefinedBehavior (RegValue' sym)
-> IO ()
forall sym bak.
(IsSymBackend sym bak, HasLLVMAnn sym) =>
bak
-> CallStack
-> Pred sym
-> UndefinedBehavior (RegValue' sym)
-> IO ()
assertUndefined bak
bak CallStack
callStack SymExpr sym BaseBoolType
v1 (UndefinedBehavior (RegValue' sym) -> IO ())
-> UndefinedBehavior (RegValue' sym) -> IO ()
forall a b. (a -> b) -> a -> b
$
          PtrComparisonOperator
-> RegValue' sym (LLVMPointerType wptr)
-> RegValue' sym (LLVMPointerType wptr)
-> UndefinedBehavior (RegValue' sym)
forall (w :: Natural) (e :: CrucibleType -> Type).
(1 <= w) =>
PtrComparisonOperator
-> e (LLVMPointerType w)
-> e (LLVMPointerType w)
-> UndefinedBehavior e
UB.CompareInvalidPointer PtrComparisonOperator
UB.Eq (RegValue sym (LLVMPointerType wptr)
-> RegValue' sym (LLVMPointerType wptr)
forall sym (tp :: CrucibleType).
RegValue sym tp -> RegValue' sym tp
RV RegValue sym (LLVMPointerType wptr)
x) (RegValue sym (LLVMPointerType wptr)
-> RegValue' sym (LLVMPointerType wptr)
forall sym (tp :: CrucibleType).
RegValue sym tp -> RegValue' sym tp
RV RegValue sym (LLVMPointerType wptr)
y)
        bak
-> CallStack
-> SymExpr sym BaseBoolType
-> UndefinedBehavior (RegValue' sym)
-> IO ()
forall sym bak.
(IsSymBackend sym bak, HasLLVMAnn sym) =>
bak
-> CallStack
-> Pred sym
-> UndefinedBehavior (RegValue' sym)
-> IO ()
assertUndefined bak
bak CallStack
callStack SymExpr sym BaseBoolType
v2 (UndefinedBehavior (RegValue' sym) -> IO ())
-> UndefinedBehavior (RegValue' sym) -> IO ()
forall a b. (a -> b) -> a -> b
$
          PtrComparisonOperator
-> RegValue' sym (LLVMPointerType wptr)
-> RegValue' sym (LLVMPointerType wptr)
-> UndefinedBehavior (RegValue' sym)
forall (w :: Natural) (e :: CrucibleType -> Type).
(1 <= w) =>
PtrComparisonOperator
-> e (LLVMPointerType w)
-> e (LLVMPointerType w)
-> UndefinedBehavior e
UB.CompareInvalidPointer PtrComparisonOperator
UB.Eq (RegValue sym (LLVMPointerType wptr)
-> RegValue' sym (LLVMPointerType wptr)
forall sym (tp :: CrucibleType).
RegValue sym tp -> RegValue' sym tp
RV RegValue sym (LLVMPointerType wptr)
x) (RegValue sym (LLVMPointerType wptr)
-> RegValue' sym (LLVMPointerType wptr)
forall sym (tp :: CrucibleType).
RegValue sym tp -> RegValue' sym tp
RV RegValue sym (LLVMPointerType wptr)
y)

        Bool -> IO () -> IO ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
unless (MemOptions -> Bool
laxConstantEquality ?memOpts::MemOptions
MemOptions
?memOpts) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
          do let allocs_doc :: Doc Any
allocs_doc = MemAllocs sym -> Doc Any
forall sym ann. IsExpr (SymExpr sym) => MemAllocs sym -> Doc ann
G.ppAllocs (Mem sym -> MemAllocs sym
forall sym. Mem sym -> MemAllocs sym
G.memAllocs (MemImpl sym -> Mem sym
forall sym. MemImpl sym -> Mem sym
memImplHeap MemImpl sym
mem))
             let x_doc :: Doc Any
x_doc = RegValue sym (LLVMPointerType wptr) -> Doc Any
forall sym (wptr :: Natural) ann.
IsExpr (SymExpr sym) =>
LLVMPtr sym wptr -> Doc ann
G.ppPtr RegValue sym (LLVMPointerType wptr)
x
             let y_doc :: Doc Any
y_doc = RegValue sym (LLVMPointerType wptr) -> Doc Any
forall sym (wptr :: Natural) ann.
IsExpr (SymExpr sym) =>
LLVMPtr sym wptr -> Doc ann
G.ppPtr RegValue sym (LLVMPointerType wptr)
y
             -- TODO: Is this undefined behavior? If so, add to the UB module
             bak -> SymExpr sym BaseBoolType -> SimErrorReason -> IO ()
forall sym bak.
IsSymBackend sym bak =>
bak -> Pred sym -> SimErrorReason -> IO ()
assert bak
bak SymExpr sym BaseBoolType
v3 (SimErrorReason -> IO ()) -> SimErrorReason -> IO ()
forall a b. (a -> b) -> a -> b
$
               String -> String -> SimErrorReason
AssertFailureSimError
               String
"Const pointers compared for equality"
               ([String] -> String
unlines [ Doc Any -> String
forall a. Show a => a -> String
show Doc Any
x_doc
                        , Doc Any -> String
forall a. Show a => a -> String
show Doc Any
y_doc
                        , Doc Any -> String
forall a. Show a => a -> String
show Doc Any
allocs_doc
                        ])
        sym
-> NatRepr wptr
-> RegValue sym (LLVMPointerType wptr)
-> RegValue sym (LLVMPointerType wptr)
-> IO (SymExpr sym BaseBoolType)
forall (w :: Natural) sym.
(1 <= w, IsSymInterface sym) =>
sym -> NatRepr w -> LLVMPtr sym w -> LLVMPtr sym w -> IO (Pred sym)
ptrEq sym
sym NatRepr wptr
forall (w :: Natural) (w' :: Natural).
(HasPtrWidth w, w ~ w') =>
NatRepr w'
PtrWidth RegValue sym (LLVMPointerType wptr)
x RegValue sym (LLVMPointerType wptr)
y

  eval (LLVM_PtrLe GlobalVar Mem
mvar (RegEntry sym (LLVMPointerType wptr)
-> RegValue sym (LLVMPointerType wptr)
forall sym (tp :: CrucibleType). RegEntry sym tp -> RegValue sym tp
regValue -> RegValue sym (LLVMPointerType wptr)
x) (RegEntry sym (LLVMPointerType wptr)
-> RegValue sym (LLVMPointerType wptr)
forall sym (tp :: CrucibleType). RegEntry sym tp -> RegValue sym tp
regValue -> RegValue sym (LLVMPointerType wptr)
y)) = do
    MemImpl sym
mem <- GlobalVar Mem -> EvalM p sym ext rtp blocks ret args (MemImpl sym)
getMem GlobalVar Mem
mvar
    IO (SymExpr sym BaseBoolType)
-> StateT
     (SimState p sym ext rtp (CrucibleLang blocks ret) ('Just args))
     IO
     (SymExpr sym BaseBoolType)
forall a.
IO a
-> StateT
     (SimState p sym ext rtp (CrucibleLang blocks ret) ('Just args))
     IO
     a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (SymExpr sym BaseBoolType)
 -> StateT
      (SimState p sym ext rtp (CrucibleLang blocks ret) ('Just args))
      IO
      (SymExpr sym BaseBoolType))
-> IO (SymExpr sym BaseBoolType)
-> StateT
     (SimState p sym ext rtp (CrucibleLang blocks ret) ('Just args))
     IO
     (SymExpr sym BaseBoolType)
forall a b. (a -> b) -> a -> b
$ do
       SymExpr sym BaseBoolType
v1 <- sym
-> RegValue sym (LLVMPointerType wptr)
-> MemImpl sym
-> IO (SymExpr sym BaseBoolType)
forall sym (wptr :: Natural).
(IsSymInterface sym, HasPtrWidth wptr) =>
sym -> LLVMPtr sym wptr -> MemImpl sym -> IO (Pred sym)
isValidPointer sym
sym RegValue sym (LLVMPointerType wptr)
x MemImpl sym
mem
       SymExpr sym BaseBoolType
v2 <- sym
-> RegValue sym (LLVMPointerType wptr)
-> MemImpl sym
-> IO (SymExpr sym BaseBoolType)
forall sym (wptr :: Natural).
(IsSymInterface sym, HasPtrWidth wptr) =>
sym -> LLVMPtr sym wptr -> MemImpl sym -> IO (Pred sym)
isValidPointer sym
sym RegValue sym (LLVMPointerType wptr)
y MemImpl sym
mem

       let callStack :: CallStack
callStack = MemState sym -> CallStack
forall sym. MemState sym -> CallStack
getCallStack (MemImpl sym
mem MemImpl sym
-> Getting (MemState sym) (MemImpl sym) (MemState sym)
-> MemState sym
forall s a. s -> Getting a s a -> a
^. (MemImpl sym -> Mem sym)
-> (Mem sym -> Const (MemState sym) (Mem sym))
-> MemImpl sym
-> Const (MemState sym) (MemImpl sym)
forall (p :: Type -> Type -> Type) (f :: Type -> Type) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to MemImpl sym -> Mem sym
forall sym. MemImpl sym -> Mem sym
memImplHeap ((Mem sym -> Const (MemState sym) (Mem sym))
 -> MemImpl sym -> Const (MemState sym) (MemImpl sym))
-> ((MemState sym -> Const (MemState sym) (MemState sym))
    -> Mem sym -> Const (MemState sym) (Mem sym))
-> Getting (MemState sym) (MemImpl sym) (MemState sym)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MemState sym -> Const (MemState sym) (MemState sym))
-> Mem sym -> Const (MemState sym) (Mem sym)
forall sym (f :: Type -> Type).
Functor f =>
(MemState sym -> f (MemState sym)) -> Mem sym -> f (Mem sym)
ML.memState)
       bak
-> CallStack
-> SymExpr sym BaseBoolType
-> UndefinedBehavior (RegValue' sym)
-> IO ()
forall sym bak.
(IsSymBackend sym bak, HasLLVMAnn sym) =>
bak
-> CallStack
-> Pred sym
-> UndefinedBehavior (RegValue' sym)
-> IO ()
assertUndefined bak
bak CallStack
callStack SymExpr sym BaseBoolType
v1
        (PtrComparisonOperator
-> RegValue' sym (LLVMPointerType wptr)
-> RegValue' sym (LLVMPointerType wptr)
-> UndefinedBehavior (RegValue' sym)
forall (w :: Natural) (e :: CrucibleType -> Type).
(1 <= w) =>
PtrComparisonOperator
-> e (LLVMPointerType w)
-> e (LLVMPointerType w)
-> UndefinedBehavior e
UB.CompareInvalidPointer PtrComparisonOperator
UB.Leq (RegValue sym (LLVMPointerType wptr)
-> RegValue' sym (LLVMPointerType wptr)
forall sym (tp :: CrucibleType).
RegValue sym tp -> RegValue' sym tp
RV RegValue sym (LLVMPointerType wptr)
x) (RegValue sym (LLVMPointerType wptr)
-> RegValue' sym (LLVMPointerType wptr)
forall sym (tp :: CrucibleType).
RegValue sym tp -> RegValue' sym tp
RV RegValue sym (LLVMPointerType wptr)
y))
       bak
-> CallStack
-> SymExpr sym BaseBoolType
-> UndefinedBehavior (RegValue' sym)
-> IO ()
forall sym bak.
(IsSymBackend sym bak, HasLLVMAnn sym) =>
bak
-> CallStack
-> Pred sym
-> UndefinedBehavior (RegValue' sym)
-> IO ()
assertUndefined bak
bak CallStack
callStack SymExpr sym BaseBoolType
v2
        (PtrComparisonOperator
-> RegValue' sym (LLVMPointerType wptr)
-> RegValue' sym (LLVMPointerType wptr)
-> UndefinedBehavior (RegValue' sym)
forall (w :: Natural) (e :: CrucibleType -> Type).
(1 <= w) =>
PtrComparisonOperator
-> e (LLVMPointerType w)
-> e (LLVMPointerType w)
-> UndefinedBehavior e
UB.CompareInvalidPointer PtrComparisonOperator
UB.Leq (RegValue sym (LLVMPointerType wptr)
-> RegValue' sym (LLVMPointerType wptr)
forall sym (tp :: CrucibleType).
RegValue sym tp -> RegValue' sym tp
RV RegValue sym (LLVMPointerType wptr)
x) (RegValue sym (LLVMPointerType wptr)
-> RegValue' sym (LLVMPointerType wptr)
forall sym (tp :: CrucibleType).
RegValue sym tp -> RegValue' sym tp
RV RegValue sym (LLVMPointerType wptr)
y))

       (SymExpr sym BaseBoolType
le, SymExpr sym BaseBoolType
valid) <- sym
-> NatRepr wptr
-> RegValue sym (LLVMPointerType wptr)
-> RegValue sym (LLVMPointerType wptr)
-> IO (SymExpr sym BaseBoolType, SymExpr sym BaseBoolType)
forall (w :: Natural) sym.
(1 <= w, IsSymInterface sym, ?memOpts::MemOptions) =>
sym
-> NatRepr w
-> LLVMPtr sym w
-> LLVMPtr sym w
-> IO (Pred sym, Pred sym)
ptrLe sym
sym NatRepr wptr
forall (w :: Natural) (w' :: Natural).
(HasPtrWidth w, w ~ w') =>
NatRepr w'
PtrWidth RegValue sym (LLVMPointerType wptr)
x RegValue sym (LLVMPointerType wptr)
y
       bak
-> CallStack
-> SymExpr sym BaseBoolType
-> UndefinedBehavior (RegValue' sym)
-> IO ()
forall sym bak.
(IsSymBackend sym bak, HasLLVMAnn sym) =>
bak
-> CallStack
-> Pred sym
-> UndefinedBehavior (RegValue' sym)
-> IO ()
assertUndefined bak
bak CallStack
callStack SymExpr sym BaseBoolType
valid
         (RegValue' sym (LLVMPointerType wptr)
-> RegValue' sym (LLVMPointerType wptr)
-> UndefinedBehavior (RegValue' sym)
forall (w :: Natural) (e :: CrucibleType -> Type).
(1 <= w) =>
e (LLVMPointerType w)
-> e (LLVMPointerType w) -> UndefinedBehavior e
UB.CompareDifferentAllocs (RegValue sym (LLVMPointerType wptr)
-> RegValue' sym (LLVMPointerType wptr)
forall sym (tp :: CrucibleType).
RegValue sym tp -> RegValue' sym tp
RV RegValue sym (LLVMPointerType wptr)
x) (RegValue sym (LLVMPointerType wptr)
-> RegValue' sym (LLVMPointerType wptr)
forall sym (tp :: CrucibleType).
RegValue sym tp -> RegValue' sym tp
RV RegValue sym (LLVMPointerType wptr)
y))

       SymExpr sym BaseBoolType -> IO (SymExpr sym BaseBoolType)
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure SymExpr sym BaseBoolType
le

  eval (LLVM_PtrAddOffset NatRepr wptr
_w GlobalVar Mem
mvar (RegEntry
  sym ('IntrinsicType "LLVM_pointer" ('EmptyCtx ::> BVType wptr))
-> RegValue
     sym ('IntrinsicType "LLVM_pointer" ('EmptyCtx ::> BVType wptr))
forall sym (tp :: CrucibleType). RegEntry sym tp -> RegValue sym tp
regValue -> RegValue
  sym ('IntrinsicType "LLVM_pointer" ('EmptyCtx ::> BVType wptr))
x) (RegEntry sym (BVType wptr) -> RegValue sym (BVType wptr)
forall sym (tp :: CrucibleType). RegEntry sym tp -> RegValue sym tp
regValue -> RegValue sym (BVType wptr)
y)) =
    do MemImpl sym
mem <- GlobalVar Mem -> EvalM p sym ext rtp blocks ret args (MemImpl sym)
getMem GlobalVar Mem
mvar
       IO (LLVMPointer sym wptr)
-> StateT
     (SimState p sym ext rtp (CrucibleLang blocks ret) ('Just args))
     IO
     (LLVMPointer sym wptr)
forall a.
IO a
-> StateT
     (SimState p sym ext rtp (CrucibleLang blocks ret) ('Just args))
     IO
     a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (LLVMPointer sym wptr)
 -> StateT
      (SimState p sym ext rtp (CrucibleLang blocks ret) ('Just args))
      IO
      (LLVMPointer sym wptr))
-> IO (LLVMPointer sym wptr)
-> StateT
     (SimState p sym ext rtp (CrucibleLang blocks ret) ('Just args))
     IO
     (LLVMPointer sym wptr)
forall a b. (a -> b) -> a -> b
$ bak
-> MemImpl sym
-> RegValue
     sym ('IntrinsicType "LLVM_pointer" ('EmptyCtx ::> BVType wptr))
-> SymBV sym wptr
-> IO
     (RegValue
        sym ('IntrinsicType "LLVM_pointer" ('EmptyCtx ::> BVType wptr)))
forall sym bak (wptr :: Natural).
(IsSymBackend sym bak, HasPtrWidth wptr, HasLLVMAnn sym,
 ?memOpts::MemOptions) =>
bak
-> MemImpl sym
-> LLVMPtr sym wptr
-> SymBV sym wptr
-> IO (LLVMPtr sym wptr)
doPtrAddOffset bak
bak MemImpl sym
mem RegValue
  sym ('IntrinsicType "LLVM_pointer" ('EmptyCtx ::> BVType wptr))
x RegValue sym (BVType wptr)
SymBV sym wptr
y

  eval (LLVM_PtrSubtract NatRepr wptr
_w GlobalVar Mem
mvar (RegEntry sym (LLVMPointerType wptr)
-> RegValue sym (LLVMPointerType wptr)
forall sym (tp :: CrucibleType). RegEntry sym tp -> RegValue sym tp
regValue -> RegValue sym (LLVMPointerType wptr)
x) (RegEntry sym (LLVMPointerType wptr)
-> RegValue sym (LLVMPointerType wptr)
forall sym (tp :: CrucibleType). RegEntry sym tp -> RegValue sym tp
regValue -> RegValue sym (LLVMPointerType wptr)
y)) =
    do MemImpl sym
mem <- GlobalVar Mem -> EvalM p sym ext rtp blocks ret args (MemImpl sym)
getMem GlobalVar Mem
mvar
       IO (SymExpr sym (BaseBVType wptr))
-> StateT
     (SimState p sym ext rtp (CrucibleLang blocks ret) ('Just args))
     IO
     (SymExpr sym (BaseBVType wptr))
forall a.
IO a
-> StateT
     (SimState p sym ext rtp (CrucibleLang blocks ret) ('Just args))
     IO
     a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (SymExpr sym (BaseBVType wptr))
 -> StateT
      (SimState p sym ext rtp (CrucibleLang blocks ret) ('Just args))
      IO
      (SymExpr sym (BaseBVType wptr)))
-> IO (SymExpr sym (BaseBVType wptr))
-> StateT
     (SimState p sym ext rtp (CrucibleLang blocks ret) ('Just args))
     IO
     (SymExpr sym (BaseBVType wptr))
forall a b. (a -> b) -> a -> b
$ bak
-> MemImpl sym
-> RegValue sym (LLVMPointerType wptr)
-> RegValue sym (LLVMPointerType wptr)
-> IO (SymExpr sym (BaseBVType wptr))
forall sym bak (wptr :: Natural).
(IsSymBackend sym bak, HasPtrWidth wptr, HasLLVMAnn sym) =>
bak
-> MemImpl sym
-> LLVMPtr sym wptr
-> LLVMPtr sym wptr
-> IO (SymBV sym wptr)
doPtrSubtract bak
bak MemImpl sym
mem RegValue sym (LLVMPointerType wptr)
x RegValue sym (LLVMPointerType wptr)
y

  eval LLVM_Debug{} = () -> EvalM p sym ext rtp blocks ret args ()
forall a.
a
-> StateT
     (SimState p sym ext rtp (CrucibleLang blocks ret) ('Just args))
     IO
     a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ()


mkMemVar :: Text
         -> HandleAllocator
         -> IO (GlobalVar Mem)
mkMemVar :: Text -> HandleAllocator -> IO (GlobalVar Mem)
mkMemVar Text
memName HandleAllocator
halloc = HandleAllocator -> Text -> TypeRepr Mem -> IO (GlobalVar Mem)
forall (tp :: CrucibleType).
HandleAllocator -> Text -> TypeRepr tp -> IO (GlobalVar tp)
freshGlobalVar HandleAllocator
halloc Text
memName TypeRepr Mem
forall k (f :: k -> Type) (ctx :: k). KnownRepr f ctx => f ctx
knownRepr


-- | For now, the core message should be on the first line, with details
-- on further lines. Later we should make it more structured.
ptrMessage ::
  (IsSymInterface sym) =>
  String ->
  LLVMPtr sym wptr {- ^ pointer involved in message -} ->
  StorageType      {- ^ type of value pointed to    -} ->
  String
ptrMessage :: forall sym (wptr :: Natural).
IsSymInterface sym =>
String -> LLVMPtr sym wptr -> StorageType -> String
ptrMessage String
msg LLVMPtr sym wptr
ptr StorageType
ty =
  [String] -> String
unlines [ String
msg
          , String
"  address " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Doc Any -> String
forall a. Show a => a -> String
show (LLVMPtr sym wptr -> Doc Any
forall sym (wptr :: Natural) ann.
IsExpr (SymExpr sym) =>
LLVMPtr sym wptr -> Doc ann
G.ppPtr LLVMPtr sym wptr
ptr)
          , String
"  at type " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Doc Any -> String
forall a. Show a => a -> String
show (StorageType -> Doc Any
forall ann. StorageType -> Doc ann
G.ppType StorageType
ty)
          ]

-- | Allocate memory on the stack frame of the currently executing function.
doAlloca ::
  ( IsSymBackend sym bak, HasPtrWidth wptr, Partial.HasLLVMAnn sym
  , ?memOpts :: MemOptions ) =>
  bak ->
  MemImpl sym ->
  SymBV sym wptr {- ^ allocation size -} ->
  Alignment      {- ^ pointer alignment -} ->
  String         {- ^ source location for use in error messages -} ->
  IO (LLVMPtr sym wptr, MemImpl sym)
doAlloca :: forall sym bak (wptr :: Natural).
(IsSymBackend sym bak, HasPtrWidth wptr, HasLLVMAnn sym,
 ?memOpts::MemOptions) =>
bak
-> MemImpl sym
-> SymBV sym wptr
-> Alignment
-> String
-> IO (LLVMPtr sym wptr, MemImpl sym)
doAlloca bak
bak MemImpl sym
mem SymBV sym wptr
sz Alignment
alignment String
loc = do
  let sym :: sym
sym = bak -> sym
forall sym bak. HasSymInterface sym bak => bak -> sym
backendGetSym bak
bak
  Natural
blkNum <- IO Natural -> IO Natural
forall a. IO a -> IO a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO Natural -> IO Natural) -> IO Natural -> IO Natural
forall a b. (a -> b) -> a -> b
$ BlockSource -> IO Natural
nextBlock (MemImpl sym -> BlockSource
forall sym. MemImpl sym -> BlockSource
memImplBlockSource MemImpl sym
mem)
  SymNat sym
blk <- IO (SymNat sym) -> IO (SymNat sym)
forall a. IO a -> IO a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (SymNat sym) -> IO (SymNat sym))
-> IO (SymNat sym) -> IO (SymNat sym)
forall a b. (a -> b) -> a -> b
$ sym -> Natural -> IO (SymNat sym)
forall sym. IsExprBuilder sym => sym -> Natural -> IO (SymNat sym)
natLit sym
sym Natural
blkNum
  SymBV sym wptr
z <- IO (SymBV sym wptr) -> IO (SymBV sym wptr)
forall a. IO a -> IO a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (SymBV sym wptr) -> IO (SymBV sym wptr))
-> IO (SymBV sym wptr) -> IO (SymBV sym wptr)
forall a b. (a -> b) -> a -> b
$ sym -> NatRepr wptr -> IO (SymBV sym wptr)
forall (w :: Natural) sym.
(1 <= w, IsExprBuilder sym) =>
sym -> NatRepr w -> IO (SymBV sym w)
bvZero sym
sym NatRepr wptr
forall (w :: Natural) (w' :: Natural).
(HasPtrWidth w, w ~ w') =>
NatRepr w'
PtrWidth

  let heap' :: Mem sym
heap' = AllocType
-> Natural
-> Maybe (SymBV sym wptr)
-> Alignment
-> Mutability
-> String
-> Mem sym
-> Mem sym
forall (w :: Natural) sym.
(1 <= w) =>
AllocType
-> Natural
-> Maybe (SymBV sym w)
-> Alignment
-> Mutability
-> String
-> Mem sym
-> Mem sym
G.allocMem AllocType
G.StackAlloc Natural
blkNum (SymBV sym wptr -> Maybe (SymBV sym wptr)
forall a. a -> Maybe a
Just SymBV sym wptr
sz) Alignment
alignment Mutability
G.Mutable String
loc (MemImpl sym -> Mem sym
forall sym. MemImpl sym -> Mem sym
memImplHeap MemImpl sym
mem)
  let ptr :: LLVMPointer sym wptr
ptr   = SymNat sym -> SymBV sym wptr -> LLVMPointer sym wptr
forall sym (w :: Natural).
SymNat sym -> SymBV sym w -> LLVMPointer sym w
LLVMPointer SymNat sym
blk SymBV sym wptr
z
  let mem' :: MemImpl sym
mem'  = MemImpl sym
mem{ memImplHeap = heap' }
  MemImpl sym
mem'' <- if MemOptions -> Bool
laxLoadsAndStores ?memOpts::MemOptions
MemOptions
?memOpts
                Bool -> Bool -> Bool
&& MemOptions -> IndeterminateLoadBehavior
indeterminateLoadBehavior ?memOpts::MemOptions
MemOptions
?memOpts IndeterminateLoadBehavior -> IndeterminateLoadBehavior -> Bool
forall a. Eq a => a -> a -> Bool
== IndeterminateLoadBehavior
StableSymbolic
           then bak
-> MemImpl sym
-> LLVMPtr sym wptr
-> Maybe (SymBV sym wptr)
-> Alignment
-> IO (MemImpl sym)
forall sym bak (wptr :: Natural).
(IsSymBackend sym bak, HasPtrWidth wptr, HasLLVMAnn sym) =>
bak
-> MemImpl sym
-> LLVMPtr sym wptr
-> Maybe (SymBV sym wptr)
-> Alignment
-> IO (MemImpl sym)
doConstStoreStableSymbolic bak
bak MemImpl sym
mem' LLVMPtr sym wptr
LLVMPointer sym wptr
ptr (SymBV sym wptr -> Maybe (SymBV sym wptr)
forall a. a -> Maybe a
Just SymBV sym wptr
sz) Alignment
alignment
           else MemImpl sym -> IO (MemImpl sym)
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure MemImpl sym
mem'
  (LLVMPointer sym wptr, MemImpl sym)
-> IO (LLVMPointer sym wptr, MemImpl sym)
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (LLVMPointer sym wptr
ptr, MemImpl sym
mem'')

-- | Load a 'RegValue' from memory. Both the 'StorageType' and 'TypeRepr'
-- arguments should be computed from a single 'MemType' using
-- 'toStorableType' and 'Lang.Crucible.LLVM.Translation.Types.llvmTypeAsRepr'
-- respectively.
--
-- Precondition: the pointer is valid and aligned, and the loaded value is defined.
doLoad ::
  ( IsSymBackend sym bak, HasPtrWidth wptr, Partial.HasLLVMAnn sym
  , ?memOpts :: MemOptions ) =>
  bak ->
  MemImpl sym ->
  LLVMPtr sym wptr {- ^ pointer to load from      -} ->
  StorageType      {- ^ type of value to load     -} ->
  TypeRepr tp      {- ^ crucible type of the result -} ->
  Alignment        {- ^ assumed pointer alignment -} ->
  IO (RegValue sym tp)
doLoad :: forall sym bak (wptr :: Natural) (tp :: CrucibleType).
(IsSymBackend sym bak, HasPtrWidth wptr, HasLLVMAnn sym,
 ?memOpts::MemOptions) =>
bak
-> MemImpl sym
-> LLVMPtr sym wptr
-> StorageType
-> TypeRepr tp
-> Alignment
-> IO (RegValue sym tp)
doLoad bak
bak MemImpl sym
mem LLVMPtr sym wptr
ptr StorageType
valType TypeRepr tp
tpr Alignment
alignment = do
  let sym :: sym
sym = bak -> sym
forall sym bak. HasSymInterface sym bak => bak -> sym
backendGetSym bak
bak
  sym -> TypeRepr tp -> LLVMVal sym -> IO (RegValue sym tp)
forall sym (tp :: CrucibleType).
(HasCallStack, IsSymInterface sym) =>
sym -> TypeRepr tp -> LLVMVal sym -> IO (RegValue sym tp)
unpackMemValue sym
sym TypeRepr tp
tpr (LLVMVal sym -> IO (RegValue sym tp))
-> IO (LLVMVal sym) -> IO (RegValue sym tp)
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<<
    bak -> PartLLVMVal sym -> IO (LLVMVal sym)
forall sym bak.
IsSymBackend sym bak =>
bak -> PartLLVMVal sym -> IO (LLVMVal sym)
Partial.assertSafe bak
bak (PartLLVMVal sym -> IO (LLVMVal sym))
-> IO (PartLLVMVal sym) -> IO (LLVMVal sym)
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<<
      sym
-> MemImpl sym
-> LLVMPtr sym wptr
-> StorageType
-> Alignment
-> IO (PartLLVMVal sym)
forall sym (wptr :: Natural).
(IsSymInterface sym, HasPtrWidth wptr, HasLLVMAnn sym,
 ?memOpts::MemOptions) =>
sym
-> MemImpl sym
-> LLVMPtr sym wptr
-> StorageType
-> Alignment
-> IO (PartLLVMVal sym)
loadRaw sym
sym MemImpl sym
mem LLVMPtr sym wptr
ptr StorageType
valType Alignment
alignment

-- | Store a 'RegValue' in memory. Both the 'StorageType' and 'TypeRepr'
-- arguments should be computed from a single 'MemType' using
-- 'toStorableType' and 'Lang.Crucible.LLVM.Translation.Types.llvmTypeAsRepr'
-- respectively.
--
-- Precondition: the pointer is valid and points to a mutable memory region.
doStore ::
  ( IsSymBackend sym bak
  , HasPtrWidth wptr
  , Partial.HasLLVMAnn sym
  , ?memOpts :: MemOptions ) =>
  bak ->
  MemImpl sym ->
  LLVMPtr sym wptr {- ^ pointer to store into  -} ->
  TypeRepr tp ->
  StorageType      {- ^ type of value to store -} ->
  Alignment ->
  RegValue sym tp  {- ^ value to store         -} ->
  IO (MemImpl sym)
doStore :: forall sym bak (wptr :: Natural) (tp :: CrucibleType).
(IsSymBackend sym bak, HasPtrWidth wptr, HasLLVMAnn sym,
 ?memOpts::MemOptions) =>
bak
-> MemImpl sym
-> LLVMPtr sym wptr
-> TypeRepr tp
-> StorageType
-> Alignment
-> RegValue sym tp
-> IO (MemImpl sym)
doStore bak
bak MemImpl sym
mem LLVMPtr sym wptr
ptr TypeRepr tp
tpr StorageType
valType Alignment
alignment RegValue sym tp
val = do
    --putStrLn "MEM STORE"
    let sym :: sym
sym = bak -> sym
forall sym bak. HasSymInterface sym bak => bak -> sym
backendGetSym bak
bak
    LLVMVal sym
val' <- sym
-> StorageType
-> TypeRepr tp
-> RegValue sym tp
-> IO (LLVMVal sym)
forall sym (tp :: CrucibleType).
IsSymInterface sym =>
sym
-> StorageType
-> TypeRepr tp
-> RegValue sym tp
-> IO (LLVMVal sym)
packMemValue sym
sym StorageType
valType TypeRepr tp
tpr RegValue sym tp
val
    bak
-> MemImpl sym
-> LLVMPtr sym wptr
-> StorageType
-> Alignment
-> LLVMVal sym
-> IO (MemImpl sym)
forall sym bak (wptr :: Natural).
(IsSymBackend sym bak, HasPtrWidth wptr, HasLLVMAnn sym,
 ?memOpts::MemOptions) =>
bak
-> MemImpl sym
-> LLVMPtr sym wptr
-> StorageType
-> Alignment
-> LLVMVal sym
-> IO (MemImpl sym)
storeRaw bak
bak MemImpl sym
mem LLVMPtr sym wptr
ptr StorageType
valType Alignment
alignment LLVMVal sym
val'

data SomeFnHandle where
  SomeFnHandle    :: FnHandle args ret -> SomeFnHandle
  VarargsFnHandle :: FnHandle (args ::> VectorType AnyType) ret -> SomeFnHandle

-- | Allocate and zero a memory region with /size * number/ bytes.
--
-- Precondition: the multiplication /size * number/ does not overflow.
doCalloc ::
  ( IsSymBackend sym bak, HasPtrWidth wptr, Partial.HasLLVMAnn sym
  , ?memOpts :: MemOptions ) =>
  bak ->
  MemImpl sym ->
  SymBV sym wptr {- ^ size   -} ->
  SymBV sym wptr {- ^ number -} ->
  Alignment {- ^ Minimum alignment of the resulting allocation -} ->
  IO (LLVMPtr sym wptr, MemImpl sym)
doCalloc :: forall sym bak (wptr :: Natural).
(IsSymBackend sym bak, HasPtrWidth wptr, HasLLVMAnn sym,
 ?memOpts::MemOptions) =>
bak
-> MemImpl sym
-> SymBV sym wptr
-> SymBV sym wptr
-> Alignment
-> IO (LLVMPtr sym wptr, MemImpl sym)
doCalloc bak
bak MemImpl sym
mem SymBV sym wptr
sz SymBV sym wptr
num Alignment
alignment = do
  let sym :: sym
sym = bak -> sym
forall sym bak. HasSymInterface sym bak => bak -> sym
backendGetSym bak
bak
  (SymBV sym wptr
ov, SymBV sym wptr
sz') <- sym
-> SymBV sym wptr
-> SymBV sym wptr
-> IO (SymBV sym wptr, SymBV sym wptr)
forall (w :: Natural).
(1 <= w) =>
sym -> SymBV sym w -> SymBV sym w -> IO (SymBV sym w, SymBV sym w)
forall sym (w :: Natural).
(IsExprBuilder sym, 1 <= w) =>
sym -> SymBV sym w -> SymBV sym w -> IO (SymBV sym w, SymBV sym w)
unsignedWideMultiplyBV sym
sym SymBV sym wptr
sz SymBV sym wptr
num
  SymExpr sym BaseBoolType
ov_iszero <- sym -> SymExpr sym BaseBoolType -> IO (SymExpr sym BaseBoolType)
forall sym. IsExprBuilder sym => sym -> Pred sym -> IO (Pred sym)
notPred sym
sym (SymExpr sym BaseBoolType -> IO (SymExpr sym BaseBoolType))
-> IO (SymExpr sym BaseBoolType) -> IO (SymExpr sym BaseBoolType)
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< sym -> SymBV sym wptr -> IO (SymExpr sym BaseBoolType)
forall (w :: Natural).
(1 <= w) =>
sym -> SymBV sym w -> IO (SymExpr sym BaseBoolType)
forall sym (w :: Natural).
(IsExprBuilder sym, 1 <= w) =>
sym -> SymBV sym w -> IO (Pred sym)
bvIsNonzero sym
sym SymBV sym wptr
ov
  -- TODO, this probably shouldn't be UB
  bak -> SymExpr sym BaseBoolType -> SimErrorReason -> IO ()
forall sym bak.
IsSymBackend sym bak =>
bak -> Pred sym -> SimErrorReason -> IO ()
assert bak
bak SymExpr sym BaseBoolType
ov_iszero
     (String -> String -> SimErrorReason
AssertFailureSimError String
"Multiplication overflow in calloc()" String
"")

  Position
loc <- ProgramLoc -> Position
plSourceLoc (ProgramLoc -> Position) -> IO ProgramLoc -> IO Position
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> sym -> IO ProgramLoc
forall sym. IsExprBuilder sym => sym -> IO ProgramLoc
getCurrentProgramLoc sym
sym
  let displayString :: String
displayString = String
"<calloc> " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Position -> String
forall a. Show a => a -> String
show Position
loc
  SymExpr sym (BaseBVType 8)
z <- sym -> NatRepr 8 -> IO (SymExpr sym (BaseBVType 8))
forall (w :: Natural) sym.
(1 <= w, IsExprBuilder sym) =>
sym -> NatRepr w -> IO (SymBV sym w)
bvZero sym
sym NatRepr 8
forall (n :: Natural). KnownNat n => NatRepr n
knownNat
  (LLVMPointer sym wptr
ptr, MemImpl sym
mem') <- bak
-> AllocType
-> Mutability
-> String
-> MemImpl sym
-> SymBV sym wptr
-> Alignment
-> IO (LLVMPtr sym wptr, MemImpl sym)
forall sym bak (wptr :: Natural).
(IsSymBackend sym bak, HasPtrWidth wptr, HasLLVMAnn sym,
 ?memOpts::MemOptions) =>
bak
-> AllocType
-> Mutability
-> String
-> MemImpl sym
-> SymBV sym wptr
-> Alignment
-> IO (LLVMPtr sym wptr, MemImpl sym)
doMalloc bak
bak AllocType
G.HeapAlloc Mutability
G.Mutable String
displayString MemImpl sym
mem SymBV sym wptr
sz' Alignment
alignment
  MemImpl sym
mem'' <- bak
-> NatRepr wptr
-> MemImpl sym
-> LLVMPtr sym wptr
-> SymExpr sym (BaseBVType 8)
-> SymBV sym wptr
-> IO (MemImpl sym)
forall (w :: Natural) sym bak (wptr :: Natural).
(1 <= w, IsSymBackend sym bak, HasPtrWidth wptr, HasLLVMAnn sym) =>
bak
-> NatRepr w
-> MemImpl sym
-> LLVMPtr sym wptr
-> SymBV sym 8
-> SymBV sym w
-> IO (MemImpl sym)
doMemset bak
bak NatRepr wptr
forall (w :: Natural) (w' :: Natural).
(HasPtrWidth w, w ~ w') =>
NatRepr w'
PtrWidth MemImpl sym
mem' LLVMPtr sym wptr
LLVMPointer sym wptr
ptr SymExpr sym (BaseBVType 8)
z SymBV sym wptr
sz'
  (LLVMPointer sym wptr, MemImpl sym)
-> IO (LLVMPointer sym wptr, MemImpl sym)
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (LLVMPointer sym wptr
ptr, MemImpl sym
mem'')

-- | Allocate a memory region.
doMalloc
  :: ( IsSymBackend sym bak, HasPtrWidth wptr, Partial.HasLLVMAnn sym
     , ?memOpts :: MemOptions )
  => bak
  -> G.AllocType {- ^ stack, heap, or global -}
  -> G.Mutability {- ^ whether region is read-only -}
  -> String {- ^ source location for use in error messages -}
  -> MemImpl sym
  -> SymBV sym wptr {- ^ allocation size -}
  -> Alignment
  -> IO (LLVMPtr sym wptr, MemImpl sym)
doMalloc :: forall sym bak (wptr :: Natural).
(IsSymBackend sym bak, HasPtrWidth wptr, HasLLVMAnn sym,
 ?memOpts::MemOptions) =>
bak
-> AllocType
-> Mutability
-> String
-> MemImpl sym
-> SymBV sym wptr
-> Alignment
-> IO (LLVMPtr sym wptr, MemImpl sym)
doMalloc bak
bak AllocType
allocType Mutability
mut String
loc MemImpl sym
mem SymBV sym wptr
sz Alignment
alignment = Maybe (SymBV sym wptr)
-> bak
-> AllocType
-> Mutability
-> String
-> MemImpl sym
-> Alignment
-> IO
     (RegValue
        sym (IntrinsicType "LLVM_pointer" ('EmptyCtx '::> BVType wptr)),
      MemImpl sym)
forall sym bak (wptr :: Natural).
(IsSymBackend sym bak, HasPtrWidth wptr, HasLLVMAnn sym,
 ?memOpts::MemOptions) =>
Maybe (SymBV sym wptr)
-> bak
-> AllocType
-> Mutability
-> String
-> MemImpl sym
-> Alignment
-> IO (LLVMPtr sym wptr, MemImpl sym)
doMallocSize (SymBV sym wptr -> Maybe (SymBV sym wptr)
forall a. a -> Maybe a
Just SymBV sym wptr
sz) bak
bak AllocType
allocType Mutability
mut String
loc MemImpl sym
mem Alignment
alignment

-- | Allocate a memory region of unbounded size.
doMallocUnbounded
  :: ( IsSymBackend sym bak, HasPtrWidth wptr, Partial.HasLLVMAnn sym
     , ?memOpts :: MemOptions )
  => bak
  -> G.AllocType {- ^ stack, heap, or global -}
  -> G.Mutability {- ^ whether region is read-only -}
  -> String {- ^ source location for use in error messages -}
  -> MemImpl sym
  -> Alignment
  -> IO (LLVMPtr sym wptr, MemImpl sym)
doMallocUnbounded :: forall sym bak (wptr :: Natural).
(IsSymBackend sym bak, HasPtrWidth wptr, HasLLVMAnn sym,
 ?memOpts::MemOptions) =>
bak
-> AllocType
-> Mutability
-> String
-> MemImpl sym
-> Alignment
-> IO (LLVMPtr sym wptr, MemImpl sym)
doMallocUnbounded = Maybe (SymBV sym wptr)
-> bak
-> AllocType
-> Mutability
-> String
-> MemImpl sym
-> Alignment
-> IO
     (RegValue
        sym (IntrinsicType "LLVM_pointer" ('EmptyCtx '::> BVType wptr)),
      MemImpl sym)
forall sym bak (wptr :: Natural).
(IsSymBackend sym bak, HasPtrWidth wptr, HasLLVMAnn sym,
 ?memOpts::MemOptions) =>
Maybe (SymBV sym wptr)
-> bak
-> AllocType
-> Mutability
-> String
-> MemImpl sym
-> Alignment
-> IO (LLVMPtr sym wptr, MemImpl sym)
doMallocSize Maybe (SymBV sym wptr)
forall a. Maybe a
Nothing

doMallocSize
  :: ( IsSymBackend sym bak, HasPtrWidth wptr, Partial.HasLLVMAnn sym
     , ?memOpts :: MemOptions )
  => Maybe (SymBV sym wptr) {- ^ allocation size -}
  -> bak
  -> G.AllocType {- ^ stack, heap, or global -}
  -> G.Mutability {- ^ whether region is read-only -}
  -> String {- ^ source location for use in error messages -}
  -> MemImpl sym
  -> Alignment
  -> IO (LLVMPtr sym wptr, MemImpl sym)
doMallocSize :: forall sym bak (wptr :: Natural).
(IsSymBackend sym bak, HasPtrWidth wptr, HasLLVMAnn sym,
 ?memOpts::MemOptions) =>
Maybe (SymBV sym wptr)
-> bak
-> AllocType
-> Mutability
-> String
-> MemImpl sym
-> Alignment
-> IO (LLVMPtr sym wptr, MemImpl sym)
doMallocSize Maybe (SymBV sym wptr)
sz bak
bak AllocType
allocType Mutability
mut String
loc MemImpl sym
mem Alignment
alignment = do
  let sym :: sym
sym = bak -> sym
forall sym bak. HasSymInterface sym bak => bak -> sym
backendGetSym bak
bak
  Natural
blkNum <- BlockSource -> IO Natural
nextBlock (MemImpl sym -> BlockSource
forall sym. MemImpl sym -> BlockSource
memImplBlockSource MemImpl sym
mem)
  SymNat sym
blk    <- sym -> Natural -> IO (SymNat sym)
forall sym. IsExprBuilder sym => sym -> Natural -> IO (SymNat sym)
natLit sym
sym Natural
blkNum
  SymBV sym wptr
z      <- sym -> NatRepr wptr -> IO (SymBV sym wptr)
forall (w :: Natural) sym.
(1 <= w, IsExprBuilder sym) =>
sym -> NatRepr w -> IO (SymBV sym w)
bvZero sym
sym NatRepr wptr
forall (w :: Natural) (w' :: Natural).
(HasPtrWidth w, w ~ w') =>
NatRepr w'
PtrWidth
  let heap' :: Mem sym
heap' = AllocType
-> Natural
-> Maybe (SymBV sym wptr)
-> Alignment
-> Mutability
-> String
-> Mem sym
-> Mem sym
forall (w :: Natural) sym.
(1 <= w) =>
AllocType
-> Natural
-> Maybe (SymBV sym w)
-> Alignment
-> Mutability
-> String
-> Mem sym
-> Mem sym
G.allocMem AllocType
allocType Natural
blkNum Maybe (SymBV sym wptr)
sz Alignment
alignment Mutability
mut String
loc (MemImpl sym -> Mem sym
forall sym. MemImpl sym -> Mem sym
memImplHeap MemImpl sym
mem)
  let ptr :: LLVMPointer sym wptr
ptr   = SymNat sym -> SymBV sym wptr -> LLVMPointer sym wptr
forall sym (w :: Natural).
SymNat sym -> SymBV sym w -> LLVMPointer sym w
LLVMPointer SymNat sym
blk SymBV sym wptr
z
  let mem' :: MemImpl sym
mem'  = MemImpl sym
mem{ memImplHeap = heap' }
  MemImpl sym
mem'' <- if MemOptions -> Bool
laxLoadsAndStores ?memOpts::MemOptions
MemOptions
?memOpts
                Bool -> Bool -> Bool
&& AllocType
allocType AllocType -> AllocType -> Bool
forall a. Eq a => a -> a -> Bool
== AllocType
G.HeapAlloc
                Bool -> Bool -> Bool
&& MemOptions -> IndeterminateLoadBehavior
indeterminateLoadBehavior ?memOpts::MemOptions
MemOptions
?memOpts IndeterminateLoadBehavior -> IndeterminateLoadBehavior -> Bool
forall a. Eq a => a -> a -> Bool
== IndeterminateLoadBehavior
StableSymbolic
           then bak
-> MemImpl sym
-> LLVMPtr sym wptr
-> Maybe (SymBV sym wptr)
-> Alignment
-> IO (MemImpl sym)
forall sym bak (wptr :: Natural).
(IsSymBackend sym bak, HasPtrWidth wptr, HasLLVMAnn sym) =>
bak
-> MemImpl sym
-> LLVMPtr sym wptr
-> Maybe (SymBV sym wptr)
-> Alignment
-> IO (MemImpl sym)
doConstStoreStableSymbolic bak
bak MemImpl sym
mem' LLVMPtr sym wptr
LLVMPointer sym wptr
ptr Maybe (SymBV sym wptr)
sz Alignment
alignment
           else MemImpl sym -> IO (MemImpl sym)
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure MemImpl sym
mem'
  (LLVMPointer sym wptr, MemImpl sym)
-> IO (LLVMPointer sym wptr, MemImpl sym)
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (LLVMPointer sym wptr
ptr, MemImpl sym
mem'')

-- | Associate a function handle with an existing allocation.
--
-- This can overwrite existing allocation/handle associations, and is used to do
-- so when registering lazily-translated CFGs.
--
-- See also "Lang.Crucible.LLVM.Functions".
doInstallHandle
  :: (Typeable a, IsSymBackend sym bak)
  => bak
  -> LLVMPtr sym wptr
  -> a {- ^ handle -}
  -> MemImpl sym
  -> IO (MemImpl sym)
doInstallHandle :: forall a sym bak (wptr :: Natural).
(Typeable a, IsSymBackend sym bak) =>
bak -> LLVMPtr sym wptr -> a -> MemImpl sym -> IO (MemImpl sym)
doInstallHandle bak
_bak LLVMPtr sym wptr
ptr a
x MemImpl sym
mem =
  case SymNat sym -> Maybe Natural
forall sym. IsExpr (SymExpr sym) => SymNat sym -> Maybe Natural
asNat (LLVMPtr sym wptr -> SymNat sym
forall sym (w :: Natural). LLVMPtr sym w -> SymNat sym
llvmPointerBlock LLVMPtr sym wptr
ptr) of
    Just Natural
blkNum ->
      do let hMap' :: Map Natural Dynamic
hMap' = Natural -> Dynamic -> Map Natural Dynamic -> Map Natural Dynamic
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Natural
blkNum (a -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn a
x) (MemImpl sym -> Map Natural Dynamic
forall sym. MemImpl sym -> Map Natural Dynamic
memImplHandleMap MemImpl sym
mem)
         MemImpl sym -> IO (MemImpl sym)
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return MemImpl sym
mem{ memImplHandleMap = hMap' }
    Maybe Natural
Nothing ->
      String -> [String] -> IO (MemImpl sym)
forall a. HasCallStack => String -> [String] -> a
panic String
"MemModel.doInstallHandle"
        [ String
"Attempted to install handle for symbolic pointer"
        , String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Doc Any -> String
forall a. Show a => a -> String
show (LLVMPtr sym wptr -> Doc Any
forall sym (wptr :: Natural) ann.
IsExpr (SymExpr sym) =>
LLVMPtr sym wptr -> Doc ann
ppPtr LLVMPtr sym wptr
ptr)
        ]

-- | Look up the handle associated with the given pointer, if any.
doLookupHandle
  :: (Typeable a, IsSymInterface sym)
  => sym
  -> MemImpl sym
  -> LLVMPtr sym wptr
  -> IO (Either ME.FuncLookupError a)
doLookupHandle :: forall a sym (wptr :: Natural).
(Typeable a, IsSymInterface sym) =>
sym
-> MemImpl sym -> LLVMPtr sym wptr -> IO (Either FuncLookupError a)
doLookupHandle sym
_sym MemImpl sym
mem LLVMPtr sym wptr
ptr = do
  let LLVMPointer SymNat sym
blk SymBV sym wptr
_ = LLVMPtr sym wptr
ptr
  case SymNat sym -> Maybe Natural
forall sym. IsExpr (SymExpr sym) => SymNat sym -> Maybe Natural
asNat SymNat sym
blk of
    Maybe Natural
Nothing -> Either FuncLookupError a -> IO (Either FuncLookupError a)
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (FuncLookupError -> Either FuncLookupError a
forall a b. a -> Either a b
Left FuncLookupError
ME.SymbolicPointer)
    Just Natural
i
      | Natural
i Natural -> Natural -> Bool
forall a. Eq a => a -> a -> Bool
== Natural
0 -> Either FuncLookupError a -> IO (Either FuncLookupError a)
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (FuncLookupError -> Either FuncLookupError a
forall a b. a -> Either a b
Left FuncLookupError
ME.RawBitvector)
      | Bool
otherwise ->
          case Natural -> Map Natural Dynamic -> Maybe Dynamic
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Natural
i (MemImpl sym -> Map Natural Dynamic
forall sym. MemImpl sym -> Map Natural Dynamic
memImplHandleMap MemImpl sym
mem) of
            Maybe Dynamic
Nothing -> Either FuncLookupError a -> IO (Either FuncLookupError a)
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (FuncLookupError -> Either FuncLookupError a
forall a b. a -> Either a b
Left FuncLookupError
ME.NoOverride)
            Just Dynamic
x ->
              case Dynamic -> Maybe a
forall a. Typeable a => Dynamic -> Maybe a
fromDynamic Dynamic
x of
                Maybe a
Nothing -> Either FuncLookupError a -> IO (Either FuncLookupError a)
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (FuncLookupError -> Either FuncLookupError a
forall a b. a -> Either a b
Left (SomeTypeRep -> FuncLookupError
ME.Uncallable (Dynamic -> SomeTypeRep
dynTypeRep Dynamic
x)))
                Just a
a  -> Either FuncLookupError a -> IO (Either FuncLookupError a)
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (a -> Either FuncLookupError a
forall a b. b -> Either a b
Right a
a)

-- | Free the memory region pointed to by the given pointer.
--
-- Precondition: the pointer either points to the beginning of an allocated
-- region, or is null. Freeing a null pointer has no effect.
doFree
  :: (IsSymBackend sym bak, HasPtrWidth wptr, Partial.HasLLVMAnn sym)
  => bak
  -> MemImpl sym
  -> LLVMPtr sym wptr
  -> IO (MemImpl sym)
doFree :: forall sym bak (wptr :: Natural).
(IsSymBackend sym bak, HasPtrWidth wptr, HasLLVMAnn sym) =>
bak -> MemImpl sym -> LLVMPtr sym wptr -> IO (MemImpl sym)
doFree bak
bak MemImpl sym
mem LLVMPtr sym wptr
ptr = do
  let sym :: sym
sym = bak -> sym
forall sym bak. HasSymInterface sym bak => bak -> sym
backendGetSym bak
bak
  let LLVMPointer SymNat sym
blk SymBV sym wptr
_off = LLVMPtr sym wptr
ptr
  String
loc <- Position -> String
forall a. Show a => a -> String
show (Position -> String)
-> (ProgramLoc -> Position) -> ProgramLoc -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProgramLoc -> Position
plSourceLoc (ProgramLoc -> String) -> IO ProgramLoc -> IO String
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> sym -> IO ProgramLoc
forall sym. IsExprBuilder sym => sym -> IO ProgramLoc
getCurrentProgramLoc sym
sym
  (Mem sym
heap', SymExpr sym BaseBoolType
p1, SymExpr sym BaseBoolType
p2, SymExpr sym BaseBoolType
notFreed) <- sym
-> NatRepr wptr
-> LLVMPtr sym wptr
-> Mem sym
-> String
-> IO
     (Mem sym, SymExpr sym BaseBoolType, SymExpr sym BaseBoolType,
      SymExpr sym BaseBoolType)
forall sym (w :: Natural).
(1 <= w, IsSymInterface sym) =>
sym
-> NatRepr w
-> LLVMPtr sym w
-> Mem sym
-> String
-> IO (Mem sym, Pred sym, Pred sym, Pred sym)
G.freeMem sym
sym NatRepr wptr
forall (w :: Natural) (w' :: Natural).
(HasPtrWidth w, w ~ w') =>
NatRepr w'
PtrWidth LLVMPtr sym wptr
ptr (MemImpl sym -> Mem sym
forall sym. MemImpl sym -> Mem sym
memImplHeap MemImpl sym
mem) String
loc

  -- If this pointer is a handle pointer, remove the associated data
  let hMap' :: Map Natural Dynamic
hMap' =
       case SymNat sym -> Maybe Natural
forall sym. IsExpr (SymExpr sym) => SymNat sym -> Maybe Natural
asNat SymNat sym
blk of
         Just Natural
i  -> Natural -> Map Natural Dynamic -> Map Natural Dynamic
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Natural
i (MemImpl sym -> Map Natural Dynamic
forall sym. MemImpl sym -> Map Natural Dynamic
memImplHandleMap MemImpl sym
mem)
         Maybe Natural
Nothing -> MemImpl sym -> Map Natural Dynamic
forall sym. MemImpl sym -> Map Natural Dynamic
memImplHandleMap MemImpl sym
mem

  -- NB: free is defined and has no effect if passed a null pointer
  SymExpr sym BaseBoolType
isNull    <- sym
-> NatRepr wptr
-> LLVMPtr sym wptr
-> IO (SymExpr sym BaseBoolType)
forall (w :: Natural) sym.
(1 <= w, IsSymInterface sym) =>
sym -> NatRepr w -> LLVMPtr sym w -> IO (Pred sym)
ptrIsNull sym
sym NatRepr wptr
forall (w :: Natural) (w' :: Natural).
(HasPtrWidth w, w ~ w') =>
NatRepr w'
PtrWidth LLVMPtr sym wptr
ptr
  SymExpr sym BaseBoolType
p1'       <- sym
-> SymExpr sym BaseBoolType
-> SymExpr sym BaseBoolType
-> IO (SymExpr sym BaseBoolType)
forall sym.
IsExprBuilder sym =>
sym -> Pred sym -> Pred sym -> IO (Pred sym)
orPred sym
sym SymExpr sym BaseBoolType
p1 SymExpr sym BaseBoolType
isNull
  SymExpr sym BaseBoolType
p2'       <- sym
-> SymExpr sym BaseBoolType
-> SymExpr sym BaseBoolType
-> IO (SymExpr sym BaseBoolType)
forall sym.
IsExprBuilder sym =>
sym -> Pred sym -> Pred sym -> IO (Pred sym)
orPred sym
sym SymExpr sym BaseBoolType
p2 SymExpr sym BaseBoolType
isNull
  SymExpr sym BaseBoolType
notFreed' <- sym
-> SymExpr sym BaseBoolType
-> SymExpr sym BaseBoolType
-> IO (SymExpr sym BaseBoolType)
forall sym.
IsExprBuilder sym =>
sym -> Pred sym -> Pred sym -> IO (Pred sym)
orPred sym
sym SymExpr sym BaseBoolType
notFreed SymExpr sym BaseBoolType
isNull
  let callStack :: CallStack
callStack = MemState sym -> CallStack
forall sym. MemState sym -> CallStack
getCallStack (MemImpl sym
mem MemImpl sym
-> Getting (MemState sym) (MemImpl sym) (MemState sym)
-> MemState sym
forall s a. s -> Getting a s a -> a
^. (MemImpl sym -> Mem sym)
-> (Mem sym -> Const (MemState sym) (Mem sym))
-> MemImpl sym
-> Const (MemState sym) (MemImpl sym)
forall (p :: Type -> Type -> Type) (f :: Type -> Type) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to MemImpl sym -> Mem sym
forall sym. MemImpl sym -> Mem sym
memImplHeap ((Mem sym -> Const (MemState sym) (Mem sym))
 -> MemImpl sym -> Const (MemState sym) (MemImpl sym))
-> ((MemState sym -> Const (MemState sym) (MemState sym))
    -> Mem sym -> Const (MemState sym) (Mem sym))
-> Getting (MemState sym) (MemImpl sym) (MemState sym)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MemState sym -> Const (MemState sym) (MemState sym))
-> Mem sym -> Const (MemState sym) (Mem sym)
forall sym (f :: Type -> Type).
Functor f =>
(MemState sym -> f (MemState sym)) -> Mem sym -> f (Mem sym)
ML.memState)
  bak
-> CallStack
-> SymExpr sym BaseBoolType
-> UndefinedBehavior (RegValue' sym)
-> IO ()
forall sym bak.
(IsSymBackend sym bak, HasLLVMAnn sym) =>
bak
-> CallStack
-> Pred sym
-> UndefinedBehavior (RegValue' sym)
-> IO ()
assertUndefined bak
bak CallStack
callStack SymExpr sym BaseBoolType
p1' (RegValue' sym (LLVMPointerType wptr)
-> UndefinedBehavior (RegValue' sym)
forall (w :: Natural) (e :: CrucibleType -> Type).
(1 <= w) =>
e (LLVMPointerType w) -> UndefinedBehavior e
UB.FreeBadOffset (LLVMPtr sym wptr -> RegValue' sym (LLVMPointerType wptr)
forall sym (tp :: CrucibleType).
RegValue sym tp -> RegValue' sym tp
RV LLVMPtr sym wptr
ptr))
  bak
-> CallStack
-> SymExpr sym BaseBoolType
-> UndefinedBehavior (RegValue' sym)
-> IO ()
forall sym bak.
(IsSymBackend sym bak, HasLLVMAnn sym) =>
bak
-> CallStack
-> Pred sym
-> UndefinedBehavior (RegValue' sym)
-> IO ()
assertUndefined bak
bak CallStack
callStack SymExpr sym BaseBoolType
p2' (RegValue' sym (LLVMPointerType wptr)
-> UndefinedBehavior (RegValue' sym)
forall (w :: Natural) (e :: CrucibleType -> Type).
(1 <= w) =>
e (LLVMPointerType w) -> UndefinedBehavior e
UB.FreeUnallocated (LLVMPtr sym wptr -> RegValue' sym (LLVMPointerType wptr)
forall sym (tp :: CrucibleType).
RegValue sym tp -> RegValue' sym tp
RV LLVMPtr sym wptr
ptr))
  bak
-> CallStack
-> SymExpr sym BaseBoolType
-> UndefinedBehavior (RegValue' sym)
-> IO ()
forall sym bak.
(IsSymBackend sym bak, HasLLVMAnn sym) =>
bak
-> CallStack
-> Pred sym
-> UndefinedBehavior (RegValue' sym)
-> IO ()
assertUndefined bak
bak CallStack
callStack SymExpr sym BaseBoolType
notFreed' (RegValue' sym (LLVMPointerType wptr)
-> UndefinedBehavior (RegValue' sym)
forall (w :: Natural) (e :: CrucibleType -> Type).
(1 <= w) =>
e (LLVMPointerType w) -> UndefinedBehavior e
UB.DoubleFree (LLVMPtr sym wptr -> RegValue' sym (LLVMPointerType wptr)
forall sym (tp :: CrucibleType).
RegValue sym tp -> RegValue' sym tp
RV LLVMPtr sym wptr
ptr))

  MemImpl sym -> IO (MemImpl sym)
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return MemImpl sym
mem{ memImplHeap = heap', memImplHandleMap = hMap' }

-- | Fill a memory range with copies of the specified byte.
--
-- Precondition: the memory range falls within a valid allocated region.
doMemset ::
  (1 <= w, IsSymBackend sym bak, HasPtrWidth wptr, Partial.HasLLVMAnn sym) =>
  bak ->
  NatRepr w ->
  MemImpl sym ->
  LLVMPtr sym wptr {- ^ destination -} ->
  SymBV sym 8      {- ^ fill byte   -} ->
  SymBV sym w      {- ^ length      -} ->
  IO (MemImpl sym)
doMemset :: forall (w :: Natural) sym bak (wptr :: Natural).
(1 <= w, IsSymBackend sym bak, HasPtrWidth wptr, HasLLVMAnn sym) =>
bak
-> NatRepr w
-> MemImpl sym
-> LLVMPtr sym wptr
-> SymBV sym 8
-> SymBV sym w
-> IO (MemImpl sym)
doMemset bak
bak NatRepr w
w MemImpl sym
mem LLVMPtr sym wptr
dest SymBV sym 8
val SymBV sym w
len = do
  let sym :: sym
sym = bak -> sym
forall sym bak. HasSymInterface sym bak => bak -> sym
backendGetSym bak
bak
  SymExpr sym (BaseBVType wptr)
len' <- sym
-> NatRepr w
-> NatRepr wptr
-> SymBV sym w
-> IO (SymExpr sym (BaseBVType wptr))
forall (w :: Natural) (w' :: Natural) sym.
(1 <= w, 1 <= w', IsSymInterface sym) =>
sym
-> NatRepr w
-> NatRepr w'
-> SymExpr sym (BaseBVType w)
-> IO (SymExpr sym (BaseBVType w'))
sextendBVTo sym
sym NatRepr w
w NatRepr wptr
forall (w :: Natural) (w' :: Natural).
(HasPtrWidth w, w ~ w') =>
NatRepr w'
PtrWidth SymBV sym w
len

  (Mem sym
heap', SymExpr sym BaseBoolType
p) <- sym
-> NatRepr wptr
-> LLVMPtr sym wptr
-> SymBV sym 8
-> SymExpr sym (BaseBVType wptr)
-> Mem sym
-> IO (Mem sym, SymExpr sym BaseBoolType)
forall (w :: Natural) sym.
(1 <= w, IsSymInterface sym) =>
sym
-> NatRepr w
-> LLVMPtr sym w
-> SymBV sym 8
-> SymBV sym w
-> Mem sym
-> IO (Mem sym, Pred sym)
G.setMem sym
sym NatRepr wptr
forall (w :: Natural) (w' :: Natural).
(HasPtrWidth w, w ~ w') =>
NatRepr w'
PtrWidth LLVMPtr sym wptr
dest SymBV sym 8
val SymExpr sym (BaseBVType wptr)
len' (MemImpl sym -> Mem sym
forall sym. MemImpl sym -> Mem sym
memImplHeap MemImpl sym
mem)

  let callStack :: CallStack
callStack = MemState sym -> CallStack
forall sym. MemState sym -> CallStack
getCallStack (MemImpl sym
mem MemImpl sym
-> Getting (MemState sym) (MemImpl sym) (MemState sym)
-> MemState sym
forall s a. s -> Getting a s a -> a
^. (MemImpl sym -> Mem sym)
-> (Mem sym -> Const (MemState sym) (Mem sym))
-> MemImpl sym
-> Const (MemState sym) (MemImpl sym)
forall (p :: Type -> Type -> Type) (f :: Type -> Type) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to MemImpl sym -> Mem sym
forall sym. MemImpl sym -> Mem sym
memImplHeap ((Mem sym -> Const (MemState sym) (Mem sym))
 -> MemImpl sym -> Const (MemState sym) (MemImpl sym))
-> ((MemState sym -> Const (MemState sym) (MemState sym))
    -> Mem sym -> Const (MemState sym) (Mem sym))
-> Getting (MemState sym) (MemImpl sym) (MemState sym)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MemState sym -> Const (MemState sym) (MemState sym))
-> Mem sym -> Const (MemState sym) (Mem sym)
forall sym (f :: Type -> Type).
Functor f =>
(MemState sym -> f (MemState sym)) -> Mem sym -> f (Mem sym)
ML.memState)
  bak
-> CallStack
-> SymExpr sym BaseBoolType
-> UndefinedBehavior (RegValue' sym)
-> IO ()
forall sym bak.
(IsSymBackend sym bak, HasLLVMAnn sym) =>
bak
-> CallStack
-> Pred sym
-> UndefinedBehavior (RegValue' sym)
-> IO ()
assertUndefined bak
bak CallStack
callStack SymExpr sym BaseBoolType
p (UndefinedBehavior (RegValue' sym) -> IO ())
-> UndefinedBehavior (RegValue' sym) -> IO ()
forall a b. (a -> b) -> a -> b
$
    RegValue' sym (LLVMPointerType wptr)
-> RegValue' sym (BVType 8)
-> RegValue' sym (BVType w)
-> UndefinedBehavior (RegValue' sym)
forall (w :: Natural) (v :: Natural) (e :: CrucibleType -> Type).
(1 <= w, 1 <= v) =>
e (LLVMPointerType w)
-> e (BVType 8) -> e (BVType v) -> UndefinedBehavior e
UB.MemsetInvalidRegion (LLVMPtr sym wptr -> RegValue' sym (LLVMPointerType wptr)
forall sym (tp :: CrucibleType).
RegValue sym tp -> RegValue' sym tp
RV LLVMPtr sym wptr
dest) (RegValue sym (BVType 8) -> RegValue' sym (BVType 8)
forall sym (tp :: CrucibleType).
RegValue sym tp -> RegValue' sym tp
RV RegValue sym (BVType 8)
SymBV sym 8
val) (RegValue sym (BVType w) -> RegValue' sym (BVType w)
forall sym (tp :: CrucibleType).
RegValue sym tp -> RegValue' sym tp
RV RegValue sym (BVType w)
SymBV sym w
len)

  MemImpl sym -> IO (MemImpl sym)
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return MemImpl sym
mem{ memImplHeap = heap' }

doInvalidate ::
  ( 1 <= w, IsSymBackend sym bak, HasPtrWidth wptr, Partial.HasLLVMAnn sym
  , ?memOpts :: MemOptions ) =>
  bak ->
  NatRepr w ->
  MemImpl sym ->
  LLVMPtr sym wptr {- ^ destination -} ->
  Text             {- ^ message     -} ->
  SymBV sym w      {- ^ length      -} ->
  IO (MemImpl sym)
doInvalidate :: forall (w :: Natural) sym bak (wptr :: Natural).
(1 <= w, IsSymBackend sym bak, HasPtrWidth wptr, HasLLVMAnn sym,
 ?memOpts::MemOptions) =>
bak
-> NatRepr w
-> MemImpl sym
-> LLVMPtr sym wptr
-> Text
-> SymBV sym w
-> IO (MemImpl sym)
doInvalidate bak
bak NatRepr w
w MemImpl sym
mem LLVMPtr sym wptr
dest Text
msg SymBV sym w
len = do
  let sym :: sym
sym = bak -> sym
forall sym bak. HasSymInterface sym bak => bak -> sym
backendGetSym bak
bak
  SymExpr sym (BaseBVType wptr)
len' <- sym
-> NatRepr w
-> NatRepr wptr
-> SymBV sym w
-> IO (SymExpr sym (BaseBVType wptr))
forall (w :: Natural) (w' :: Natural) sym.
(1 <= w, 1 <= w', IsSymInterface sym) =>
sym
-> NatRepr w
-> NatRepr w'
-> SymExpr sym (BaseBVType w)
-> IO (SymExpr sym (BaseBVType w'))
sextendBVTo sym
sym NatRepr w
w NatRepr wptr
forall (w :: Natural) (w' :: Natural).
(HasPtrWidth w, w ~ w') =>
NatRepr w'
PtrWidth SymBV sym w
len

  (Mem sym
heap', SymExpr sym BaseBoolType
p) <- if MemOptions -> Bool
laxLoadsAndStores ?memOpts::MemOptions
MemOptions
?memOpts Bool -> Bool -> Bool
&&
                   MemOptions -> IndeterminateLoadBehavior
indeterminateLoadBehavior ?memOpts::MemOptions
MemOptions
?memOpts IndeterminateLoadBehavior -> IndeterminateLoadBehavior -> Bool
forall a. Eq a => a -> a -> Bool
== IndeterminateLoadBehavior
StableSymbolic
                then do SymExpr sym BaseBoolType
p <- sym
-> NatRepr wptr
-> Alignment
-> LLVMPtr sym wptr
-> Maybe (SymExpr sym (BaseBVType wptr))
-> Mem sym
-> IO (SymExpr sym BaseBoolType)
forall (w :: Natural) sym.
(1 <= w, IsSymInterface sym) =>
sym
-> NatRepr w
-> Alignment
-> LLVMPtr sym w
-> Maybe (SymBV sym w)
-> Mem sym
-> IO (Pred sym)
G.isAllocatedMutable sym
sym NatRepr wptr
forall (w :: Natural) (w' :: Natural).
(HasPtrWidth w, w ~ w') =>
NatRepr w'
PtrWidth Alignment
noAlignment LLVMPtr sym wptr
dest (SymExpr sym (BaseBVType wptr)
-> Maybe (SymExpr sym (BaseBVType wptr))
forall a. a -> Maybe a
Just SymExpr sym (BaseBVType wptr)
len') (MemImpl sym -> Mem sym
forall sym. MemImpl sym -> Mem sym
memImplHeap MemImpl sym
mem)
                        MemImpl sym
mem' <- bak
-> MemImpl sym
-> LLVMPtr sym wptr
-> Maybe (SymExpr sym (BaseBVType wptr))
-> Alignment
-> IO (MemImpl sym)
forall sym bak (wptr :: Natural).
(IsSymBackend sym bak, HasPtrWidth wptr, HasLLVMAnn sym) =>
bak
-> MemImpl sym
-> LLVMPtr sym wptr
-> Maybe (SymBV sym wptr)
-> Alignment
-> IO (MemImpl sym)
doStoreStableSymbolic bak
bak MemImpl sym
mem LLVMPtr sym wptr
dest (SymExpr sym (BaseBVType wptr)
-> Maybe (SymExpr sym (BaseBVType wptr))
forall a. a -> Maybe a
Just SymExpr sym (BaseBVType wptr)
len') Alignment
noAlignment
                        (Mem sym, SymExpr sym BaseBoolType)
-> IO (Mem sym, SymExpr sym BaseBoolType)
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (MemImpl sym -> Mem sym
forall sym. MemImpl sym -> Mem sym
memImplHeap MemImpl sym
mem', SymExpr sym BaseBoolType
p)
                else sym
-> NatRepr wptr
-> LLVMPtr sym wptr
-> Text
-> SymExpr sym (BaseBVType wptr)
-> Mem sym
-> IO (Mem sym, SymExpr sym BaseBoolType)
forall (w :: Natural) sym.
(1 <= w, IsSymInterface sym) =>
sym
-> NatRepr w
-> LLVMPtr sym w
-> Text
-> SymBV sym w
-> Mem sym
-> IO (Mem sym, Pred sym)
G.invalidateMem sym
sym NatRepr wptr
forall (w :: Natural) (w' :: Natural).
(HasPtrWidth w, w ~ w') =>
NatRepr w'
PtrWidth LLVMPtr sym wptr
dest Text
msg SymExpr sym (BaseBVType wptr)
len' (MemImpl sym -> Mem sym
forall sym. MemImpl sym -> Mem sym
memImplHeap MemImpl sym
mem)

  let gsym :: Maybe String
gsym = Symbol -> String
unsymbol (Symbol -> String) -> Maybe Symbol -> Maybe String
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Natural Symbol -> LLVMPtr sym wptr -> Maybe Symbol
forall sym (w :: Natural).
IsSymInterface sym =>
Map Natural Symbol -> LLVMPtr sym w -> Maybe Symbol
isGlobalPointer (MemImpl sym -> Map Natural Symbol
forall sym. MemImpl sym -> Map Natural Symbol
memImplSymbolMap MemImpl sym
mem) LLVMPtr sym wptr
dest
  let mop :: MemoryOp sym wptr
mop = Text
-> Maybe String
-> LLVMPtr sym wptr
-> SymBV sym w
-> Mem sym
-> MemoryOp sym wptr
forall sym (w :: Natural) (wlen :: Natural).
(1 <= wlen) =>
Text
-> Maybe String
-> LLVMPtr sym w
-> SymBV sym wlen
-> Mem sym
-> MemoryOp sym w
MemInvalidateOp Text
msg Maybe String
gsym LLVMPtr sym wptr
dest SymBV sym w
len (MemImpl sym -> Mem sym
forall sym. MemImpl sym -> Mem sym
memImplHeap MemImpl sym
mem)
  SymExpr sym BaseBoolType
p' <- sym
-> MemoryOp sym wptr
-> MemoryErrorReason
-> SymExpr sym BaseBoolType
-> IO (SymExpr sym BaseBoolType)
forall sym (w :: Natural).
(IsSymInterface sym, HasLLVMAnn sym, 1 <= w) =>
sym
-> MemoryOp sym w -> MemoryErrorReason -> Pred sym -> IO (Pred sym)
Partial.annotateME sym
sym MemoryOp sym wptr
mop MemoryErrorReason
UnwritableRegion SymExpr sym BaseBoolType
p
  bak -> SymExpr sym BaseBoolType -> SimErrorReason -> IO ()
forall sym bak.
IsSymBackend sym bak =>
bak -> Pred sym -> SimErrorReason -> IO ()
assert bak
bak SymExpr sym BaseBoolType
p' (SimErrorReason -> IO ()) -> SimErrorReason -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> SimErrorReason
AssertFailureSimError String
"Invalidation of unallocated or readonly region" String
""

  MemImpl sym -> IO (MemImpl sym)
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return MemImpl sym
mem{ memImplHeap = heap' }

-- | Store an array in memory.
--
-- Precondition: the pointer is valid and points to a mutable memory region.
doArrayStore
  :: (IsSymBackend sym bak, HasPtrWidth w, Partial.HasLLVMAnn sym)
  => bak
  -> MemImpl sym
  -> LLVMPtr sym w {- ^ destination  -}
  -> Alignment
  -> SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8) {- ^ array value  -}
  -> SymBV sym w {- ^ array length -}
  -> IO (MemImpl sym)
doArrayStore :: forall sym bak (w :: Natural).
(IsSymBackend sym bak, HasPtrWidth w, HasLLVMAnn sym) =>
bak
-> MemImpl sym
-> LLVMPtr sym w
-> Alignment
-> SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)
-> SymBV sym w
-> IO (MemImpl sym)
doArrayStore bak
bak MemImpl sym
mem LLVMPtr sym w
ptr Alignment
alignment SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)
arr SymBV sym w
len = Maybe (SymBV sym w)
-> bak
-> MemImpl sym
-> LLVMPtr sym w
-> Alignment
-> SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)
-> IO (MemImpl sym)
forall sym bak (w :: Natural).
(IsSymBackend sym bak, HasPtrWidth w, HasLLVMAnn sym) =>
Maybe (SymBV sym w)
-> bak
-> MemImpl sym
-> LLVMPtr sym w
-> Alignment
-> SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)
-> IO (MemImpl sym)
doArrayStoreSize (SymBV sym w -> Maybe (SymBV sym w)
forall a. a -> Maybe a
Just SymBV sym w
len) bak
bak MemImpl sym
mem LLVMPtr sym w
ptr Alignment
alignment SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)
arr

-- | Store an array of unbounded length in memory.
--
-- Precondition: the pointer is valid and points to a mutable memory region.
doArrayStoreUnbounded
  :: (IsSymBackend sym bak, HasPtrWidth w, Partial.HasLLVMAnn sym)
  => bak
  -> MemImpl sym
  -> LLVMPtr sym w {- ^ destination  -}
  -> Alignment
  -> SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8) {- ^ array value  -}
  -> IO (MemImpl sym)
doArrayStoreUnbounded :: forall sym bak (w :: Natural).
(IsSymBackend sym bak, HasPtrWidth w, HasLLVMAnn sym) =>
bak
-> MemImpl sym
-> LLVMPtr sym w
-> Alignment
-> SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)
-> IO (MemImpl sym)
doArrayStoreUnbounded = Maybe (SymBV sym w)
-> bak
-> MemImpl sym
-> RegValue
     sym (IntrinsicType "LLVM_pointer" ('EmptyCtx '::> BVType w))
-> Alignment
-> SymExpr
     sym (BaseArrayType (SingleCtx (BaseBVType w)) (BaseBVType 8))
-> IO (MemImpl sym)
forall sym bak (w :: Natural).
(IsSymBackend sym bak, HasPtrWidth w, HasLLVMAnn sym) =>
Maybe (SymBV sym w)
-> bak
-> MemImpl sym
-> LLVMPtr sym w
-> Alignment
-> SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)
-> IO (MemImpl sym)
doArrayStoreSize Maybe (SymBV sym w)
forall a. Maybe a
Nothing


doArrayStoreSize
  :: (IsSymBackend sym bak, HasPtrWidth w, Partial.HasLLVMAnn sym)
  => Maybe (SymBV sym w) {- ^ possibly-unbounded array length -}
  -> bak
  -> MemImpl sym
  -> LLVMPtr sym w {- ^ destination  -}
  -> Alignment
  -> SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8) {- ^ array value  -}
  -> IO (MemImpl sym)
doArrayStoreSize :: forall sym bak (w :: Natural).
(IsSymBackend sym bak, HasPtrWidth w, HasLLVMAnn sym) =>
Maybe (SymBV sym w)
-> bak
-> MemImpl sym
-> LLVMPtr sym w
-> Alignment
-> SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)
-> IO (MemImpl sym)
doArrayStoreSize Maybe (SymBV sym w)
len bak
bak MemImpl sym
mem LLVMPtr sym w
ptr Alignment
alignment SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)
arr = do
  let sym :: sym
sym = bak -> sym
forall sym bak. HasSymInterface sym bak => bak -> sym
backendGetSym bak
bak
  (Mem sym
heap', SymExpr sym BaseBoolType
p1, SymExpr sym BaseBoolType
p2) <-
    sym
-> NatRepr w
-> LLVMPtr sym w
-> Alignment
-> SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)
-> Maybe (SymBV sym w)
-> Mem sym
-> IO (Mem sym, SymExpr sym BaseBoolType, SymExpr sym BaseBoolType)
forall sym (w :: Natural).
(IsSymInterface sym, 1 <= w) =>
sym
-> NatRepr w
-> LLVMPtr sym w
-> Alignment
-> SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)
-> Maybe (SymBV sym w)
-> Mem sym
-> IO (Mem sym, Pred sym, Pred sym)
G.writeArrayMem sym
sym NatRepr w
forall (w :: Natural) (w' :: Natural).
(HasPtrWidth w, w ~ w') =>
NatRepr w'
PtrWidth LLVMPtr sym w
ptr Alignment
alignment SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)
arr Maybe (SymBV sym w)
len (MemImpl sym -> Mem sym
forall sym. MemImpl sym -> Mem sym
memImplHeap MemImpl sym
mem)

  let gsym :: Maybe String
gsym = Symbol -> String
unsymbol (Symbol -> String) -> Maybe Symbol -> Maybe String
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Natural Symbol -> LLVMPtr sym w -> Maybe Symbol
forall sym (w :: Natural).
IsSymInterface sym =>
Map Natural Symbol -> LLVMPtr sym w -> Maybe Symbol
isGlobalPointer (MemImpl sym -> Map Natural Symbol
forall sym. MemImpl sym -> Map Natural Symbol
memImplSymbolMap MemImpl sym
mem) LLVMPtr sym w
ptr
  let mop :: MemoryOp sym w
mop = Maybe String
-> LLVMPtr sym w
-> Maybe (SymBV sym w)
-> Mem sym
-> MemoryOp sym w
forall sym (w :: Natural).
Maybe String
-> LLVMPtr sym w
-> Maybe (SymBV sym w)
-> Mem sym
-> MemoryOp sym w
MemStoreBytesOp Maybe String
gsym LLVMPtr sym w
ptr Maybe (SymBV sym w)
len (MemImpl sym -> Mem sym
forall sym. MemImpl sym -> Mem sym
memImplHeap MemImpl sym
mem)

  bak
-> MemoryOp sym w
-> MemoryErrorReason
-> SymExpr sym BaseBoolType
-> IO ()
forall sym bak (wptr :: Natural).
(IsSymBackend sym bak, HasLLVMAnn sym, 1 <= wptr) =>
bak
-> MemErrContext sym wptr -> MemoryErrorReason -> Pred sym -> IO ()
assertStoreError bak
bak MemoryOp sym w
mop MemoryErrorReason
UnwritableRegion SymExpr sym BaseBoolType
p1
  let callStack :: CallStack
callStack = MemState sym -> CallStack
forall sym. MemState sym -> CallStack
getCallStack (MemImpl sym
mem MemImpl sym
-> Getting (MemState sym) (MemImpl sym) (MemState sym)
-> MemState sym
forall s a. s -> Getting a s a -> a
^. (MemImpl sym -> Mem sym)
-> (Mem sym -> Const (MemState sym) (Mem sym))
-> MemImpl sym
-> Const (MemState sym) (MemImpl sym)
forall (p :: Type -> Type -> Type) (f :: Type -> Type) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to MemImpl sym -> Mem sym
forall sym. MemImpl sym -> Mem sym
memImplHeap ((Mem sym -> Const (MemState sym) (Mem sym))
 -> MemImpl sym -> Const (MemState sym) (MemImpl sym))
-> ((MemState sym -> Const (MemState sym) (MemState sym))
    -> Mem sym -> Const (MemState sym) (Mem sym))
-> Getting (MemState sym) (MemImpl sym) (MemState sym)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MemState sym -> Const (MemState sym) (MemState sym))
-> Mem sym -> Const (MemState sym) (Mem sym)
forall sym (f :: Type -> Type).
Functor f =>
(MemState sym -> f (MemState sym)) -> Mem sym -> f (Mem sym)
ML.memState)
  bak
-> CallStack
-> SymExpr sym BaseBoolType
-> UndefinedBehavior (RegValue' sym)
-> IO ()
forall sym bak.
(IsSymBackend sym bak, HasLLVMAnn sym) =>
bak
-> CallStack
-> Pred sym
-> UndefinedBehavior (RegValue' sym)
-> IO ()
assertUndefined bak
bak CallStack
callStack SymExpr sym BaseBoolType
p2 (RegValue' sym (LLVMPointerType w)
-> Alignment -> UndefinedBehavior (RegValue' sym)
forall (w :: Natural) (e :: CrucibleType -> Type).
(1 <= w) =>
e (LLVMPointerType w) -> Alignment -> UndefinedBehavior e
UB.WriteBadAlignment (LLVMPtr sym w -> RegValue' sym (LLVMPointerType w)
forall sym (tp :: CrucibleType).
RegValue sym tp -> RegValue' sym tp
RV LLVMPtr sym w
ptr) Alignment
alignment)

  MemImpl sym -> IO (MemImpl sym)
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return MemImpl sym
mem { memImplHeap = heap' }

-- | Store an array in memory.
--
-- Precondition: the pointer is valid and points to a mutable or immutable memory region.
-- Therefore it can be used to initialize read-only memory regions.
doArrayConstStore
  :: (IsSymBackend sym bak, HasPtrWidth w, Partial.HasLLVMAnn sym)
  => bak
  -> MemImpl sym
  -> LLVMPtr sym w {- ^ destination  -}
  -> Alignment
  -> SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8) {- ^ array value  -}
  -> SymBV sym w {- ^ array length -}
  -> IO (MemImpl sym)
doArrayConstStore :: forall sym bak (w :: Natural).
(IsSymBackend sym bak, HasPtrWidth w, HasLLVMAnn sym) =>
bak
-> MemImpl sym
-> LLVMPtr sym w
-> Alignment
-> SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)
-> SymBV sym w
-> IO (MemImpl sym)
doArrayConstStore bak
bak MemImpl sym
mem LLVMPtr sym w
ptr Alignment
alignment SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)
arr SymBV sym w
len =
  Maybe (SymBV sym w)
-> bak
-> MemImpl sym
-> LLVMPtr sym w
-> Alignment
-> SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)
-> IO (MemImpl sym)
forall sym bak (w :: Natural).
(IsSymBackend sym bak, HasPtrWidth w, HasLLVMAnn sym) =>
Maybe (SymBV sym w)
-> bak
-> MemImpl sym
-> LLVMPtr sym w
-> Alignment
-> SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)
-> IO (MemImpl sym)
doArrayConstStoreSize (SymBV sym w -> Maybe (SymBV sym w)
forall a. a -> Maybe a
Just SymBV sym w
len) bak
bak MemImpl sym
mem LLVMPtr sym w
ptr Alignment
alignment SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)
arr

-- | Store an array of unbounded length in memory.
--
-- Precondition: the pointer is valid and points to a mutable or immutable memory region.
-- Therefore it can be used to initialize read-only memory regions.
doArrayConstStoreUnbounded
  :: (IsSymBackend sym bak, HasPtrWidth w, Partial.HasLLVMAnn sym)
  => bak
  -> MemImpl sym
  -> LLVMPtr sym w {- ^ destination  -}
  -> Alignment
  -> SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8) {- ^ array value  -}
  -> IO (MemImpl sym)
doArrayConstStoreUnbounded :: forall sym bak (w :: Natural).
(IsSymBackend sym bak, HasPtrWidth w, HasLLVMAnn sym) =>
bak
-> MemImpl sym
-> LLVMPtr sym w
-> Alignment
-> SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)
-> IO (MemImpl sym)
doArrayConstStoreUnbounded = Maybe (SymBV sym w)
-> bak
-> MemImpl sym
-> RegValue
     sym (IntrinsicType "LLVM_pointer" ('EmptyCtx '::> BVType w))
-> Alignment
-> SymExpr
     sym (BaseArrayType (SingleCtx (BaseBVType w)) (BaseBVType 8))
-> IO (MemImpl sym)
forall sym bak (w :: Natural).
(IsSymBackend sym bak, HasPtrWidth w, HasLLVMAnn sym) =>
Maybe (SymBV sym w)
-> bak
-> MemImpl sym
-> LLVMPtr sym w
-> Alignment
-> SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)
-> IO (MemImpl sym)
doArrayConstStoreSize Maybe (SymBV sym w)
forall a. Maybe a
Nothing

-- | The workhorse for 'doArrayConstStore' (if the first argument is
-- @'Just' len@) or 'doArrayConstStoreUnbounded' (if the first argument is
-- 'Nothing').
doArrayConstStoreSize
  :: (IsSymBackend sym bak, HasPtrWidth w, Partial.HasLLVMAnn sym)
  => Maybe (SymBV sym w) {- ^ possibly-unbounded array length -}
  -> bak
  -> MemImpl sym
  -> LLVMPtr sym w {- ^ destination  -}
  -> Alignment
  -> SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8) {- ^ array value  -}
  -> IO (MemImpl sym)
doArrayConstStoreSize :: forall sym bak (w :: Natural).
(IsSymBackend sym bak, HasPtrWidth w, HasLLVMAnn sym) =>
Maybe (SymBV sym w)
-> bak
-> MemImpl sym
-> LLVMPtr sym w
-> Alignment
-> SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)
-> IO (MemImpl sym)
doArrayConstStoreSize Maybe (SymBV sym w)
len bak
bak MemImpl sym
mem LLVMPtr sym w
ptr Alignment
alignment SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)
arr = do
  let sym :: sym
sym = bak -> sym
forall sym bak. HasSymInterface sym bak => bak -> sym
backendGetSym bak
bak
  (Mem sym
heap', SymExpr sym BaseBoolType
p1, SymExpr sym BaseBoolType
p2) <-
    sym
-> NatRepr w
-> LLVMPtr sym w
-> Alignment
-> SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)
-> Maybe (SymBV sym w)
-> Mem sym
-> IO (Mem sym, SymExpr sym BaseBoolType, SymExpr sym BaseBoolType)
forall sym (w :: Natural).
(IsSymInterface sym, 1 <= w) =>
sym
-> NatRepr w
-> LLVMPtr sym w
-> Alignment
-> SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)
-> Maybe (SymBV sym w)
-> Mem sym
-> IO (Mem sym, Pred sym, Pred sym)
G.writeArrayConstMem sym
sym NatRepr w
forall (w :: Natural) (w' :: Natural).
(HasPtrWidth w, w ~ w') =>
NatRepr w'
PtrWidth LLVMPtr sym w
ptr Alignment
alignment SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)
arr Maybe (SymBV sym w)
len (MemImpl sym -> Mem sym
forall sym. MemImpl sym -> Mem sym
memImplHeap MemImpl sym
mem)

  let gsym :: Maybe String
gsym = Symbol -> String
unsymbol (Symbol -> String) -> Maybe Symbol -> Maybe String
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Natural Symbol -> LLVMPtr sym w -> Maybe Symbol
forall sym (w :: Natural).
IsSymInterface sym =>
Map Natural Symbol -> LLVMPtr sym w -> Maybe Symbol
isGlobalPointer (MemImpl sym -> Map Natural Symbol
forall sym. MemImpl sym -> Map Natural Symbol
memImplSymbolMap MemImpl sym
mem) LLVMPtr sym w
ptr
  let mop :: MemoryOp sym w
mop = Maybe String
-> LLVMPtr sym w
-> Maybe (SymBV sym w)
-> Mem sym
-> MemoryOp sym w
forall sym (w :: Natural).
Maybe String
-> LLVMPtr sym w
-> Maybe (SymBV sym w)
-> Mem sym
-> MemoryOp sym w
MemStoreBytesOp Maybe String
gsym LLVMPtr sym w
ptr Maybe (SymBV sym w)
len (MemImpl sym -> Mem sym
forall sym. MemImpl sym -> Mem sym
memImplHeap MemImpl sym
mem)

  bak
-> MemoryOp sym w
-> MemoryErrorReason
-> SymExpr sym BaseBoolType
-> IO ()
forall sym bak (wptr :: Natural).
(IsSymBackend sym bak, HasLLVMAnn sym, 1 <= wptr) =>
bak
-> MemErrContext sym wptr -> MemoryErrorReason -> Pred sym -> IO ()
assertStoreError bak
bak MemoryOp sym w
mop MemoryErrorReason
UnwritableRegion SymExpr sym BaseBoolType
p1
  let callStack :: CallStack
callStack = MemState sym -> CallStack
forall sym. MemState sym -> CallStack
getCallStack (MemImpl sym
mem MemImpl sym
-> Getting (MemState sym) (MemImpl sym) (MemState sym)
-> MemState sym
forall s a. s -> Getting a s a -> a
^. (MemImpl sym -> Mem sym)
-> (Mem sym -> Const (MemState sym) (Mem sym))
-> MemImpl sym
-> Const (MemState sym) (MemImpl sym)
forall (p :: Type -> Type -> Type) (f :: Type -> Type) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to MemImpl sym -> Mem sym
forall sym. MemImpl sym -> Mem sym
memImplHeap ((Mem sym -> Const (MemState sym) (Mem sym))
 -> MemImpl sym -> Const (MemState sym) (MemImpl sym))
-> ((MemState sym -> Const (MemState sym) (MemState sym))
    -> Mem sym -> Const (MemState sym) (Mem sym))
-> Getting (MemState sym) (MemImpl sym) (MemState sym)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MemState sym -> Const (MemState sym) (MemState sym))
-> Mem sym -> Const (MemState sym) (Mem sym)
forall sym (f :: Type -> Type).
Functor f =>
(MemState sym -> f (MemState sym)) -> Mem sym -> f (Mem sym)
ML.memState)
  bak
-> CallStack
-> SymExpr sym BaseBoolType
-> UndefinedBehavior (RegValue' sym)
-> IO ()
forall sym bak.
(IsSymBackend sym bak, HasLLVMAnn sym) =>
bak
-> CallStack
-> Pred sym
-> UndefinedBehavior (RegValue' sym)
-> IO ()
assertUndefined bak
bak CallStack
callStack SymExpr sym BaseBoolType
p2 (RegValue' sym (LLVMPointerType w)
-> Alignment -> UndefinedBehavior (RegValue' sym)
forall (w :: Natural) (e :: CrucibleType -> Type).
(1 <= w) =>
e (LLVMPointerType w) -> Alignment -> UndefinedBehavior e
UB.WriteBadAlignment (LLVMPtr sym w -> RegValue' sym (LLVMPointerType w)
forall sym (tp :: CrucibleType).
RegValue sym tp -> RegValue' sym tp
RV LLVMPtr sym w
ptr) Alignment
alignment)

  MemImpl sym -> IO (MemImpl sym)
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return MemImpl sym
mem { memImplHeap = heap' }

-- | Copy memory from source to destination.
--
-- Precondition: the source and destination pointers fall within valid allocated
-- regions.
doMemcpy ::
  ( 1 <= w, IsSymBackend sym bak, HasPtrWidth wptr, Partial.HasLLVMAnn sym
  , ?memOpts :: MemOptions ) =>
  bak ->
  NatRepr w ->
  MemImpl sym ->
  Bool {- ^ if true, require disjoint memory regions -} ->
  LLVMPtr sym wptr {- ^ destination -} ->
  LLVMPtr sym wptr {- ^ source      -} ->
  SymBV sym w      {- ^ length      -} ->
  IO (MemImpl sym)
doMemcpy :: forall (w :: Natural) sym bak (wptr :: Natural).
(1 <= w, IsSymBackend sym bak, HasPtrWidth wptr, HasLLVMAnn sym,
 ?memOpts::MemOptions) =>
bak
-> NatRepr w
-> MemImpl sym
-> Bool
-> LLVMPtr sym wptr
-> LLVMPtr sym wptr
-> SymBV sym w
-> IO (MemImpl sym)
doMemcpy bak
bak NatRepr w
w MemImpl sym
mem Bool
mustBeDisjoint LLVMPtr sym wptr
dest LLVMPtr sym wptr
src SymBV sym w
len = do
  let sym :: sym
sym = bak -> sym
forall sym bak. HasSymInterface sym bak => bak -> sym
backendGetSym bak
bak
  SymExpr sym (BaseBVType wptr)
len' <- sym
-> NatRepr w
-> NatRepr wptr
-> SymBV sym w
-> IO (SymExpr sym (BaseBVType wptr))
forall (w :: Natural) (w' :: Natural) sym.
(1 <= w, 1 <= w', IsSymInterface sym) =>
sym
-> NatRepr w
-> NatRepr w'
-> SymExpr sym (BaseBVType w)
-> IO (SymExpr sym (BaseBVType w'))
sextendBVTo sym
sym NatRepr w
w NatRepr wptr
forall (w :: Natural) (w' :: Natural).
(HasPtrWidth w, w ~ w') =>
NatRepr w'
PtrWidth SymBV sym w
len

  (Mem sym
heap', SymExpr sym BaseBoolType
p1, SymExpr sym BaseBoolType
p2) <- sym
-> NatRepr wptr
-> LLVMPtr sym wptr
-> LLVMPtr sym wptr
-> SymExpr sym (BaseBVType wptr)
-> Mem sym
-> IO (Mem sym, SymExpr sym BaseBoolType, SymExpr sym BaseBoolType)
forall (w :: Natural) sym.
(1 <= w, IsSymInterface sym) =>
sym
-> NatRepr w
-> LLVMPtr sym w
-> LLVMPtr sym w
-> SymBV sym w
-> Mem sym
-> IO (Mem sym, Pred sym, Pred sym)
G.copyMem sym
sym NatRepr wptr
forall (w :: Natural) (w' :: Natural).
(HasPtrWidth w, w ~ w') =>
NatRepr w'
PtrWidth LLVMPtr sym wptr
dest LLVMPtr sym wptr
src SymExpr sym (BaseBVType wptr)
len' (MemImpl sym -> Mem sym
forall sym. MemImpl sym -> Mem sym
memImplHeap MemImpl sym
mem)

  let gsym_dest :: Maybe String
gsym_dest = Symbol -> String
unsymbol (Symbol -> String) -> Maybe Symbol -> Maybe String
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Natural Symbol -> LLVMPtr sym wptr -> Maybe Symbol
forall sym (w :: Natural).
IsSymInterface sym =>
Map Natural Symbol -> LLVMPtr sym w -> Maybe Symbol
isGlobalPointer (MemImpl sym -> Map Natural Symbol
forall sym. MemImpl sym -> Map Natural Symbol
memImplSymbolMap MemImpl sym
mem) LLVMPtr sym wptr
dest
  let gsym_src :: Maybe String
gsym_src = Symbol -> String
unsymbol (Symbol -> String) -> Maybe Symbol -> Maybe String
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Natural Symbol -> LLVMPtr sym wptr -> Maybe Symbol
forall sym (w :: Natural).
IsSymInterface sym =>
Map Natural Symbol -> LLVMPtr sym w -> Maybe Symbol
isGlobalPointer (MemImpl sym -> Map Natural Symbol
forall sym. MemImpl sym -> Map Natural Symbol
memImplSymbolMap MemImpl sym
mem) LLVMPtr sym wptr
src

  let mop :: MemoryOp sym wptr
mop = (Maybe String, LLVMPtr sym wptr)
-> (Maybe String, LLVMPtr sym wptr)
-> SymBV sym w
-> Mem sym
-> MemoryOp sym wptr
forall sym (w :: Natural) (wlen :: Natural).
(1 <= wlen) =>
(Maybe String, LLVMPtr sym w)
-> (Maybe String, LLVMPtr sym w)
-> SymBV sym wlen
-> Mem sym
-> MemoryOp sym w
MemCopyOp (Maybe String
gsym_dest, LLVMPtr sym wptr
dest) (Maybe String
gsym_src, LLVMPtr sym wptr
src) SymBV sym w
len (MemImpl sym -> Mem sym
forall sym. MemImpl sym -> Mem sym
memImplHeap MemImpl sym
mem)

  SymExpr sym BaseBoolType
p1' <- Bool
-> (SymExpr sym BaseBoolType -> IO (SymExpr sym BaseBoolType))
-> SymExpr sym BaseBoolType
-> IO (SymExpr sym BaseBoolType)
forall (f :: Type -> Type) a.
Applicative f =>
Bool -> (a -> f a) -> a -> f a
applyUnless (MemOptions -> Bool
laxLoadsAndStores ?memOpts::MemOptions
MemOptions
?memOpts)
                     (sym
-> MemoryOp sym wptr
-> MemoryErrorReason
-> SymExpr sym BaseBoolType
-> IO (SymExpr sym BaseBoolType)
forall sym (w :: Natural).
(IsSymInterface sym, HasLLVMAnn sym, 1 <= w) =>
sym
-> MemoryOp sym w -> MemoryErrorReason -> Pred sym -> IO (Pred sym)
Partial.annotateME sym
sym MemoryOp sym wptr
mop MemoryErrorReason
UnreadableRegion) SymExpr sym BaseBoolType
p1
  SymExpr sym BaseBoolType
p2' <- sym
-> MemoryOp sym wptr
-> MemoryErrorReason
-> SymExpr sym BaseBoolType
-> IO (SymExpr sym BaseBoolType)
forall sym (w :: Natural).
(IsSymInterface sym, HasLLVMAnn sym, 1 <= w) =>
sym
-> MemoryOp sym w -> MemoryErrorReason -> Pred sym -> IO (Pred sym)
Partial.annotateME sym
sym MemoryOp sym wptr
mop MemoryErrorReason
UnwritableRegion SymExpr sym BaseBoolType
p2

  bak -> SymExpr sym BaseBoolType -> SimErrorReason -> IO ()
forall sym bak.
IsSymBackend sym bak =>
bak -> Pred sym -> SimErrorReason -> IO ()
assert bak
bak SymExpr sym BaseBoolType
p1' (SimErrorReason -> IO ()) -> SimErrorReason -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> SimErrorReason
AssertFailureSimError String
"Mem copy failed" String
"Invalid copy source"
  bak -> SymExpr sym BaseBoolType -> SimErrorReason -> IO ()
forall sym bak.
IsSymBackend sym bak =>
bak -> Pred sym -> SimErrorReason -> IO ()
assert bak
bak SymExpr sym BaseBoolType
p2' (SimErrorReason -> IO ()) -> SimErrorReason -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> SimErrorReason
AssertFailureSimError String
"Mem copy failed" String
"Invalid copy destination"

  Bool -> IO () -> IO ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when Bool
mustBeDisjoint (bak
-> MemoryOp sym wptr
-> NatRepr w
-> LLVMPtr sym wptr
-> SymBV sym w
-> LLVMPtr sym wptr
-> SymBV sym w
-> IO ()
forall (w :: Natural) (wptr :: Natural) sym bak.
(1 <= w, HasPtrWidth wptr, IsSymBackend sym bak, HasLLVMAnn sym) =>
bak
-> MemoryOp sym wptr
-> NatRepr w
-> LLVMPtr sym wptr
-> SymBV sym w
-> LLVMPtr sym wptr
-> SymBV sym w
-> IO ()
assertDisjointRegions bak
bak MemoryOp sym wptr
mop (SymBV sym w -> NatRepr w
forall (w :: Natural). SymExpr sym (BaseBVType w) -> NatRepr w
forall (e :: BaseType -> Type) (w :: Natural).
IsExpr e =>
e (BaseBVType w) -> NatRepr w
bvWidth SymBV sym w
len) LLVMPtr sym wptr
dest SymBV sym w
len LLVMPtr sym wptr
src SymBV sym w
len)

  MemImpl sym -> IO (MemImpl sym)
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return MemImpl sym
mem{ memImplHeap = heap' }

unsymbol :: L.Symbol -> String
unsymbol :: Symbol -> String
unsymbol (L.Symbol String
s) = String
s

-- | Copy memory from source to destination.  This version does
--   no checks to verify that the source and destination allocations
--   are allocated and appropriately sized.
uncheckedMemcpy ::
  (IsSymInterface sym, HasPtrWidth wptr) =>
  sym ->
  MemImpl sym ->
  LLVMPtr sym wptr {- ^ destination -} ->
  LLVMPtr sym wptr {- ^ source      -} ->
  SymBV sym wptr   {- ^ length      -} ->
  IO (MemImpl sym)
uncheckedMemcpy :: forall sym (wptr :: Natural).
(IsSymInterface sym, HasPtrWidth wptr) =>
sym
-> MemImpl sym
-> LLVMPtr sym wptr
-> LLVMPtr sym wptr
-> SymBV sym wptr
-> IO (MemImpl sym)
uncheckedMemcpy sym
sym MemImpl sym
mem LLVMPtr sym wptr
dest LLVMPtr sym wptr
src SymBV sym wptr
len = do
  (Mem sym
heap', SymExpr sym BaseBoolType
_p1, SymExpr sym BaseBoolType
_p2) <- sym
-> NatRepr wptr
-> LLVMPtr sym wptr
-> LLVMPtr sym wptr
-> SymBV sym wptr
-> Mem sym
-> IO (Mem sym, SymExpr sym BaseBoolType, SymExpr sym BaseBoolType)
forall (w :: Natural) sym.
(1 <= w, IsSymInterface sym) =>
sym
-> NatRepr w
-> LLVMPtr sym w
-> LLVMPtr sym w
-> SymBV sym w
-> Mem sym
-> IO (Mem sym, Pred sym, Pred sym)
G.copyMem sym
sym NatRepr wptr
forall (w :: Natural) (w' :: Natural).
(HasPtrWidth w, w ~ w') =>
NatRepr w'
PtrWidth LLVMPtr sym wptr
dest LLVMPtr sym wptr
src SymBV sym wptr
len (MemImpl sym -> Mem sym
forall sym. MemImpl sym -> Mem sym
memImplHeap MemImpl sym
mem)
  MemImpl sym -> IO (MemImpl sym)
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return MemImpl sym
mem{ memImplHeap = heap' }

doPtrSubtract ::
  (IsSymBackend sym bak, HasPtrWidth wptr, Partial.HasLLVMAnn sym) =>
  bak ->
  MemImpl sym ->
  LLVMPtr sym wptr ->
  LLVMPtr sym wptr ->
  IO (SymBV sym wptr)
doPtrSubtract :: forall sym bak (wptr :: Natural).
(IsSymBackend sym bak, HasPtrWidth wptr, HasLLVMAnn sym) =>
bak
-> MemImpl sym
-> LLVMPtr sym wptr
-> LLVMPtr sym wptr
-> IO (SymBV sym wptr)
doPtrSubtract bak
bak MemImpl sym
mem LLVMPtr sym wptr
x LLVMPtr sym wptr
y = do
  let sym :: sym
sym = bak -> sym
forall sym bak. HasSymInterface sym bak => bak -> sym
backendGetSym bak
bak
  (SymBV sym wptr
diff, SymExpr sym BaseBoolType
valid) <- sym
-> NatRepr wptr
-> LLVMPtr sym wptr
-> LLVMPtr sym wptr
-> IO (SymBV sym wptr, SymExpr sym BaseBoolType)
forall (w :: Natural) sym.
(1 <= w, IsSymInterface sym) =>
sym
-> NatRepr w
-> LLVMPtr sym w
-> LLVMPtr sym w
-> IO (SymBV sym w, Pred sym)
ptrDiff sym
sym NatRepr wptr
forall (w :: Natural) (w' :: Natural).
(HasPtrWidth w, w ~ w') =>
NatRepr w'
PtrWidth LLVMPtr sym wptr
x LLVMPtr sym wptr
y
  let callStack :: CallStack
callStack = MemState sym -> CallStack
forall sym. MemState sym -> CallStack
getCallStack (MemImpl sym
mem MemImpl sym
-> Getting (MemState sym) (MemImpl sym) (MemState sym)
-> MemState sym
forall s a. s -> Getting a s a -> a
^. (MemImpl sym -> Mem sym)
-> (Mem sym -> Const (MemState sym) (Mem sym))
-> MemImpl sym
-> Const (MemState sym) (MemImpl sym)
forall (p :: Type -> Type -> Type) (f :: Type -> Type) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to MemImpl sym -> Mem sym
forall sym. MemImpl sym -> Mem sym
memImplHeap ((Mem sym -> Const (MemState sym) (Mem sym))
 -> MemImpl sym -> Const (MemState sym) (MemImpl sym))
-> ((MemState sym -> Const (MemState sym) (MemState sym))
    -> Mem sym -> Const (MemState sym) (Mem sym))
-> Getting (MemState sym) (MemImpl sym) (MemState sym)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MemState sym -> Const (MemState sym) (MemState sym))
-> Mem sym -> Const (MemState sym) (Mem sym)
forall sym (f :: Type -> Type).
Functor f =>
(MemState sym -> f (MemState sym)) -> Mem sym -> f (Mem sym)
ML.memState)
  bak
-> CallStack
-> SymExpr sym BaseBoolType
-> UndefinedBehavior (RegValue' sym)
-> IO ()
forall sym bak.
(IsSymBackend sym bak, HasLLVMAnn sym) =>
bak
-> CallStack
-> Pred sym
-> UndefinedBehavior (RegValue' sym)
-> IO ()
assertUndefined bak
bak CallStack
callStack SymExpr sym BaseBoolType
valid (UndefinedBehavior (RegValue' sym) -> IO ())
-> UndefinedBehavior (RegValue' sym) -> IO ()
forall a b. (a -> b) -> a -> b
$
    RegValue' sym (LLVMPointerType wptr)
-> RegValue' sym (LLVMPointerType wptr)
-> UndefinedBehavior (RegValue' sym)
forall (w :: Natural) (e :: CrucibleType -> Type).
(1 <= w) =>
e (LLVMPointerType w)
-> e (LLVMPointerType w) -> UndefinedBehavior e
UB.PtrSubDifferentAllocs (LLVMPtr sym wptr -> RegValue' sym (LLVMPointerType wptr)
forall sym (tp :: CrucibleType).
RegValue sym tp -> RegValue' sym tp
RV LLVMPtr sym wptr
x) (LLVMPtr sym wptr -> RegValue' sym (LLVMPointerType wptr)
forall sym (tp :: CrucibleType).
RegValue sym tp -> RegValue' sym tp
RV LLVMPtr sym wptr
y)
  SymBV sym wptr -> IO (SymBV sym wptr)
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure SymBV sym wptr
diff

-- | Add an offset to a pointer and asserts that the result is a valid pointer.
doPtrAddOffset ::
  ( IsSymBackend sym bak, HasPtrWidth wptr, Partial.HasLLVMAnn sym
  , ?memOpts :: MemOptions ) =>
  bak ->
  MemImpl sym ->
  LLVMPtr sym wptr {- ^ base pointer -} ->
  SymBV sym wptr   {- ^ offset       -} ->
  IO (LLVMPtr sym wptr)
doPtrAddOffset :: forall sym bak (wptr :: Natural).
(IsSymBackend sym bak, HasPtrWidth wptr, HasLLVMAnn sym,
 ?memOpts::MemOptions) =>
bak
-> MemImpl sym
-> LLVMPtr sym wptr
-> SymBV sym wptr
-> IO (LLVMPtr sym wptr)
doPtrAddOffset bak
bak MemImpl sym
m LLVMPtr sym wptr
x SymBV sym wptr
off = do
  let sym :: sym
sym = bak -> sym
forall sym bak. HasSymInterface sym bak => bak -> sym
backendGetSym bak
bak
  SymExpr sym BaseBoolType
isBV <- sym -> LLVMPtr sym wptr -> IO (SymExpr sym BaseBoolType)
forall sym (w :: Natural).
IsSymInterface sym =>
sym -> LLVMPtr sym w -> IO (Pred sym)
ptrIsBv sym
sym LLVMPtr sym wptr
x
  LLVMPointer sym wptr
x' <- sym
-> NatRepr wptr
-> LLVMPtr sym wptr
-> SymBV sym wptr
-> IO (LLVMPtr sym wptr)
forall (w :: Natural) sym.
(1 <= w, IsExprBuilder sym) =>
sym
-> NatRepr w -> LLVMPtr sym w -> SymBV sym w -> IO (LLVMPtr sym w)
ptrAdd sym
sym NatRepr wptr
forall (w :: Natural) (w' :: Natural).
(HasPtrWidth w, w ~ w') =>
NatRepr w'
PtrWidth LLVMPtr sym wptr
x SymBV sym wptr
off
  SymExpr sym BaseBoolType
v <- case SymExpr sym BaseBoolType -> Maybe Bool
forall (e :: BaseType -> Type).
IsExpr e =>
e BaseBoolType -> Maybe Bool
asConstantPred SymExpr sym BaseBoolType
isBV of
         Just Bool
True  -> SymExpr sym BaseBoolType -> IO (SymExpr sym BaseBoolType)
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return SymExpr sym BaseBoolType
isBV
         Maybe Bool
_ -> sym
-> SymExpr sym BaseBoolType
-> SymExpr sym BaseBoolType
-> IO (SymExpr sym BaseBoolType)
forall sym.
IsExprBuilder sym =>
sym -> Pred sym -> Pred sym -> IO (Pred sym)
orPred sym
sym SymExpr sym BaseBoolType
isBV (SymExpr sym BaseBoolType -> IO (SymExpr sym BaseBoolType))
-> IO (SymExpr sym BaseBoolType) -> IO (SymExpr sym BaseBoolType)
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< sym
-> NatRepr wptr
-> LLVMPtr sym wptr
-> Mem sym
-> IO (SymExpr sym BaseBoolType)
forall (w :: Natural) sym.
(1 <= w, IsSymInterface sym) =>
sym -> NatRepr w -> LLVMPtr sym w -> Mem sym -> IO (Pred sym)
G.isValidPointer sym
sym NatRepr wptr
forall (w :: Natural) (w' :: Natural).
(HasPtrWidth w, w ~ w') =>
NatRepr w'
PtrWidth LLVMPtr sym wptr
LLVMPointer sym wptr
x' (MemImpl sym -> Mem sym
forall sym. MemImpl sym -> Mem sym
memImplHeap MemImpl sym
m)
  Bool -> IO () -> IO ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
unless (MemOptions -> Bool
laxLoadsAndStores ?memOpts::MemOptions
MemOptions
?memOpts) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    let callStack :: CallStack
callStack = MemState sym -> CallStack
forall sym. MemState sym -> CallStack
getCallStack (MemImpl sym
m MemImpl sym
-> Getting (MemState sym) (MemImpl sym) (MemState sym)
-> MemState sym
forall s a. s -> Getting a s a -> a
^. (MemImpl sym -> Mem sym)
-> (Mem sym -> Const (MemState sym) (Mem sym))
-> MemImpl sym
-> Const (MemState sym) (MemImpl sym)
forall (p :: Type -> Type -> Type) (f :: Type -> Type) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to MemImpl sym -> Mem sym
forall sym. MemImpl sym -> Mem sym
memImplHeap ((Mem sym -> Const (MemState sym) (Mem sym))
 -> MemImpl sym -> Const (MemState sym) (MemImpl sym))
-> ((MemState sym -> Const (MemState sym) (MemState sym))
    -> Mem sym -> Const (MemState sym) (Mem sym))
-> Getting (MemState sym) (MemImpl sym) (MemState sym)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MemState sym -> Const (MemState sym) (MemState sym))
-> Mem sym -> Const (MemState sym) (Mem sym)
forall sym (f :: Type -> Type).
Functor f =>
(MemState sym -> f (MemState sym)) -> Mem sym -> f (Mem sym)
ML.memState)
    in bak
-> CallStack
-> SymExpr sym BaseBoolType
-> UndefinedBehavior (RegValue' sym)
-> IO ()
forall sym bak.
(IsSymBackend sym bak, HasLLVMAnn sym) =>
bak
-> CallStack
-> Pred sym
-> UndefinedBehavior (RegValue' sym)
-> IO ()
assertUndefined bak
bak CallStack
callStack SymExpr sym BaseBoolType
v (RegValue' sym (LLVMPointerType wptr)
-> RegValue' sym (BVType wptr) -> UndefinedBehavior (RegValue' sym)
forall (w :: Natural) (e :: CrucibleType -> Type).
(1 <= w) =>
e (LLVMPointerType w) -> e (BVType w) -> UndefinedBehavior e
UB.PtrAddOffsetOutOfBounds (LLVMPtr sym wptr -> RegValue' sym (LLVMPointerType wptr)
forall sym (tp :: CrucibleType).
RegValue sym tp -> RegValue' sym tp
RV LLVMPtr sym wptr
x) (RegValue sym (BVType wptr) -> RegValue' sym (BVType wptr)
forall sym (tp :: CrucibleType).
RegValue sym tp -> RegValue' sym tp
RV RegValue sym (BVType wptr)
SymBV sym wptr
off))
  LLVMPointer sym wptr -> IO (LLVMPointer sym wptr)
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return LLVMPointer sym wptr
x'

-- | Store a fresh symbolic value of the appropriate size in the supplied
-- pointer. This is used in various spots whenever 'laxLoadsAndStores' is
-- enabled and 'indeterminateLoadBehavior' is set to 'StableSymbolic'.
doStoreStableSymbolic ::
  (IsSymBackend sym bak, HasPtrWidth wptr, Partial.HasLLVMAnn sym) =>
  bak ->
  MemImpl sym ->
  LLVMPtr sym wptr       {- ^ destination       -} ->
  Maybe (SymBV sym wptr) {- ^ allocation size   -} ->
  Alignment              {- ^ pointer alignment -} ->
  IO (MemImpl sym)
doStoreStableSymbolic :: forall sym bak (wptr :: Natural).
(IsSymBackend sym bak, HasPtrWidth wptr, HasLLVMAnn sym) =>
bak
-> MemImpl sym
-> LLVMPtr sym wptr
-> Maybe (SymBV sym wptr)
-> Alignment
-> IO (MemImpl sym)
doStoreStableSymbolic bak
bak MemImpl sym
mem LLVMPtr sym wptr
ptr Maybe (SymBV sym wptr)
mbSz Alignment
alignment = do
  let sym :: sym
sym = bak -> sym
forall sym bak. HasSymInterface sym bak => bak -> sym
backendGetSym bak
bak
  SymExpr
  sym ('BaseArrayType (EmptyCtx ::> 'BaseBVType wptr) (BaseBVType 8))
bytes <- sym
-> SolverSymbol
-> BaseTypeRepr
     ('BaseArrayType (EmptyCtx ::> 'BaseBVType wptr) (BaseBVType 8))
-> IO
     (SymExpr
        sym
        ('BaseArrayType (EmptyCtx ::> 'BaseBVType wptr) (BaseBVType 8)))
forall sym (tp :: BaseType).
IsSymExprBuilder sym =>
sym -> SolverSymbol -> BaseTypeRepr tp -> IO (SymExpr sym tp)
forall (tp :: BaseType).
sym -> SolverSymbol -> BaseTypeRepr tp -> IO (SymExpr sym tp)
freshConstant sym
sym SolverSymbol
emptySymbol
             (Assignment BaseTypeRepr (EmptyCtx ::> 'BaseBVType wptr)
-> BaseTypeRepr (BaseBVType 8)
-> BaseTypeRepr
     ('BaseArrayType (EmptyCtx ::> 'BaseBVType wptr) (BaseBVType 8))
forall (idx :: Ctx BaseType) (tp :: BaseType) (xs :: BaseType).
Assignment BaseTypeRepr (idx ::> tp)
-> BaseTypeRepr xs -> BaseTypeRepr ('BaseArrayType (idx ::> tp) xs)
BaseArrayRepr (BaseTypeRepr ('BaseBVType wptr)
-> Assignment BaseTypeRepr (EmptyCtx ::> 'BaseBVType wptr)
forall {k} (f :: k -> Type) (tp :: k).
f tp -> Assignment f (EmptyCtx ::> tp)
Ctx.singleton (NatRepr wptr -> BaseTypeRepr ('BaseBVType wptr)
forall (w :: Natural).
(1 <= w) =>
NatRepr w -> BaseTypeRepr ('BaseBVType w)
BaseBVRepr ?ptrWidth::NatRepr wptr
NatRepr wptr
?ptrWidth))
                            (NatRepr 8 -> BaseTypeRepr (BaseBVType 8)
forall (w :: Natural).
(1 <= w) =>
NatRepr w -> BaseTypeRepr ('BaseBVType w)
BaseBVRepr (forall (n :: Natural). KnownNat n => NatRepr n
knownNat @8)))
  case Maybe (SymBV sym wptr)
mbSz of
    Just SymBV sym wptr
sz -> bak
-> MemImpl sym
-> LLVMPtr sym wptr
-> Alignment
-> SymExpr
     sym ('BaseArrayType (EmptyCtx ::> 'BaseBVType wptr) (BaseBVType 8))
-> SymBV sym wptr
-> IO (MemImpl sym)
forall sym bak (w :: Natural).
(IsSymBackend sym bak, HasPtrWidth w, HasLLVMAnn sym) =>
bak
-> MemImpl sym
-> LLVMPtr sym w
-> Alignment
-> SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)
-> SymBV sym w
-> IO (MemImpl sym)
doArrayStore bak
bak MemImpl sym
mem LLVMPtr sym wptr
ptr Alignment
alignment SymExpr
  sym ('BaseArrayType (EmptyCtx ::> 'BaseBVType wptr) (BaseBVType 8))
bytes SymBV sym wptr
sz
    Maybe (SymBV sym wptr)
Nothing -> bak
-> MemImpl sym
-> LLVMPtr sym wptr
-> Alignment
-> SymExpr
     sym ('BaseArrayType (EmptyCtx ::> 'BaseBVType wptr) (BaseBVType 8))
-> IO (MemImpl sym)
forall sym bak (w :: Natural).
(IsSymBackend sym bak, HasPtrWidth w, HasLLVMAnn sym) =>
bak
-> MemImpl sym
-> LLVMPtr sym w
-> Alignment
-> SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)
-> IO (MemImpl sym)
doArrayStoreUnbounded bak
bak MemImpl sym
mem LLVMPtr sym wptr
ptr Alignment
alignment SymExpr
  sym ('BaseArrayType (EmptyCtx ::> 'BaseBVType wptr) (BaseBVType 8))
bytes

-- | Store a fresh symbolic value of the appropriate size in the supplied
-- pointer. This is used in various spots whenever 'laxLoadsAndStores' is
-- enabled and 'indeterminateLoadBehavior' is set to 'StableSymbolic'.
--
-- Precondition: the pointer is valid and points to a mutable or immutable
-- memory region. Therefore it can be used to initialize read-only memory
-- regions.
doConstStoreStableSymbolic ::
  (IsSymBackend sym bak, HasPtrWidth wptr, Partial.HasLLVMAnn sym) =>
  bak ->
  MemImpl sym ->
  LLVMPtr sym wptr       {- ^ destination       -} ->
  Maybe (SymBV sym wptr) {- ^ allocation size   -} ->
  Alignment              {- ^ pointer alignment -} ->
  IO (MemImpl sym)
doConstStoreStableSymbolic :: forall sym bak (wptr :: Natural).
(IsSymBackend sym bak, HasPtrWidth wptr, HasLLVMAnn sym) =>
bak
-> MemImpl sym
-> LLVMPtr sym wptr
-> Maybe (SymBV sym wptr)
-> Alignment
-> IO (MemImpl sym)
doConstStoreStableSymbolic bak
bak MemImpl sym
mem LLVMPtr sym wptr
ptr Maybe (SymBV sym wptr)
mbSz Alignment
alignment = do
  let sym :: sym
sym = bak -> sym
forall sym bak. HasSymInterface sym bak => bak -> sym
backendGetSym bak
bak
  SymExpr
  sym ('BaseArrayType (EmptyCtx ::> 'BaseBVType wptr) (BaseBVType 8))
bytes <- sym
-> SolverSymbol
-> BaseTypeRepr
     ('BaseArrayType (EmptyCtx ::> 'BaseBVType wptr) (BaseBVType 8))
-> IO
     (SymExpr
        sym
        ('BaseArrayType (EmptyCtx ::> 'BaseBVType wptr) (BaseBVType 8)))
forall sym (tp :: BaseType).
IsSymExprBuilder sym =>
sym -> SolverSymbol -> BaseTypeRepr tp -> IO (SymExpr sym tp)
forall (tp :: BaseType).
sym -> SolverSymbol -> BaseTypeRepr tp -> IO (SymExpr sym tp)
freshConstant sym
sym SolverSymbol
emptySymbol
             (Assignment BaseTypeRepr (EmptyCtx ::> 'BaseBVType wptr)
-> BaseTypeRepr (BaseBVType 8)
-> BaseTypeRepr
     ('BaseArrayType (EmptyCtx ::> 'BaseBVType wptr) (BaseBVType 8))
forall (idx :: Ctx BaseType) (tp :: BaseType) (xs :: BaseType).
Assignment BaseTypeRepr (idx ::> tp)
-> BaseTypeRepr xs -> BaseTypeRepr ('BaseArrayType (idx ::> tp) xs)
BaseArrayRepr (BaseTypeRepr ('BaseBVType wptr)
-> Assignment BaseTypeRepr (EmptyCtx ::> 'BaseBVType wptr)
forall {k} (f :: k -> Type) (tp :: k).
f tp -> Assignment f (EmptyCtx ::> tp)
Ctx.singleton (NatRepr wptr -> BaseTypeRepr ('BaseBVType wptr)
forall (w :: Natural).
(1 <= w) =>
NatRepr w -> BaseTypeRepr ('BaseBVType w)
BaseBVRepr ?ptrWidth::NatRepr wptr
NatRepr wptr
?ptrWidth))
                            (NatRepr 8 -> BaseTypeRepr (BaseBVType 8)
forall (w :: Natural).
(1 <= w) =>
NatRepr w -> BaseTypeRepr ('BaseBVType w)
BaseBVRepr (forall (n :: Natural). KnownNat n => NatRepr n
knownNat @8)))
  case Maybe (SymBV sym wptr)
mbSz of
    Just SymBV sym wptr
sz -> bak
-> MemImpl sym
-> LLVMPtr sym wptr
-> Alignment
-> SymExpr
     sym ('BaseArrayType (EmptyCtx ::> 'BaseBVType wptr) (BaseBVType 8))
-> SymBV sym wptr
-> IO (MemImpl sym)
forall sym bak (w :: Natural).
(IsSymBackend sym bak, HasPtrWidth w, HasLLVMAnn sym) =>
bak
-> MemImpl sym
-> LLVMPtr sym w
-> Alignment
-> SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)
-> SymBV sym w
-> IO (MemImpl sym)
doArrayConstStore bak
bak MemImpl sym
mem LLVMPtr sym wptr
ptr Alignment
alignment SymExpr
  sym ('BaseArrayType (EmptyCtx ::> 'BaseBVType wptr) (BaseBVType 8))
bytes SymBV sym wptr
sz
    Maybe (SymBV sym wptr)
Nothing -> bak
-> MemImpl sym
-> LLVMPtr sym wptr
-> Alignment
-> SymExpr
     sym ('BaseArrayType (EmptyCtx ::> 'BaseBVType wptr) (BaseBVType 8))
-> IO (MemImpl sym)
forall sym bak (w :: Natural).
(IsSymBackend sym bak, HasPtrWidth w, HasLLVMAnn sym) =>
bak
-> MemImpl sym
-> LLVMPtr sym w
-> Alignment
-> SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)
-> IO (MemImpl sym)
doArrayConstStoreUnbounded bak
bak MemImpl sym
mem LLVMPtr sym wptr
ptr Alignment
alignment SymExpr
  sym ('BaseArrayType (EmptyCtx ::> 'BaseBVType wptr) (BaseBVType 8))
bytes

-- | This predicate tests if the pointer is a valid, live pointer
--   into the heap, OR is the distinguished NULL pointer.
isValidPointer ::
  (IsSymInterface sym, HasPtrWidth wptr) =>
  sym ->
  LLVMPtr sym wptr ->
  MemImpl sym ->
  IO (Pred sym)
isValidPointer :: forall sym (wptr :: Natural).
(IsSymInterface sym, HasPtrWidth wptr) =>
sym -> LLVMPtr sym wptr -> MemImpl sym -> IO (Pred sym)
isValidPointer sym
sym LLVMPtr sym wptr
p MemImpl sym
mem =
   do Pred sym
np <- sym -> NatRepr wptr -> LLVMPtr sym wptr -> IO (Pred sym)
forall (w :: Natural) sym.
(1 <= w, IsSymInterface sym) =>
sym -> NatRepr w -> LLVMPtr sym w -> IO (Pred sym)
ptrIsNull sym
sym NatRepr wptr
forall (w :: Natural) (w' :: Natural).
(HasPtrWidth w, w ~ w') =>
NatRepr w'
PtrWidth LLVMPtr sym wptr
p
      case Pred sym -> Maybe Bool
forall (e :: BaseType -> Type).
IsExpr e =>
e BaseBoolType -> Maybe Bool
asConstantPred Pred sym
np of
        Just Bool
True  -> Pred sym -> IO (Pred sym)
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Pred sym
np
        Just Bool
False -> sym -> NatRepr wptr -> LLVMPtr sym wptr -> Mem sym -> IO (Pred sym)
forall (w :: Natural) sym.
(1 <= w, IsSymInterface sym) =>
sym -> NatRepr w -> LLVMPtr sym w -> Mem sym -> IO (Pred sym)
G.isValidPointer sym
sym NatRepr wptr
forall (w :: Natural) (w' :: Natural).
(HasPtrWidth w, w ~ w') =>
NatRepr w'
PtrWidth LLVMPtr sym wptr
p (MemImpl sym -> Mem sym
forall sym. MemImpl sym -> Mem sym
memImplHeap MemImpl sym
mem)
        Maybe Bool
_ -> sym -> Pred sym -> Pred sym -> IO (Pred sym)
forall sym.
IsExprBuilder sym =>
sym -> Pred sym -> Pred sym -> IO (Pred sym)
orPred sym
sym Pred sym
np (Pred sym -> IO (Pred sym)) -> IO (Pred sym) -> IO (Pred sym)
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< sym -> NatRepr wptr -> LLVMPtr sym wptr -> Mem sym -> IO (Pred sym)
forall (w :: Natural) sym.
(1 <= w, IsSymInterface sym) =>
sym -> NatRepr w -> LLVMPtr sym w -> Mem sym -> IO (Pred sym)
G.isValidPointer sym
sym NatRepr wptr
forall (w :: Natural) (w' :: Natural).
(HasPtrWidth w, w ~ w') =>
NatRepr w'
PtrWidth LLVMPtr sym wptr
p (MemImpl sym -> Mem sym
forall sym. MemImpl sym -> Mem sym
memImplHeap MemImpl sym
mem)

-- | Return the condition required to prove that the pointer points to
-- a range of 'size' bytes that falls within an allocated region of
-- the appropriate mutability, and also that the pointer is
-- sufficiently aligned.
isAllocatedAlignedPointer ::
  (1 <= w, IsSymInterface sym) =>
  sym -> NatRepr w ->
  Alignment           {- ^ minimum required pointer alignment                 -} ->
  G.Mutability        {- ^ 'Mutable' means pointed-to region must be writable -} ->
  LLVMPtr sym w       {- ^ pointer                                            -} ->
  Maybe (SymBV sym w) {- ^ size (@Nothing@ means entire address space)        -} ->
  MemImpl sym         {- ^ memory                                             -} ->
  IO (Pred sym)
isAllocatedAlignedPointer :: forall (w :: Natural) sym.
(1 <= w, IsSymInterface sym) =>
sym
-> NatRepr w
-> Alignment
-> Mutability
-> LLVMPtr sym w
-> Maybe (SymBV sym w)
-> MemImpl sym
-> IO (Pred sym)
isAllocatedAlignedPointer sym
sym NatRepr w
w Alignment
alignment Mutability
mutability LLVMPtr sym w
ptr Maybe (SymBV sym w)
size MemImpl sym
mem =
  sym
-> NatRepr w
-> Alignment
-> Mutability
-> LLVMPtr sym w
-> Maybe (SymBV sym w)
-> Mem sym
-> IO (SymExpr sym BaseBoolType)
forall (w :: Natural) sym.
(1 <= w, IsSymInterface sym) =>
sym
-> NatRepr w
-> Alignment
-> Mutability
-> LLVMPtr sym w
-> Maybe (SymBV sym w)
-> Mem sym
-> IO (Pred sym)
G.isAllocatedAlignedPointer sym
sym NatRepr w
w Alignment
alignment Mutability
mutability LLVMPtr sym w
ptr Maybe (SymBV sym w)
size (MemImpl sym -> Mem sym
forall sym. MemImpl sym -> Mem sym
memImplHeap MemImpl sym
mem)

-- | Compute the length of a null-terminated string.
--
--   The pointer to read from must be concrete and nonnull.  The contents
--   of the string may be symbolic; HOWEVER, this function will not terminate
--   until it eventually reaches a concete null-terminator or a load error.
strLen ::
  ( IsSymBackend sym bak, HasPtrWidth wptr, Partial.HasLLVMAnn sym
  , ?memOpts :: MemOptions ) =>
  bak ->
  MemImpl sym      {- ^ memory to read from        -} ->
  LLVMPtr sym wptr {- ^ pointer to string value    -} ->
  IO (SymBV sym wptr)
strLen :: forall sym bak (wptr :: Natural).
(IsSymBackend sym bak, HasPtrWidth wptr, HasLLVMAnn sym,
 ?memOpts::MemOptions) =>
bak -> MemImpl sym -> LLVMPtr sym wptr -> IO (SymBV sym wptr)
strLen bak
bak MemImpl sym
mem = BV wptr
-> SymExpr sym BaseBoolType
-> LLVMPointer sym wptr
-> IO (SymExpr sym ('BaseBVType wptr))
go (NatRepr wptr -> BV wptr
forall (w :: Natural). NatRepr w -> BV w
BV.zero NatRepr wptr
forall (w :: Natural) (w' :: Natural).
(HasPtrWidth w, w ~ w') =>
NatRepr w'
PtrWidth) (sym -> SymExpr sym BaseBoolType
forall sym. IsExprBuilder sym => sym -> Pred sym
truePred sym
sym)
  where
  sym :: sym
sym = bak -> sym
forall sym bak. HasSymInterface sym bak => bak -> sym
backendGetSym bak
bak

  go :: BV wptr
-> SymExpr sym BaseBoolType
-> LLVMPointer sym wptr
-> IO (SymExpr sym ('BaseBVType wptr))
go !BV wptr
n SymExpr sym BaseBoolType
cond LLVMPointer sym wptr
p =
    sym
-> MemImpl sym
-> RegValue
     sym (IntrinsicType "LLVM_pointer" ('EmptyCtx '::> BVType wptr))
-> StorageType
-> Alignment
-> IO (PartLLVMVal sym)
forall sym (wptr :: Natural).
(IsSymInterface sym, HasPtrWidth wptr, HasLLVMAnn sym,
 ?memOpts::MemOptions) =>
sym
-> MemImpl sym
-> LLVMPtr sym wptr
-> StorageType
-> Alignment
-> IO (PartLLVMVal sym)
loadRaw sym
sym MemImpl sym
mem RegValue
  sym (IntrinsicType "LLVM_pointer" ('EmptyCtx '::> BVType wptr))
LLVMPointer sym wptr
p (Bytes -> StorageType
bitvectorType Bytes
1) Alignment
noAlignment IO (PartLLVMVal sym)
-> (PartLLVMVal sym -> IO (SymExpr sym ('BaseBVType wptr)))
-> IO (SymExpr sym ('BaseBVType wptr))
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Partial.Err SymExpr sym BaseBoolType
pe ->
        do SymExpr sym BaseBoolType
ast <- sym
-> SymExpr sym BaseBoolType
-> SymExpr sym BaseBoolType
-> IO (SymExpr sym BaseBoolType)
forall sym.
IsExprBuilder sym =>
sym -> Pred sym -> Pred sym -> IO (Pred sym)
impliesPred sym
sym SymExpr sym BaseBoolType
cond SymExpr sym BaseBoolType
pe
           bak -> SymExpr sym BaseBoolType -> SimErrorReason -> IO ()
forall sym bak.
IsSymBackend sym bak =>
bak -> Pred sym -> SimErrorReason -> IO ()
assert bak
bak SymExpr sym BaseBoolType
ast (SimErrorReason -> IO ()) -> SimErrorReason -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> SimErrorReason
AssertFailureSimError String
"Error during memory load: strlen" String
""
           sym -> NatRepr wptr -> IO (SymExpr sym ('BaseBVType wptr))
forall (w :: Natural) sym.
(1 <= w, IsExprBuilder sym) =>
sym -> NatRepr w -> IO (SymBV sym w)
bvZero sym
sym NatRepr wptr
forall (w :: Natural) (w' :: Natural).
(HasPtrWidth w, w ~ w') =>
NatRepr w'
PtrWidth -- bogus value, but have to return something...
      Partial.NoErr SymExpr sym BaseBoolType
loadok LLVMVal sym
llvmval ->
        do SymExpr sym BaseBoolType
ast <- sym
-> SymExpr sym BaseBoolType
-> SymExpr sym BaseBoolType
-> IO (SymExpr sym BaseBoolType)
forall sym.
IsExprBuilder sym =>
sym -> Pred sym -> Pred sym -> IO (Pred sym)
impliesPred sym
sym SymExpr sym BaseBoolType
cond SymExpr sym BaseBoolType
loadok
           bak -> SymExpr sym BaseBoolType -> SimErrorReason -> IO ()
forall sym bak.
IsSymBackend sym bak =>
bak -> Pred sym -> SimErrorReason -> IO ()
assert bak
bak SymExpr sym BaseBoolType
ast (SimErrorReason -> IO ()) -> SimErrorReason -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> SimErrorReason
AssertFailureSimError String
"Error during memory load: strlen" String
""
           RegValue sym (LLVMPointerType 8)
v <- sym
-> TypeRepr (LLVMPointerType 8)
-> LLVMVal sym
-> IO (RegValue sym (LLVMPointerType 8))
forall sym (tp :: CrucibleType).
(HasCallStack, IsSymInterface sym) =>
sym -> TypeRepr tp -> LLVMVal sym -> IO (RegValue sym tp)
unpackMemValue sym
sym (NatRepr 8 -> TypeRepr (LLVMPointerType 8)
forall (ty :: CrucibleType) (w :: Natural).
(1 <= w, ty ~ LLVMPointerType w) =>
NatRepr w -> TypeRepr ty
LLVMPointerRepr (forall (n :: Natural). KnownNat n => NatRepr n
knownNat @8)) LLVMVal sym
llvmval
           let err :: SimErrorReason
err = String -> String -> SimErrorReason
AssertFailureSimError String
"Found pointer instead of byte in string passed to `strlen`" String
""
           SymExpr sym BaseBoolType
test <- sym -> SymExpr sym (BaseBVType 8) -> IO (SymExpr sym BaseBoolType)
forall (w :: Natural).
(1 <= w) =>
sym -> SymBV sym w -> IO (SymExpr sym BaseBoolType)
forall sym (w :: Natural).
(IsExprBuilder sym, 1 <= w) =>
sym -> SymBV sym w -> IO (Pred sym)
bvIsNonzero sym
sym (SymExpr sym (BaseBVType 8) -> IO (SymExpr sym BaseBoolType))
-> IO (SymExpr sym (BaseBVType 8)) -> IO (SymExpr sym BaseBoolType)
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< bak
-> SimErrorReason
-> RegValue sym (LLVMPointerType 8)
-> IO (SymExpr sym (BaseBVType 8))
forall sym bak (w :: Natural).
IsSymBackend sym bak =>
bak -> SimErrorReason -> LLVMPtr sym w -> IO (SymBV sym w)
Partial.ptrToBv bak
bak SimErrorReason
err RegValue sym (LLVMPointerType 8)
v
           (sym
 -> SymExpr sym BaseBoolType
 -> SymExpr sym ('BaseBVType wptr)
 -> SymExpr sym ('BaseBVType wptr)
 -> IO (SymExpr sym ('BaseBVType wptr)))
-> sym
-> SymExpr sym BaseBoolType
-> IO (SymExpr sym ('BaseBVType wptr))
-> IO (SymExpr sym ('BaseBVType wptr))
-> IO (SymExpr sym ('BaseBVType wptr))
forall sym v.
IsExprBuilder sym =>
(sym -> Pred sym -> v -> v -> IO v)
-> sym -> Pred sym -> IO v -> IO v -> IO v
iteM sym
-> SymExpr sym BaseBoolType
-> SymExpr sym ('BaseBVType wptr)
-> SymExpr sym ('BaseBVType wptr)
-> IO (SymExpr sym ('BaseBVType wptr))
forall (w :: Natural).
(1 <= w) =>
sym
-> SymExpr sym BaseBoolType
-> SymBV sym w
-> SymBV sym w
-> IO (SymBV sym w)
forall sym (w :: Natural).
(IsExprBuilder sym, 1 <= w) =>
sym -> Pred sym -> SymBV sym w -> SymBV sym w -> IO (SymBV sym w)
bvIte sym
sym
             SymExpr sym BaseBoolType
test
             (do SymExpr sym BaseBoolType
cond' <- sym
-> SymExpr sym BaseBoolType
-> SymExpr sym BaseBoolType
-> IO (SymExpr sym BaseBoolType)
forall sym.
IsExprBuilder sym =>
sym -> Pred sym -> Pred sym -> IO (Pred sym)
andPred sym
sym SymExpr sym BaseBoolType
cond SymExpr sym BaseBoolType
test
                 LLVMPointer sym wptr
p'    <- bak
-> MemImpl sym
-> RegValue
     sym (IntrinsicType "LLVM_pointer" ('EmptyCtx '::> BVType wptr))
-> SymExpr sym ('BaseBVType wptr)
-> IO
     (RegValue
        sym (IntrinsicType "LLVM_pointer" ('EmptyCtx '::> BVType wptr)))
forall sym bak (wptr :: Natural).
(IsSymBackend sym bak, HasPtrWidth wptr, HasLLVMAnn sym,
 ?memOpts::MemOptions) =>
bak
-> MemImpl sym
-> LLVMPtr sym wptr
-> SymBV sym wptr
-> IO (LLVMPtr sym wptr)
doPtrAddOffset bak
bak MemImpl sym
mem RegValue
  sym (IntrinsicType "LLVM_pointer" ('EmptyCtx '::> BVType wptr))
LLVMPointer sym wptr
p (SymExpr sym ('BaseBVType wptr) -> IO (LLVMPointer sym wptr))
-> IO (SymExpr sym ('BaseBVType wptr)) -> IO (LLVMPointer sym wptr)
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< sym -> NatRepr wptr -> IO (SymExpr sym ('BaseBVType wptr))
forall (w :: Natural) sym.
(1 <= w, IsExprBuilder sym) =>
sym -> NatRepr w -> IO (SymBV sym w)
bvOne sym
sym NatRepr wptr
forall (w :: Natural) (w' :: Natural).
(HasPtrWidth w, w ~ w') =>
NatRepr w'
PtrWidth
                 case NatRepr wptr -> BV wptr -> Maybe (BV wptr)
forall (w :: Natural). NatRepr w -> BV w -> Maybe (BV w)
BV.succUnsigned NatRepr wptr
forall (w :: Natural) (w' :: Natural).
(HasPtrWidth w, w ~ w') =>
NatRepr w'
PtrWidth BV wptr
n of
                   Just BV wptr
n_1 -> BV wptr
-> SymExpr sym BaseBoolType
-> LLVMPointer sym wptr
-> IO (SymExpr sym ('BaseBVType wptr))
go BV wptr
n_1 SymExpr sym BaseBoolType
cond' LLVMPointer sym wptr
p'
                   Maybe (BV wptr)
Nothing -> String -> [String] -> IO (SymExpr sym ('BaseBVType wptr))
forall a. HasCallStack => String -> [String] -> a
panic String
"Lang.Crucible.LLVM.MemModel.strLen" [String
"string length exceeds pointer width"])
             (sym
-> NatRepr wptr -> BV wptr -> IO (SymExpr sym ('BaseBVType wptr))
forall (w :: Natural).
(1 <= w) =>
sym -> NatRepr w -> BV w -> IO (SymBV sym w)
forall sym (w :: Natural).
(IsExprBuilder sym, 1 <= w) =>
sym -> NatRepr w -> BV w -> IO (SymBV sym w)
bvLit sym
sym NatRepr wptr
forall (w :: Natural) (w' :: Natural).
(HasPtrWidth w, w ~ w') =>
NatRepr w'
PtrWidth BV wptr
n)


-- | Load a null-terminated string from the memory.
--
-- The pointer to read from must be concrete and nonnull.  Moreover,
-- we require all the characters in the string to be concrete.
-- Otherwise it is very difficult to tell when the string has
-- terminated.  If a maximum number of characters is provided, no more
-- than that number of charcters will be read.  In either case,
-- `loadString` will stop reading if it encounters a null-terminator.
loadString :: forall sym bak wptr.
  ( IsSymBackend sym bak, HasPtrWidth wptr, Partial.HasLLVMAnn sym
  , ?memOpts :: MemOptions, GHC.HasCallStack ) =>
  bak ->
  MemImpl sym      {- ^ memory to read from        -} ->
  LLVMPtr sym wptr {- ^ pointer to string value    -} ->
  Maybe Int        {- ^ maximum characters to read -} ->
  IO [Word8]
loadString :: forall sym bak (wptr :: Natural).
(IsSymBackend sym bak, HasPtrWidth wptr, HasLLVMAnn sym,
 ?memOpts::MemOptions, HasCallStack) =>
bak -> MemImpl sym -> LLVMPtr sym wptr -> Maybe Int -> IO [Word8]
loadString bak
bak MemImpl sym
mem = ([Word8] -> [Word8]) -> LLVMPtr sym wptr -> Maybe Int -> IO [Word8]
go [Word8] -> [Word8]
forall a. a -> a
id
 where
  sym :: sym
sym = bak -> sym
forall sym bak. HasSymInterface sym bak => bak -> sym
backendGetSym bak
bak

  go :: ([Word8] -> [Word8]) -> LLVMPtr sym wptr -> Maybe Int -> IO [Word8]
  go :: ([Word8] -> [Word8]) -> LLVMPtr sym wptr -> Maybe Int -> IO [Word8]
go [Word8] -> [Word8]
f LLVMPtr sym wptr
_ (Just Int
0) = [Word8] -> IO [Word8]
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([Word8] -> IO [Word8]) -> [Word8] -> IO [Word8]
forall a b. (a -> b) -> a -> b
$ [Word8] -> [Word8]
f []
  go [Word8] -> [Word8]
f LLVMPtr sym wptr
p Maybe Int
maxChars = do
     RegValue sym (LLVMPointerType 8)
v <- bak
-> MemImpl sym
-> LLVMPtr sym wptr
-> StorageType
-> TypeRepr (LLVMPointerType 8)
-> Alignment
-> IO (RegValue sym (LLVMPointerType 8))
forall sym bak (wptr :: Natural) (tp :: CrucibleType).
(IsSymBackend sym bak, HasPtrWidth wptr, HasLLVMAnn sym,
 ?memOpts::MemOptions) =>
bak
-> MemImpl sym
-> LLVMPtr sym wptr
-> StorageType
-> TypeRepr tp
-> Alignment
-> IO (RegValue sym tp)
doLoad bak
bak MemImpl sym
mem LLVMPtr sym wptr
p (Bytes -> StorageType
bitvectorType Bytes
1) (NatRepr 8 -> TypeRepr (LLVMPointerType 8)
forall (ty :: CrucibleType) (w :: Natural).
(1 <= w, ty ~ LLVMPointerType w) =>
NatRepr w -> TypeRepr ty
LLVMPointerRepr (NatRepr 8
forall (n :: Natural). KnownNat n => NatRepr n
knownNat :: NatRepr 8)) Alignment
noAlignment
     let err :: SimErrorReason
err = String -> String -> SimErrorReason
AssertFailureSimError String
"Found pointer instead of byte when loading string" String
""
     SymExpr sym (BaseBVType 8)
x <- bak
-> SimErrorReason
-> RegValue sym (LLVMPointerType 8)
-> IO (SymExpr sym (BaseBVType 8))
forall sym bak (w :: Natural).
IsSymBackend sym bak =>
bak -> SimErrorReason -> LLVMPtr sym w -> IO (SymBV sym w)
Partial.ptrToBv bak
bak SimErrorReason
err RegValue sym (LLVMPointerType 8)
v
     case BV 8 -> Integer
forall (w :: Natural). BV w -> Integer
BV.asUnsigned (BV 8 -> Integer) -> Maybe (BV 8) -> Maybe Integer
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> SymExpr sym (BaseBVType 8) -> Maybe (BV 8)
forall (w :: Natural). SymExpr sym (BaseBVType w) -> Maybe (BV w)
forall (e :: BaseType -> Type) (w :: Natural).
IsExpr e =>
e (BaseBVType w) -> Maybe (BV w)
asBV SymExpr sym (BaseBVType 8)
x of
       Just Integer
0 -> [Word8] -> IO [Word8]
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([Word8] -> IO [Word8]) -> [Word8] -> IO [Word8]
forall a b. (a -> b) -> a -> b
$ [Word8] -> [Word8]
f []
       Just Integer
c -> do
           let Word8
c' :: Word8 = Int -> Word8
forall a. Enum a => Int -> a
toEnum (Int -> Word8) -> Int -> Word8
forall a b. (a -> b) -> a -> b
$ Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
c
           LLVMPointer sym wptr
p' <- bak
-> MemImpl sym
-> LLVMPtr sym wptr
-> SymExpr sym (BaseBVType wptr)
-> IO (LLVMPtr sym wptr)
forall sym bak (wptr :: Natural).
(IsSymBackend sym bak, HasPtrWidth wptr, HasLLVMAnn sym,
 ?memOpts::MemOptions) =>
bak
-> MemImpl sym
-> LLVMPtr sym wptr
-> SymBV sym wptr
-> IO (LLVMPtr sym wptr)
doPtrAddOffset bak
bak MemImpl sym
mem LLVMPtr sym wptr
p (SymExpr sym (BaseBVType wptr) -> IO (LLVMPointer sym wptr))
-> IO (SymExpr sym (BaseBVType wptr)) -> IO (LLVMPointer sym wptr)
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< sym -> NatRepr wptr -> IO (SymExpr sym (BaseBVType wptr))
forall (w :: Natural) sym.
(1 <= w, IsExprBuilder sym) =>
sym -> NatRepr w -> IO (SymBV sym w)
bvOne sym
sym NatRepr wptr
forall (w :: Natural) (w' :: Natural).
(HasPtrWidth w, w ~ w') =>
NatRepr w'
PtrWidth
           ([Word8] -> [Word8]) -> LLVMPtr sym wptr -> Maybe Int -> IO [Word8]
go ([Word8] -> [Word8]
f ([Word8] -> [Word8]) -> ([Word8] -> [Word8]) -> [Word8] -> [Word8]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8
c'Word8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
:)) LLVMPtr sym wptr
LLVMPointer sym wptr
p' ((Int -> Int) -> Maybe Int -> Maybe Int
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Int
n -> Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Maybe Int
maxChars)
       Maybe Integer
Nothing ->
         bak -> SimErrorReason -> IO [Word8]
forall sym bak a.
IsSymBackend sym bak =>
bak -> SimErrorReason -> IO a
addFailedAssertion bak
bak
            (SimErrorReason -> IO [Word8]) -> SimErrorReason -> IO [Word8]
forall a b. (a -> b) -> a -> b
$ CallStack -> String -> SimErrorReason
Unsupported CallStack
HasCallStack => CallStack
GHC.callStack String
"Symbolic value encountered when loading a string"

-- | Like 'loadString', except the pointer to load may be null.  If
--   the pointer is null, we return Nothing.  Otherwise we load
--   the string as with 'loadString' and return it.
loadMaybeString ::
  ( IsSymBackend sym bak, HasPtrWidth wptr, Partial.HasLLVMAnn sym
  , ?memOpts :: MemOptions, GHC.HasCallStack ) =>
  bak ->
  MemImpl sym      {- ^ memory to read from        -} ->
  LLVMPtr sym wptr {- ^ pointer to string value    -} ->
  Maybe Int        {- ^ maximum characters to read -} ->
  IO (Maybe [Word8])
loadMaybeString :: forall sym bak (wptr :: Natural).
(IsSymBackend sym bak, HasPtrWidth wptr, HasLLVMAnn sym,
 ?memOpts::MemOptions, HasCallStack) =>
bak
-> MemImpl sym
-> LLVMPtr sym wptr
-> Maybe Int
-> IO (Maybe [Word8])
loadMaybeString bak
bak MemImpl sym
mem LLVMPtr sym wptr
ptr Maybe Int
n = do
  let sym :: sym
sym = bak -> sym
forall sym bak. HasSymInterface sym bak => bak -> sym
backendGetSym bak
bak
  SymExpr sym BaseBoolType
isnull <- sym
-> NatRepr wptr
-> LLVMPtr sym wptr
-> IO (SymExpr sym BaseBoolType)
forall (w :: Natural) sym.
(1 <= w, IsSymInterface sym) =>
sym -> NatRepr w -> LLVMPtr sym w -> IO (Pred sym)
ptrIsNull sym
sym NatRepr wptr
forall (w :: Natural) (w' :: Natural).
(HasPtrWidth w, w ~ w') =>
NatRepr w'
PtrWidth LLVMPtr sym wptr
ptr
  case SymExpr sym BaseBoolType -> Maybe Bool
forall (e :: BaseType -> Type).
IsExpr e =>
e BaseBoolType -> Maybe Bool
asConstantPred SymExpr sym BaseBoolType
isnull of
    Maybe Bool
Nothing    -> bak -> SimErrorReason -> IO (Maybe [Word8])
forall sym bak a.
IsSymBackend sym bak =>
bak -> SimErrorReason -> IO a
addFailedAssertion bak
bak
                    (SimErrorReason -> IO (Maybe [Word8]))
-> SimErrorReason -> IO (Maybe [Word8])
forall a b. (a -> b) -> a -> b
$ CallStack -> String -> SimErrorReason
Unsupported CallStack
HasCallStack => CallStack
GHC.callStack String
"Symbolic pointer encountered when loading a string"
    Just Bool
True  -> Maybe [Word8] -> IO (Maybe [Word8])
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe [Word8]
forall a. Maybe a
Nothing
    Just Bool
False -> [Word8] -> Maybe [Word8]
forall a. a -> Maybe a
Just ([Word8] -> Maybe [Word8]) -> IO [Word8] -> IO (Maybe [Word8])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> bak -> MemImpl sym -> LLVMPtr sym wptr -> Maybe Int -> IO [Word8]
forall sym bak (wptr :: Natural).
(IsSymBackend sym bak, HasPtrWidth wptr, HasLLVMAnn sym,
 ?memOpts::MemOptions, HasCallStack) =>
bak -> MemImpl sym -> LLVMPtr sym wptr -> Maybe Int -> IO [Word8]
loadString bak
bak MemImpl sym
mem LLVMPtr sym wptr
ptr Maybe Int
n


toStorableType :: (MonadFail m, HasPtrWidth wptr)
               => MemType
               -> m StorageType
toStorableType :: forall (m :: Type -> Type) (wptr :: Natural).
(MonadFail m, HasPtrWidth wptr) =>
MemType -> m StorageType
toStorableType MemType
mt =
  case MemType
mt of
    IntType Natural
n -> StorageType -> m StorageType
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (StorageType -> m StorageType) -> StorageType -> m StorageType
forall a b. (a -> b) -> a -> b
$ Bytes -> StorageType
bitvectorType (Natural -> Bytes
forall a. Integral a => a -> Bytes
bitsToBytes Natural
n)
    PtrType SymType
_ -> StorageType -> m StorageType
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (StorageType -> m StorageType) -> StorageType -> m StorageType
forall a b. (a -> b) -> a -> b
$ Bytes -> StorageType
bitvectorType (Natural -> Bytes
forall a. Integral a => a -> Bytes
bitsToBytes (NatRepr wptr -> Natural
forall (n :: Natural). NatRepr n -> Natural
natValue NatRepr wptr
forall (w :: Natural) (w' :: Natural).
(HasPtrWidth w, w ~ w') =>
NatRepr w'
PtrWidth))
    MemType
PtrOpaqueType -> StorageType -> m StorageType
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (StorageType -> m StorageType) -> StorageType -> m StorageType
forall a b. (a -> b) -> a -> b
$ Bytes -> StorageType
bitvectorType (Natural -> Bytes
forall a. Integral a => a -> Bytes
bitsToBytes (NatRepr wptr -> Natural
forall (n :: Natural). NatRepr n -> Natural
natValue NatRepr wptr
forall (w :: Natural) (w' :: Natural).
(HasPtrWidth w, w ~ w') =>
NatRepr w'
PtrWidth))
    MemType
FloatType -> StorageType -> m StorageType
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (StorageType -> m StorageType) -> StorageType -> m StorageType
forall a b. (a -> b) -> a -> b
$ StorageType
floatType
    MemType
DoubleType -> StorageType -> m StorageType
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (StorageType -> m StorageType) -> StorageType -> m StorageType
forall a b. (a -> b) -> a -> b
$ StorageType
doubleType
    MemType
X86_FP80Type -> StorageType -> m StorageType
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (StorageType -> m StorageType) -> StorageType -> m StorageType
forall a b. (a -> b) -> a -> b
$ StorageType
x86_fp80Type
    ArrayType Natural
n MemType
x -> Natural -> StorageType -> StorageType
arrayType (Natural -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
n) (StorageType -> StorageType) -> m StorageType -> m StorageType
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> MemType -> m StorageType
forall (m :: Type -> Type) (wptr :: Natural).
(MonadFail m, HasPtrWidth wptr) =>
MemType -> m StorageType
toStorableType MemType
x
    VecType Natural
n MemType
x -> Natural -> StorageType -> StorageType
arrayType (Natural -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
n) (StorageType -> StorageType) -> m StorageType -> m StorageType
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> MemType -> m StorageType
forall (m :: Type -> Type) (wptr :: Natural).
(MonadFail m, HasPtrWidth wptr) =>
MemType -> m StorageType
toStorableType MemType
x
    MemType
MetadataType -> String -> m StorageType
forall a. String -> m a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail String
"toStorableType: Cannot store metadata values"
    StructType StructInfo
si -> Vector (StorageType, Bytes) -> StorageType
mkStructType (Vector (StorageType, Bytes) -> StorageType)
-> m (Vector (StorageType, Bytes)) -> m StorageType
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (FieldInfo -> m (StorageType, Bytes))
-> Vector FieldInfo -> m (Vector (StorageType, Bytes))
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> Vector a -> f (Vector b)
traverse FieldInfo -> m (StorageType, Bytes)
forall (m :: Type -> Type).
MonadFail m =>
FieldInfo -> m (StorageType, Bytes)
transField (StructInfo -> Vector FieldInfo
siFields StructInfo
si)
      where transField :: MonadFail m => FieldInfo -> m (StorageType, Bytes)
            transField :: forall (m :: Type -> Type).
MonadFail m =>
FieldInfo -> m (StorageType, Bytes)
transField FieldInfo
fi = do
               StorageType
t <- MemType -> m StorageType
forall (m :: Type -> Type) (wptr :: Natural).
(MonadFail m, HasPtrWidth wptr) =>
MemType -> m StorageType
toStorableType (MemType -> m StorageType) -> MemType -> m StorageType
forall a b. (a -> b) -> a -> b
$ FieldInfo -> MemType
fiType FieldInfo
fi
               (StorageType, Bytes) -> m (StorageType, Bytes)
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (StorageType
t, FieldInfo -> Bytes
fiPadding FieldInfo
fi)

----------------------------------------------------------------------
-- "Raw" operations
--

-- | Load an LLVM value from memory. Asserts that the pointer is valid and the
-- result value is not undefined.
loadRaw :: ( IsSymInterface sym, HasPtrWidth wptr, Partial.HasLLVMAnn sym
           , ?memOpts :: MemOptions )
        => sym
        -> MemImpl sym
        -> LLVMPtr sym wptr
        -> StorageType
        -> Alignment
        -> IO (Partial.PartLLVMVal sym)
loadRaw :: forall sym (wptr :: Natural).
(IsSymInterface sym, HasPtrWidth wptr, HasLLVMAnn sym,
 ?memOpts::MemOptions) =>
sym
-> MemImpl sym
-> LLVMPtr sym wptr
-> StorageType
-> Alignment
-> IO (PartLLVMVal sym)
loadRaw sym
sym MemImpl sym
mem LLVMPtr sym wptr
ptr StorageType
valType Alignment
alignment = do
  let gsym :: Maybe String
gsym = Symbol -> String
unsymbol (Symbol -> String) -> Maybe Symbol -> Maybe String
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Natural Symbol -> LLVMPtr sym wptr -> Maybe Symbol
forall sym (w :: Natural).
IsSymInterface sym =>
Map Natural Symbol -> LLVMPtr sym w -> Maybe Symbol
isGlobalPointer (MemImpl sym -> Map Natural Symbol
forall sym. MemImpl sym -> Map Natural Symbol
memImplSymbolMap MemImpl sym
mem) LLVMPtr sym wptr
ptr
  sym
-> NatRepr wptr
-> Maybe String
-> LLVMPtr sym wptr
-> StorageType
-> Alignment
-> Mem sym
-> IO (PartLLVMVal sym)
forall sym (w :: Natural).
(1 <= w, IsSymInterface sym, HasLLVMAnn sym,
 ?memOpts::MemOptions) =>
sym
-> NatRepr w
-> Maybe String
-> LLVMPtr sym w
-> StorageType
-> Alignment
-> Mem sym
-> IO (PartLLVMVal sym)
G.readMem sym
sym NatRepr wptr
forall (w :: Natural) (w' :: Natural).
(HasPtrWidth w, w ~ w') =>
NatRepr w'
PtrWidth Maybe String
gsym LLVMPtr sym wptr
ptr StorageType
valType Alignment
alignment (MemImpl sym -> Mem sym
forall sym. MemImpl sym -> Mem sym
memImplHeap MemImpl sym
mem)

-- | Load an array with concrete size from memory.
loadArrayConcreteSizeRaw ::
  forall sym wptr .
  (IsSymInterface sym, HasPtrWidth wptr, Partial.HasLLVMAnn sym, ?memOpts :: MemOptions) =>
  sym ->
  MemImpl sym ->
  LLVMPtr sym wptr ->
  Natural ->
  Alignment ->
  IO (Either (Pred sym) (Pred sym, SymArray sym (SingleCtx (BaseBVType wptr)) (BaseBVType 8)))
loadArrayConcreteSizeRaw :: forall sym (wptr :: Natural).
(IsSymInterface sym, HasPtrWidth wptr, HasLLVMAnn sym,
 ?memOpts::MemOptions) =>
sym
-> MemImpl sym
-> LLVMPtr sym wptr
-> Natural
-> Alignment
-> IO
     (Either
        (Pred sym)
        (Pred sym,
         SymArray sym (SingleCtx (BaseBVType wptr)) (BaseBVType 8)))
loadArrayConcreteSizeRaw sym
sym MemImpl sym
mem LLVMPtr sym wptr
ptr Natural
sz Alignment
alignment
  | Natural
sz Natural -> Natural -> Bool
forall a. Eq a => a -> a -> Bool
== Natural
0 = do
    SymExpr sym (BaseBVType 8)
zero_bv <- sym -> NatRepr 8 -> IO (SymExpr sym (BaseBVType 8))
forall (w :: Natural) sym.
(1 <= w, IsExprBuilder sym) =>
sym -> NatRepr w -> IO (SymBV sym w)
bvZero sym
sym NatRepr 8
forall (n :: Natural). KnownNat n => NatRepr n
knownNat
    SymArray sym (SingleCtx (BaseBVType wptr)) (BaseBVType 8)
zero_arr <- sym
-> Assignment BaseTypeRepr (SingleCtx (BaseBVType wptr))
-> SymExpr sym (BaseBVType 8)
-> IO (SymArray sym (SingleCtx (BaseBVType wptr)) (BaseBVType 8))
forall sym (idx :: Ctx BaseType) (tp :: BaseType) (b :: BaseType).
IsExprBuilder sym =>
sym
-> Assignment BaseTypeRepr (idx ::> tp)
-> SymExpr sym b
-> IO (SymArray sym (idx ::> tp) b)
forall (idx :: Ctx BaseType) (tp :: BaseType) (b :: BaseType).
sym
-> Assignment BaseTypeRepr (idx ::> tp)
-> SymExpr sym b
-> IO (SymArray sym (idx ::> tp) b)
constantArray sym
sym (BaseTypeRepr (BaseBVType wptr)
-> Assignment BaseTypeRepr (SingleCtx (BaseBVType wptr))
forall {k} (f :: k -> Type) (tp :: k).
f tp -> Assignment f (EmptyCtx ::> tp)
Ctx.singleton (BaseTypeRepr (BaseBVType wptr)
 -> Assignment BaseTypeRepr (SingleCtx (BaseBVType wptr)))
-> BaseTypeRepr (BaseBVType wptr)
-> Assignment BaseTypeRepr (SingleCtx (BaseBVType wptr))
forall a b. (a -> b) -> a -> b
$ NatRepr wptr -> BaseTypeRepr (BaseBVType wptr)
forall (w :: Natural).
(1 <= w) =>
NatRepr w -> BaseTypeRepr ('BaseBVType w)
BaseBVRepr NatRepr wptr
forall (w :: Natural) (w' :: Natural).
(HasPtrWidth w, w ~ w') =>
NatRepr w'
PtrWidth) SymExpr sym (BaseBVType 8)
zero_bv
    Either
  (Pred sym)
  (Pred sym,
   SymArray sym (SingleCtx (BaseBVType wptr)) (BaseBVType 8))
-> IO
     (Either
        (Pred sym)
        (Pred sym,
         SymArray sym (SingleCtx (BaseBVType wptr)) (BaseBVType 8)))
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Either
   (Pred sym)
   (Pred sym,
    SymArray sym (SingleCtx (BaseBVType wptr)) (BaseBVType 8))
 -> IO
      (Either
         (Pred sym)
         (Pred sym,
          SymArray sym (SingleCtx (BaseBVType wptr)) (BaseBVType 8))))
-> Either
     (Pred sym)
     (Pred sym,
      SymArray sym (SingleCtx (BaseBVType wptr)) (BaseBVType 8))
-> IO
     (Either
        (Pred sym)
        (Pred sym,
         SymArray sym (SingleCtx (BaseBVType wptr)) (BaseBVType 8)))
forall a b. (a -> b) -> a -> b
$ (Pred sym,
 SymArray sym (SingleCtx (BaseBVType wptr)) (BaseBVType 8))
-> Either
     (Pred sym)
     (Pred sym,
      SymArray sym (SingleCtx (BaseBVType wptr)) (BaseBVType 8))
forall a b. b -> Either a b
Right (sym -> Pred sym
forall sym. IsExprBuilder sym => sym -> Pred sym
truePred sym
sym, SymArray sym (SingleCtx (BaseBVType wptr)) (BaseBVType 8)
zero_arr)
  | Bool
otherwise = do
    let gsym :: Maybe String
gsym = Symbol -> String
unsymbol (Symbol -> String) -> Maybe Symbol -> Maybe String
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Natural Symbol -> LLVMPtr sym wptr -> Maybe Symbol
forall sym (w :: Natural).
IsSymInterface sym =>
Map Natural Symbol -> LLVMPtr sym w -> Maybe Symbol
isGlobalPointer (MemImpl sym -> Map Natural Symbol
forall sym. MemImpl sym -> Map Natural Symbol
memImplSymbolMap MemImpl sym
mem) LLVMPtr sym wptr
ptr
    PartLLVMVal sym
res <- sym
-> NatRepr wptr
-> Maybe String
-> LLVMPtr sym wptr
-> StorageType
-> Alignment
-> Mem sym
-> IO (PartLLVMVal sym)
forall sym (w :: Natural).
(1 <= w, IsSymInterface sym, HasLLVMAnn sym,
 ?memOpts::MemOptions) =>
sym
-> NatRepr w
-> Maybe String
-> LLVMPtr sym w
-> StorageType
-> Alignment
-> Mem sym
-> IO (PartLLVMVal sym)
G.readMem sym
sym NatRepr wptr
forall (w :: Natural) (w' :: Natural).
(HasPtrWidth w, w ~ w') =>
NatRepr w'
PtrWidth Maybe String
gsym LLVMPtr sym wptr
ptr (Natural -> StorageType -> StorageType
arrayType Natural
sz (StorageType -> StorageType) -> StorageType -> StorageType
forall a b. (a -> b) -> a -> b
$ Bytes -> StorageType
bitvectorType Bytes
1) Alignment
alignment (MemImpl sym -> Mem sym
forall sym. MemImpl sym -> Mem sym
memImplHeap MemImpl sym
mem)
    case PartLLVMVal sym
res of
      Partial.NoErr Pred sym
ok LLVMVal sym
llvm_val_arr -> do
        case LLVMVal sym
llvm_val_arr of
          LLVMValArray StorageType
_ Vector (LLVMVal sym)
llvm_vals -> do
            let aum :: ArrayUpdateMap
  (SymExpr sym) (SingleCtx (BaseBVType wptr)) (BaseBVType 8)
aum = BaseTypeRepr (BaseBVType 8)
-> [(Assignment IndexLit (SingleCtx (BaseBVType wptr)),
     SymExpr sym (BaseBVType 8))]
-> ArrayUpdateMap
     (SymExpr sym) (SingleCtx (BaseBVType wptr)) (BaseBVType 8)
forall (e :: BaseType -> Type) (tp :: BaseType)
       (ctx :: Ctx BaseType).
(HasAbsValue e, HashableF e) =>
BaseTypeRepr tp
-> [(Assignment IndexLit ctx, e tp)] -> ArrayUpdateMap e ctx tp
AUM.fromAscList BaseTypeRepr (BaseBVType 8)
forall k (f :: k -> Type) (ctx :: k). KnownRepr f ctx => f ctx
knownRepr ([(Assignment IndexLit (SingleCtx (BaseBVType wptr)),
   SymExpr sym (BaseBVType 8))]
 -> ArrayUpdateMap
      (SymExpr sym) (SingleCtx (BaseBVType wptr)) (BaseBVType 8))
-> [(Assignment IndexLit (SingleCtx (BaseBVType wptr)),
     SymExpr sym (BaseBVType 8))]
-> ArrayUpdateMap
     (SymExpr sym) (SingleCtx (BaseBVType wptr)) (BaseBVType 8)
forall a b. (a -> b) -> a -> b
$ Vector
  (Assignment IndexLit (SingleCtx (BaseBVType wptr)),
   SymExpr sym (BaseBVType 8))
-> [(Assignment IndexLit (SingleCtx (BaseBVType wptr)),
     SymExpr sym (BaseBVType 8))]
forall a. Vector a -> [a]
V.toList (Vector
   (Assignment IndexLit (SingleCtx (BaseBVType wptr)),
    SymExpr sym (BaseBVType 8))
 -> [(Assignment IndexLit (SingleCtx (BaseBVType wptr)),
      SymExpr sym (BaseBVType 8))])
-> Vector
     (Assignment IndexLit (SingleCtx (BaseBVType wptr)),
      SymExpr sym (BaseBVType 8))
-> [(Assignment IndexLit (SingleCtx (BaseBVType wptr)),
     SymExpr sym (BaseBVType 8))]
forall a b. (a -> b) -> a -> b
$ (Int
 -> LLVMVal sym
 -> (Assignment IndexLit (SingleCtx (BaseBVType wptr)),
     SymExpr sym (BaseBVType 8)))
-> Vector (LLVMVal sym)
-> Vector
     (Assignment IndexLit (SingleCtx (BaseBVType wptr)),
      SymExpr sym (BaseBVType 8))
forall a b. (Int -> a -> b) -> Vector a -> Vector b
V.imap
                  (\Int
i -> \case
                    LLVMValInt SymNat sym
_ SymBV sym w
byte | Just 8 :~: w
Refl <- NatRepr 8 -> NatRepr w -> Maybe (8 :~: w)
forall (a :: Natural) (b :: Natural).
NatRepr a -> NatRepr b -> Maybe (a :~: b)
forall {k} (f :: k -> Type) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
testEquality (forall (n :: Natural). KnownNat n => NatRepr n
knownNat @8) (SymBV sym w -> NatRepr w
forall (w :: Natural). SymExpr sym (BaseBVType w) -> NatRepr w
forall (e :: BaseType -> Type) (w :: Natural).
IsExpr e =>
e (BaseBVType w) -> NatRepr w
bvWidth SymBV sym w
byte) ->
                      (IndexLit (BaseBVType wptr)
-> Assignment IndexLit (SingleCtx (BaseBVType wptr))
forall {k} (f :: k -> Type) (tp :: k).
f tp -> Assignment f (EmptyCtx ::> tp)
Ctx.singleton (IndexLit (BaseBVType wptr)
 -> Assignment IndexLit (SingleCtx (BaseBVType wptr)))
-> IndexLit (BaseBVType wptr)
-> Assignment IndexLit (SingleCtx (BaseBVType wptr))
forall a b. (a -> b) -> a -> b
$ NatRepr wptr -> BV wptr -> IndexLit (BaseBVType wptr)
forall (w :: Natural).
(1 <= w) =>
NatRepr w -> BV w -> IndexLit ('BaseBVType w)
BVIndexLit NatRepr wptr
forall (w :: Natural) (w' :: Natural).
(HasPtrWidth w, w ~ w') =>
NatRepr w'
PtrWidth (BV wptr -> IndexLit (BaseBVType wptr))
-> BV wptr -> IndexLit (BaseBVType wptr)
forall a b. (a -> b) -> a -> b
$ NatRepr wptr -> Integer -> BV wptr
forall (w :: Natural). NatRepr w -> Integer -> BV w
BV.mkBV NatRepr wptr
forall (w :: Natural) (w' :: Natural).
(HasPtrWidth w, w ~ w') =>
NatRepr w'
PtrWidth (Integer -> BV wptr) -> Integer -> BV wptr
forall a b. (a -> b) -> a -> b
$ Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i, SymBV sym w
SymExpr sym (BaseBVType 8)
byte)
                    LLVMVal sym
_ -> String
-> [String]
-> (Assignment IndexLit (SingleCtx (BaseBVType wptr)),
    SymExpr sym (BaseBVType 8))
forall a. HasCallStack => String -> [String] -> a
panic String
"MemModel.loadArrayRaw" [String
"expected LLVMValInt"])
                  Vector (LLVMVal sym)
llvm_vals
            SymExpr sym (BaseBVType 8)
zero_bv <- sym -> NatRepr 8 -> IO (SymExpr sym (BaseBVType 8))
forall (w :: Natural) sym.
(1 <= w, IsExprBuilder sym) =>
sym -> NatRepr w -> IO (SymBV sym w)
bvZero sym
sym NatRepr 8
forall (n :: Natural). KnownNat n => NatRepr n
knownNat
            SymArray sym (SingleCtx (BaseBVType wptr)) (BaseBVType 8)
arr <- sym
-> Assignment BaseTypeRepr (SingleCtx (BaseBVType wptr))
-> ArrayUpdateMap
     (SymExpr sym) (SingleCtx (BaseBVType wptr)) (BaseBVType 8)
-> SymExpr sym (BaseBVType 8)
-> IO (SymArray sym (SingleCtx (BaseBVType wptr)) (BaseBVType 8))
forall sym (idx :: Ctx BaseType) (itp :: BaseType)
       (tp :: BaseType).
IsExprBuilder sym =>
sym
-> Assignment BaseTypeRepr (idx ::> itp)
-> ArrayUpdateMap (SymExpr sym) (idx ::> itp) tp
-> SymExpr sym tp
-> IO (SymArray sym (idx ::> itp) tp)
forall (idx :: Ctx BaseType) (itp :: BaseType) (tp :: BaseType).
sym
-> Assignment BaseTypeRepr (idx ::> itp)
-> ArrayUpdateMap (SymExpr sym) (idx ::> itp) tp
-> SymExpr sym tp
-> IO (SymArray sym (idx ::> itp) tp)
arrayFromMap sym
sym (BaseTypeRepr (BaseBVType wptr)
-> Assignment BaseTypeRepr (SingleCtx (BaseBVType wptr))
forall {k} (f :: k -> Type) (tp :: k).
f tp -> Assignment f (EmptyCtx ::> tp)
Ctx.singleton (BaseTypeRepr (BaseBVType wptr)
 -> Assignment BaseTypeRepr (SingleCtx (BaseBVType wptr)))
-> BaseTypeRepr (BaseBVType wptr)
-> Assignment BaseTypeRepr (SingleCtx (BaseBVType wptr))
forall a b. (a -> b) -> a -> b
$ NatRepr wptr -> BaseTypeRepr (BaseBVType wptr)
forall (w :: Natural).
(1 <= w) =>
NatRepr w -> BaseTypeRepr ('BaseBVType w)
BaseBVRepr NatRepr wptr
forall (w :: Natural) (w' :: Natural).
(HasPtrWidth w, w ~ w') =>
NatRepr w'
PtrWidth) ArrayUpdateMap
  (SymExpr sym) (SingleCtx (BaseBVType wptr)) (BaseBVType 8)
aum SymExpr sym (BaseBVType 8)
zero_bv
            Either
  (Pred sym)
  (Pred sym,
   SymArray sym (SingleCtx (BaseBVType wptr)) (BaseBVType 8))
-> IO
     (Either
        (Pred sym)
        (Pred sym,
         SymArray sym (SingleCtx (BaseBVType wptr)) (BaseBVType 8)))
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Either
   (Pred sym)
   (Pred sym,
    SymArray sym (SingleCtx (BaseBVType wptr)) (BaseBVType 8))
 -> IO
      (Either
         (Pred sym)
         (Pred sym,
          SymArray sym (SingleCtx (BaseBVType wptr)) (BaseBVType 8))))
-> Either
     (Pred sym)
     (Pred sym,
      SymArray sym (SingleCtx (BaseBVType wptr)) (BaseBVType 8))
-> IO
     (Either
        (Pred sym)
        (Pred sym,
         SymArray sym (SingleCtx (BaseBVType wptr)) (BaseBVType 8)))
forall a b. (a -> b) -> a -> b
$ (Pred sym,
 SymArray sym (SingleCtx (BaseBVType wptr)) (BaseBVType 8))
-> Either
     (Pred sym)
     (Pred sym,
      SymArray sym (SingleCtx (BaseBVType wptr)) (BaseBVType 8))
forall a b. b -> Either a b
Right (Pred sym
ok, SymArray sym (SingleCtx (BaseBVType wptr)) (BaseBVType 8)
arr)
          LLVMVal sym
_ -> String
-> [String]
-> IO
     (Either
        (Pred sym)
        (Pred sym,
         SymArray sym (SingleCtx (BaseBVType wptr)) (BaseBVType 8)))
forall a. HasCallStack => String -> [String] -> a
panic String
"MemModel.loadArrayRaw" [String
"expected LLVMValArray"]
      Partial.Err Pred sym
err -> Either
  (Pred sym)
  (Pred sym,
   SymArray sym (SingleCtx (BaseBVType wptr)) (BaseBVType 8))
-> IO
     (Either
        (Pred sym)
        (Pred sym,
         SymArray sym (SingleCtx (BaseBVType wptr)) (BaseBVType 8)))
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Either
   (Pred sym)
   (Pred sym,
    SymArray sym (SingleCtx (BaseBVType wptr)) (BaseBVType 8))
 -> IO
      (Either
         (Pred sym)
         (Pred sym,
          SymArray sym (SingleCtx (BaseBVType wptr)) (BaseBVType 8))))
-> Either
     (Pred sym)
     (Pred sym,
      SymArray sym (SingleCtx (BaseBVType wptr)) (BaseBVType 8))
-> IO
     (Either
        (Pred sym)
        (Pred sym,
         SymArray sym (SingleCtx (BaseBVType wptr)) (BaseBVType 8)))
forall a b. (a -> b) -> a -> b
$ Pred sym
-> Either
     (Pred sym)
     (Pred sym,
      SymArray sym (SingleCtx (BaseBVType wptr)) (BaseBVType 8))
forall a b. a -> Either a b
Left Pred sym
err

-- | Store an LLVM value in memory. Asserts that the pointer is valid and points
-- to a mutable memory region.
storeRaw ::
     ( IsSymBackend sym bak
     , HasPtrWidth wptr
     , Partial.HasLLVMAnn sym
     , ?memOpts :: MemOptions )
  => bak
  -> MemImpl sym
  -> LLVMPtr sym wptr {- ^ pointer to store into -}
  -> StorageType      {- ^ type of value to store -}
  -> Alignment
  -> LLVMVal sym      {- ^ value to store -}
  -> IO (MemImpl sym)
storeRaw :: forall sym bak (wptr :: Natural).
(IsSymBackend sym bak, HasPtrWidth wptr, HasLLVMAnn sym,
 ?memOpts::MemOptions) =>
bak
-> MemImpl sym
-> LLVMPtr sym wptr
-> StorageType
-> Alignment
-> LLVMVal sym
-> IO (MemImpl sym)
storeRaw bak
bak MemImpl sym
mem LLVMPtr sym wptr
ptr StorageType
valType Alignment
alignment LLVMVal sym
val = do
    let sym :: sym
sym = bak -> sym
forall sym bak. HasSymInterface sym bak => bak -> sym
backendGetSym bak
bak
    let gsym :: Maybe String
gsym = Symbol -> String
unsymbol (Symbol -> String) -> Maybe Symbol -> Maybe String
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Natural Symbol -> LLVMPtr sym wptr -> Maybe Symbol
forall sym (w :: Natural).
IsSymInterface sym =>
Map Natural Symbol -> LLVMPtr sym w -> Maybe Symbol
isGlobalPointer (MemImpl sym -> Map Natural Symbol
forall sym. MemImpl sym -> Map Natural Symbol
memImplSymbolMap MemImpl sym
mem) LLVMPtr sym wptr
ptr
    (Mem sym
heap', SymExpr sym BaseBoolType
p1, SymExpr sym BaseBoolType
p2) <- sym
-> NatRepr wptr
-> Maybe String
-> LLVMPtr sym wptr
-> StorageType
-> Alignment
-> LLVMVal sym
-> Mem sym
-> IO (Mem sym, SymExpr sym BaseBoolType, SymExpr sym BaseBoolType)
forall (w :: Natural) sym.
(1 <= w, IsSymInterface sym, HasLLVMAnn sym,
 ?memOpts::MemOptions) =>
sym
-> NatRepr w
-> Maybe String
-> LLVMPtr sym w
-> StorageType
-> Alignment
-> LLVMVal sym
-> Mem sym
-> IO (Mem sym, Pred sym, Pred sym)
G.writeMem sym
sym NatRepr wptr
forall (w :: Natural) (w' :: Natural).
(HasPtrWidth w, w ~ w') =>
NatRepr w'
PtrWidth Maybe String
gsym LLVMPtr sym wptr
ptr StorageType
valType Alignment
alignment LLVMVal sym
val (MemImpl sym -> Mem sym
forall sym. MemImpl sym -> Mem sym
memImplHeap MemImpl sym
mem)

    let mop :: MemoryOp sym wptr
mop = StorageType
-> Maybe String -> LLVMPtr sym wptr -> Mem sym -> MemoryOp sym wptr
forall sym (w :: Natural).
StorageType
-> Maybe String -> LLVMPtr sym w -> Mem sym -> MemoryOp sym w
MemStoreOp StorageType
valType Maybe String
gsym LLVMPtr sym wptr
ptr (MemImpl sym -> Mem sym
forall sym. MemImpl sym -> Mem sym
memImplHeap MemImpl sym
mem)

    bak
-> MemoryOp sym wptr
-> MemoryErrorReason
-> SymExpr sym BaseBoolType
-> IO ()
forall sym bak (wptr :: Natural).
(IsSymBackend sym bak, HasLLVMAnn sym, 1 <= wptr) =>
bak
-> MemErrContext sym wptr -> MemoryErrorReason -> Pred sym -> IO ()
assertStoreError bak
bak MemoryOp sym wptr
mop MemoryErrorReason
UnwritableRegion SymExpr sym BaseBoolType
p1
    let callStack :: CallStack
callStack = MemState sym -> CallStack
forall sym. MemState sym -> CallStack
getCallStack (MemImpl sym
mem MemImpl sym
-> Getting (MemState sym) (MemImpl sym) (MemState sym)
-> MemState sym
forall s a. s -> Getting a s a -> a
^. (MemImpl sym -> Mem sym)
-> (Mem sym -> Const (MemState sym) (Mem sym))
-> MemImpl sym
-> Const (MemState sym) (MemImpl sym)
forall (p :: Type -> Type -> Type) (f :: Type -> Type) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to MemImpl sym -> Mem sym
forall sym. MemImpl sym -> Mem sym
memImplHeap ((Mem sym -> Const (MemState sym) (Mem sym))
 -> MemImpl sym -> Const (MemState sym) (MemImpl sym))
-> ((MemState sym -> Const (MemState sym) (MemState sym))
    -> Mem sym -> Const (MemState sym) (Mem sym))
-> Getting (MemState sym) (MemImpl sym) (MemState sym)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MemState sym -> Const (MemState sym) (MemState sym))
-> Mem sym -> Const (MemState sym) (Mem sym)
forall sym (f :: Type -> Type).
Functor f =>
(MemState sym -> f (MemState sym)) -> Mem sym -> f (Mem sym)
ML.memState)
    bak
-> CallStack
-> SymExpr sym BaseBoolType
-> UndefinedBehavior (RegValue' sym)
-> IO ()
forall sym bak.
(IsSymBackend sym bak, HasLLVMAnn sym) =>
bak
-> CallStack
-> Pred sym
-> UndefinedBehavior (RegValue' sym)
-> IO ()
assertUndefined bak
bak CallStack
callStack SymExpr sym BaseBoolType
p2 (RegValue' sym (LLVMPointerType wptr)
-> Alignment -> UndefinedBehavior (RegValue' sym)
forall (w :: Natural) (e :: CrucibleType -> Type).
(1 <= w) =>
e (LLVMPointerType w) -> Alignment -> UndefinedBehavior e
UB.WriteBadAlignment (LLVMPtr sym wptr -> RegValue' sym (LLVMPointerType wptr)
forall sym (tp :: CrucibleType).
RegValue sym tp -> RegValue' sym tp
RV LLVMPtr sym wptr
ptr) Alignment
alignment)

    MemImpl sym -> IO (MemImpl sym)
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return MemImpl sym
mem{ memImplHeap = heap' }

-- | Perform a memory write operation if the condition is true,
-- do not change the memory otherwise.
--
-- Asserts that the write operation is valid when cond is true.
doConditionalWriteOperation
  :: (IsSymBackend sym bak)
  => bak
  -> MemImpl sym
  -> Pred sym {- ^ write condition -}
  -> (MemImpl sym -> IO (MemImpl sym)) {- ^ memory write operation -}
  -> IO (MemImpl sym)
doConditionalWriteOperation :: forall sym bak.
IsSymBackend sym bak =>
bak
-> MemImpl sym
-> Pred sym
-> (MemImpl sym -> IO (MemImpl sym))
-> IO (MemImpl sym)
doConditionalWriteOperation bak
bak MemImpl sym
mem Pred sym
cond MemImpl sym -> IO (MemImpl sym)
write_op =
  bak
-> MemImpl sym
-> Pred sym
-> (MemImpl sym -> IO (MemImpl sym))
-> (MemImpl sym -> IO (MemImpl sym))
-> IO (MemImpl sym)
forall sym bak.
IsSymBackend sym bak =>
bak
-> MemImpl sym
-> Pred sym
-> (MemImpl sym -> IO (MemImpl sym))
-> (MemImpl sym -> IO (MemImpl sym))
-> IO (MemImpl sym)
mergeWriteOperations bak
bak MemImpl sym
mem Pred sym
cond MemImpl sym -> IO (MemImpl sym)
write_op MemImpl sym -> IO (MemImpl sym)
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return

-- | Merge memory write operations on condition: if the condition is true,
-- perform the true branch write operation, otherwise perform the false branch
-- write operation.
--
-- Asserts that the true branch write operation is valid when cond is true, and
-- that the false branch write operation is valid when cond is not true.
mergeWriteOperations
  :: (IsSymBackend sym bak)
  => bak
  -> MemImpl sym
  -> Pred sym {- ^ merge condition -}
  -> (MemImpl sym -> IO (MemImpl sym)) {- ^ true branch memory write operation -}
  -> (MemImpl sym -> IO (MemImpl sym)) {- ^ false branch memory write operation -}
  -> IO (MemImpl sym)
mergeWriteOperations :: forall sym bak.
IsSymBackend sym bak =>
bak
-> MemImpl sym
-> Pred sym
-> (MemImpl sym -> IO (MemImpl sym))
-> (MemImpl sym -> IO (MemImpl sym))
-> IO (MemImpl sym)
mergeWriteOperations bak
bak MemImpl sym
mem Pred sym
cond MemImpl sym -> IO (MemImpl sym)
true_write_op MemImpl sym -> IO (MemImpl sym)
false_write_op = do
  let sym :: sym
sym = bak -> sym
forall sym bak. HasSymInterface sym bak => bak -> sym
backendGetSym bak
bak
  let branched_mem :: MemImpl sym
branched_mem = MemImpl sym
mem { memImplHeap = G.branchMem $ memImplHeap mem }
  ProgramLoc
loc <- sym -> IO ProgramLoc
forall sym. IsExprBuilder sym => sym -> IO ProgramLoc
getCurrentProgramLoc sym
sym

  FrameIdentifier
true_frame_id <- bak -> IO FrameIdentifier
forall sym bak. IsSymBackend sym bak => bak -> IO FrameIdentifier
pushAssumptionFrame bak
bak
  bak -> Assumption sym -> IO ()
forall sym bak.
IsSymBackend sym bak =>
bak -> Assumption sym -> IO ()
addAssumption bak
bak (ProgramLoc -> String -> Pred sym -> Assumption sym
forall (e :: BaseType -> Type).
ProgramLoc -> String -> e BaseBoolType -> CrucibleAssumption e
GenericAssumption ProgramLoc
loc String
"conditional memory write predicate" Pred sym
cond)
  Mem sym
true_mutated_heap <- MemImpl sym -> Mem sym
forall sym. MemImpl sym -> Mem sym
memImplHeap (MemImpl sym -> Mem sym) -> IO (MemImpl sym) -> IO (Mem sym)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> MemImpl sym -> IO (MemImpl sym)
true_write_op MemImpl sym
branched_mem
  CrucibleAssumptions (SymExpr sym)
_ <- bak -> FrameIdentifier -> IO (CrucibleAssumptions (SymExpr sym))
forall sym bak.
IsSymBackend sym bak =>
bak -> FrameIdentifier -> IO (Assumptions sym)
popAssumptionFrame bak
bak FrameIdentifier
true_frame_id

  FrameIdentifier
false_frame_id <- bak -> IO FrameIdentifier
forall sym bak. IsSymBackend sym bak => bak -> IO FrameIdentifier
pushAssumptionFrame bak
bak
  Pred sym
not_cond <- sym -> Pred sym -> IO (Pred sym)
forall sym. IsExprBuilder sym => sym -> Pred sym -> IO (Pred sym)
notPred sym
sym Pred sym
cond
  bak -> Assumption sym -> IO ()
forall sym bak.
IsSymBackend sym bak =>
bak -> Assumption sym -> IO ()
addAssumption bak
bak (ProgramLoc -> String -> Pred sym -> Assumption sym
forall (e :: BaseType -> Type).
ProgramLoc -> String -> e BaseBoolType -> CrucibleAssumption e
GenericAssumption ProgramLoc
loc String
"conditional memory write predicate" Pred sym
not_cond)
  Mem sym
false_mutated_heap <- MemImpl sym -> Mem sym
forall sym. MemImpl sym -> Mem sym
memImplHeap (MemImpl sym -> Mem sym) -> IO (MemImpl sym) -> IO (Mem sym)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> MemImpl sym -> IO (MemImpl sym)
false_write_op MemImpl sym
branched_mem
  CrucibleAssumptions (SymExpr sym)
_ <- bak -> FrameIdentifier -> IO (CrucibleAssumptions (SymExpr sym))
forall sym bak.
IsSymBackend sym bak =>
bak -> FrameIdentifier -> IO (Assumptions sym)
popAssumptionFrame bak
bak FrameIdentifier
false_frame_id

  MemImpl sym -> IO (MemImpl sym)
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (MemImpl sym -> IO (MemImpl sym))
-> MemImpl sym -> IO (MemImpl sym)
forall a b. (a -> b) -> a -> b
$!
    MemImpl sym
mem { memImplHeap = G.mergeMem cond true_mutated_heap false_mutated_heap }

-- | Store an LLVM value in memory if the condition is true, and
-- otherwise leaves memory unchanged.
--
-- Asserts that the pointer is valid and points to a mutable memory
-- region when cond is true.
condStoreRaw ::
     ( IsSymBackend sym bak
     , HasPtrWidth wptr
     , Partial.HasLLVMAnn sym
     , ?memOpts :: MemOptions
     )
  => bak
  -> MemImpl sym
  -> Pred sym {- ^ Predicate that determines if we actually write. -}
  -> LLVMPtr sym wptr {- ^ pointer to store into -}
  -> StorageType      {- ^ type of value to store -}
  -> Alignment
  -> LLVMVal sym      {- ^ value to store -}
  -> IO (MemImpl sym)
condStoreRaw :: forall sym bak (wptr :: Natural).
(IsSymBackend sym bak, HasPtrWidth wptr, HasLLVMAnn sym,
 ?memOpts::MemOptions) =>
bak
-> MemImpl sym
-> Pred sym
-> LLVMPtr sym wptr
-> StorageType
-> Alignment
-> LLVMVal sym
-> IO (MemImpl sym)
condStoreRaw bak
bak MemImpl sym
mem Pred sym
cond LLVMPtr sym wptr
ptr StorageType
valType Alignment
alignment LLVMVal sym
val = do
  let sym :: sym
sym = bak -> sym
forall sym bak. HasSymInterface sym bak => bak -> sym
backendGetSym bak
bak
  let gsym :: Maybe String
gsym = Symbol -> String
unsymbol (Symbol -> String) -> Maybe Symbol -> Maybe String
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Natural Symbol -> LLVMPtr sym wptr -> Maybe Symbol
forall sym (w :: Natural).
IsSymInterface sym =>
Map Natural Symbol -> LLVMPtr sym w -> Maybe Symbol
isGlobalPointer (MemImpl sym -> Map Natural Symbol
forall sym. MemImpl sym -> Map Natural Symbol
memImplSymbolMap MemImpl sym
mem) LLVMPtr sym wptr
ptr
  -- Get current heap
  let preBranchHeap :: Mem sym
preBranchHeap = MemImpl sym -> Mem sym
forall sym. MemImpl sym -> Mem sym
memImplHeap MemImpl sym
mem
  -- Push a branch to the heap
  let postBranchHeap :: Mem sym
postBranchHeap = Mem sym -> Mem sym
forall sym. Mem sym -> Mem sym
G.branchMem Mem sym
preBranchHeap

  let mop :: MemoryOp sym wptr
mop = StorageType
-> Maybe String -> LLVMPtr sym wptr -> Mem sym -> MemoryOp sym wptr
forall sym (w :: Natural).
StorageType
-> Maybe String -> LLVMPtr sym w -> Mem sym -> MemoryOp sym w
MemStoreOp StorageType
valType Maybe String
gsym LLVMPtr sym wptr
ptr Mem sym
preBranchHeap

  -- Write to the heap
  (Mem sym
postWriteHeap, Pred sym
isAllocated, Pred sym
isAligned) <- sym
-> NatRepr wptr
-> Maybe String
-> LLVMPtr sym wptr
-> StorageType
-> Alignment
-> LLVMVal sym
-> Mem sym
-> IO (Mem sym, Pred sym, Pred sym)
forall (w :: Natural) sym.
(1 <= w, IsSymInterface sym, HasLLVMAnn sym,
 ?memOpts::MemOptions) =>
sym
-> NatRepr w
-> Maybe String
-> LLVMPtr sym w
-> StorageType
-> Alignment
-> LLVMVal sym
-> Mem sym
-> IO (Mem sym, Pred sym, Pred sym)
G.writeMem sym
sym NatRepr wptr
forall (w :: Natural) (w' :: Natural).
(HasPtrWidth w, w ~ w') =>
NatRepr w'
PtrWidth Maybe String
gsym LLVMPtr sym wptr
ptr StorageType
valType Alignment
alignment LLVMVal sym
val (MemImpl sym -> Mem sym
forall sym. MemImpl sym -> Mem sym
memImplHeap MemImpl sym
mem)
  -- Assert is allocated if write executes
  do Pred sym
condIsAllocated <- sym -> Pred sym -> Pred sym -> IO (Pred sym)
forall sym.
IsExprBuilder sym =>
sym -> Pred sym -> Pred sym -> IO (Pred sym)
impliesPred sym
sym Pred sym
cond Pred sym
isAllocated
     bak -> MemoryOp sym wptr -> MemoryErrorReason -> Pred sym -> IO ()
forall sym bak (wptr :: Natural).
(IsSymBackend sym bak, HasLLVMAnn sym, 1 <= wptr) =>
bak
-> MemErrContext sym wptr -> MemoryErrorReason -> Pred sym -> IO ()
assertStoreError bak
bak MemoryOp sym wptr
mop MemoryErrorReason
UnwritableRegion Pred sym
condIsAllocated
  -- Assert is aligned if write executes
  do Pred sym
condIsAligned <- sym -> Pred sym -> Pred sym -> IO (Pred sym)
forall sym.
IsExprBuilder sym =>
sym -> Pred sym -> Pred sym -> IO (Pred sym)
impliesPred sym
sym Pred sym
cond Pred sym
isAligned
     let callStack :: CallStack
callStack = MemState sym -> CallStack
forall sym. MemState sym -> CallStack
getCallStack (MemImpl sym
mem MemImpl sym
-> Getting (MemState sym) (MemImpl sym) (MemState sym)
-> MemState sym
forall s a. s -> Getting a s a -> a
^. (MemImpl sym -> Mem sym)
-> (Mem sym -> Const (MemState sym) (Mem sym))
-> MemImpl sym
-> Const (MemState sym) (MemImpl sym)
forall (p :: Type -> Type -> Type) (f :: Type -> Type) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to MemImpl sym -> Mem sym
forall sym. MemImpl sym -> Mem sym
memImplHeap ((Mem sym -> Const (MemState sym) (Mem sym))
 -> MemImpl sym -> Const (MemState sym) (MemImpl sym))
-> ((MemState sym -> Const (MemState sym) (MemState sym))
    -> Mem sym -> Const (MemState sym) (Mem sym))
-> Getting (MemState sym) (MemImpl sym) (MemState sym)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MemState sym -> Const (MemState sym) (MemState sym))
-> Mem sym -> Const (MemState sym) (Mem sym)
forall sym (f :: Type -> Type).
Functor f =>
(MemState sym -> f (MemState sym)) -> Mem sym -> f (Mem sym)
ML.memState)
     bak
-> CallStack
-> Pred sym
-> UndefinedBehavior (RegValue' sym)
-> IO ()
forall sym bak.
(IsSymBackend sym bak, HasLLVMAnn sym) =>
bak
-> CallStack
-> Pred sym
-> UndefinedBehavior (RegValue' sym)
-> IO ()
assertUndefined bak
bak CallStack
callStack Pred sym
condIsAligned (RegValue' sym (LLVMPointerType wptr)
-> Alignment -> UndefinedBehavior (RegValue' sym)
forall (w :: Natural) (e :: CrucibleType -> Type).
(1 <= w) =>
e (LLVMPointerType w) -> Alignment -> UndefinedBehavior e
UB.WriteBadAlignment (LLVMPtr sym wptr -> RegValue' sym (LLVMPointerType wptr)
forall sym (tp :: CrucibleType).
RegValue sym tp -> RegValue' sym tp
RV LLVMPtr sym wptr
ptr) Alignment
alignment)
  -- Merge the write heap and non-write heap
  let mergedHeap :: Mem sym
mergedHeap = Pred sym -> Mem sym -> Mem sym -> Mem sym
forall sym.
IsExpr (SymExpr sym) =>
Pred sym -> Mem sym -> Mem sym -> Mem sym
G.mergeMem Pred sym
cond Mem sym
postWriteHeap Mem sym
postBranchHeap
  -- Return new memory
  MemImpl sym -> IO (MemImpl sym)
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (MemImpl sym -> IO (MemImpl sym))
-> MemImpl sym -> IO (MemImpl sym)
forall a b. (a -> b) -> a -> b
$! MemImpl sym
mem{ memImplHeap = mergedHeap }

-- | Store an LLVM value in memory. The pointed-to memory region may
-- be either mutable or immutable; thus 'storeConstRaw' can be used to
-- initialize read-only memory regions.
storeConstRaw ::
     ( IsSymBackend sym bak
     , HasPtrWidth wptr
     , Partial.HasLLVMAnn sym
     , ?memOpts :: MemOptions )
  => bak
  -> MemImpl sym
  -> LLVMPtr sym wptr {- ^ pointer to store into -}
  -> StorageType      {- ^ type of value to store -}
  -> Alignment
  -> LLVMVal sym      {- ^ value to store -}
  -> IO (MemImpl sym)
storeConstRaw :: forall sym bak (wptr :: Natural).
(IsSymBackend sym bak, HasPtrWidth wptr, HasLLVMAnn sym,
 ?memOpts::MemOptions) =>
bak
-> MemImpl sym
-> LLVMPtr sym wptr
-> StorageType
-> Alignment
-> LLVMVal sym
-> IO (MemImpl sym)
storeConstRaw bak
bak MemImpl sym
mem LLVMPtr sym wptr
ptr StorageType
valType Alignment
alignment LLVMVal sym
val = do
    let sym :: sym
sym = bak -> sym
forall sym bak. HasSymInterface sym bak => bak -> sym
backendGetSym bak
bak
    let gsym :: Maybe String
gsym = Symbol -> String
unsymbol (Symbol -> String) -> Maybe Symbol -> Maybe String
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Natural Symbol -> LLVMPtr sym wptr -> Maybe Symbol
forall sym (w :: Natural).
IsSymInterface sym =>
Map Natural Symbol -> LLVMPtr sym w -> Maybe Symbol
isGlobalPointer (MemImpl sym -> Map Natural Symbol
forall sym. MemImpl sym -> Map Natural Symbol
memImplSymbolMap MemImpl sym
mem) LLVMPtr sym wptr
ptr
    (Mem sym
heap', SymExpr sym BaseBoolType
p1, SymExpr sym BaseBoolType
p2) <- sym
-> NatRepr wptr
-> Maybe String
-> LLVMPtr sym wptr
-> StorageType
-> Alignment
-> LLVMVal sym
-> Mem sym
-> IO (Mem sym, SymExpr sym BaseBoolType, SymExpr sym BaseBoolType)
forall (w :: Natural) sym.
(1 <= w, IsSymInterface sym, HasLLVMAnn sym,
 ?memOpts::MemOptions) =>
sym
-> NatRepr w
-> Maybe String
-> LLVMPtr sym w
-> StorageType
-> Alignment
-> LLVMVal sym
-> Mem sym
-> IO (Mem sym, Pred sym, Pred sym)
G.writeConstMem sym
sym NatRepr wptr
forall (w :: Natural) (w' :: Natural).
(HasPtrWidth w, w ~ w') =>
NatRepr w'
PtrWidth Maybe String
gsym LLVMPtr sym wptr
ptr StorageType
valType Alignment
alignment LLVMVal sym
val (MemImpl sym -> Mem sym
forall sym. MemImpl sym -> Mem sym
memImplHeap MemImpl sym
mem)

    let mop :: MemoryOp sym wptr
mop = StorageType
-> Maybe String -> LLVMPtr sym wptr -> Mem sym -> MemoryOp sym wptr
forall sym (w :: Natural).
StorageType
-> Maybe String -> LLVMPtr sym w -> Mem sym -> MemoryOp sym w
MemStoreOp StorageType
valType Maybe String
gsym LLVMPtr sym wptr
ptr (MemImpl sym -> Mem sym
forall sym. MemImpl sym -> Mem sym
memImplHeap MemImpl sym
mem)

    bak
-> MemoryOp sym wptr
-> MemoryErrorReason
-> SymExpr sym BaseBoolType
-> IO ()
forall sym bak (wptr :: Natural).
(IsSymBackend sym bak, HasLLVMAnn sym, 1 <= wptr) =>
bak
-> MemErrContext sym wptr -> MemoryErrorReason -> Pred sym -> IO ()
assertStoreError bak
bak MemoryOp sym wptr
mop MemoryErrorReason
UnwritableRegion SymExpr sym BaseBoolType
p1
    let callStack :: CallStack
callStack = MemState sym -> CallStack
forall sym. MemState sym -> CallStack
getCallStack (MemImpl sym
mem MemImpl sym
-> Getting (MemState sym) (MemImpl sym) (MemState sym)
-> MemState sym
forall s a. s -> Getting a s a -> a
^. (MemImpl sym -> Mem sym)
-> (Mem sym -> Const (MemState sym) (Mem sym))
-> MemImpl sym
-> Const (MemState sym) (MemImpl sym)
forall (p :: Type -> Type -> Type) (f :: Type -> Type) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to MemImpl sym -> Mem sym
forall sym. MemImpl sym -> Mem sym
memImplHeap ((Mem sym -> Const (MemState sym) (Mem sym))
 -> MemImpl sym -> Const (MemState sym) (MemImpl sym))
-> ((MemState sym -> Const (MemState sym) (MemState sym))
    -> Mem sym -> Const (MemState sym) (Mem sym))
-> Getting (MemState sym) (MemImpl sym) (MemState sym)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MemState sym -> Const (MemState sym) (MemState sym))
-> Mem sym -> Const (MemState sym) (Mem sym)
forall sym (f :: Type -> Type).
Functor f =>
(MemState sym -> f (MemState sym)) -> Mem sym -> f (Mem sym)
ML.memState)
    bak
-> CallStack
-> SymExpr sym BaseBoolType
-> UndefinedBehavior (RegValue' sym)
-> IO ()
forall sym bak.
(IsSymBackend sym bak, HasLLVMAnn sym) =>
bak
-> CallStack
-> Pred sym
-> UndefinedBehavior (RegValue' sym)
-> IO ()
assertUndefined bak
bak CallStack
callStack SymExpr sym BaseBoolType
p2 (RegValue' sym (LLVMPointerType wptr)
-> Alignment -> UndefinedBehavior (RegValue' sym)
forall (w :: Natural) (e :: CrucibleType -> Type).
(1 <= w) =>
e (LLVMPointerType w) -> Alignment -> UndefinedBehavior e
UB.WriteBadAlignment (LLVMPtr sym wptr -> RegValue' sym (LLVMPointerType wptr)
forall sym (tp :: CrucibleType).
RegValue sym tp -> RegValue' sym tp
RV LLVMPtr sym wptr
ptr) Alignment
alignment)

    MemImpl sym -> IO (MemImpl sym)
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return MemImpl sym
mem{ memImplHeap = heap' }

-- | Allocate a memory region on the heap, with no source location info.
mallocRaw
  :: ( IsSymBackend sym bak, HasPtrWidth wptr, Partial.HasLLVMAnn sym
     , ?memOpts :: MemOptions )
  => bak
  -> MemImpl sym
  -> SymBV sym wptr {- ^ size in bytes -}
  -> Alignment
  -> IO (LLVMPtr sym wptr, MemImpl sym)
mallocRaw :: forall sym bak (wptr :: Natural).
(IsSymBackend sym bak, HasPtrWidth wptr, HasLLVMAnn sym,
 ?memOpts::MemOptions) =>
bak
-> MemImpl sym
-> SymBV sym wptr
-> Alignment
-> IO (LLVMPtr sym wptr, MemImpl sym)
mallocRaw bak
bak MemImpl sym
mem SymBV sym wptr
sz Alignment
alignment =
  bak
-> AllocType
-> Mutability
-> String
-> MemImpl sym
-> SymBV sym wptr
-> Alignment
-> IO
     (RegValue
        sym (IntrinsicType "LLVM_pointer" ('EmptyCtx '::> BVType wptr)),
      MemImpl sym)
forall sym bak (wptr :: Natural).
(IsSymBackend sym bak, HasPtrWidth wptr, HasLLVMAnn sym,
 ?memOpts::MemOptions) =>
bak
-> AllocType
-> Mutability
-> String
-> MemImpl sym
-> SymBV sym wptr
-> Alignment
-> IO (LLVMPtr sym wptr, MemImpl sym)
doMalloc bak
bak AllocType
G.HeapAlloc Mutability
G.Mutable String
"<malloc>" MemImpl sym
mem SymBV sym wptr
sz Alignment
alignment

-- | Allocate a read-only memory region on the heap, with no source location info.
mallocConstRaw
  :: ( IsSymBackend sym bak, HasPtrWidth wptr, Partial.HasLLVMAnn sym
     , ?memOpts :: MemOptions )
  => bak
  -> MemImpl sym
  -> SymBV sym wptr
  -> Alignment
  -> IO (LLVMPtr sym wptr, MemImpl sym)
mallocConstRaw :: forall sym bak (wptr :: Natural).
(IsSymBackend sym bak, HasPtrWidth wptr, HasLLVMAnn sym,
 ?memOpts::MemOptions) =>
bak
-> MemImpl sym
-> SymBV sym wptr
-> Alignment
-> IO (LLVMPtr sym wptr, MemImpl sym)
mallocConstRaw bak
bak MemImpl sym
mem SymBV sym wptr
sz Alignment
alignment =
  bak
-> AllocType
-> Mutability
-> String
-> MemImpl sym
-> SymBV sym wptr
-> Alignment
-> IO
     (RegValue
        sym (IntrinsicType "LLVM_pointer" ('EmptyCtx '::> BVType wptr)),
      MemImpl sym)
forall sym bak (wptr :: Natural).
(IsSymBackend sym bak, HasPtrWidth wptr, HasLLVMAnn sym,
 ?memOpts::MemOptions) =>
bak
-> AllocType
-> Mutability
-> String
-> MemImpl sym
-> SymBV sym wptr
-> Alignment
-> IO (LLVMPtr sym wptr, MemImpl sym)
doMalloc bak
bak AllocType
G.HeapAlloc Mutability
G.Immutable String
"<malloc>" MemImpl sym
mem SymBV sym wptr
sz Alignment
alignment

----------------------------------------------------------------------
-- Packing and unpacking
--

unpackZero ::
  (HasCallStack, IsSymInterface sym) =>
  sym ->
  StorageType ->
  TypeRepr tp {- ^ Crucible type     -} ->
  IO (RegValue sym tp)
unpackZero :: forall sym (tp :: CrucibleType).
(HasCallStack, IsSymInterface sym) =>
sym -> StorageType -> TypeRepr tp -> IO (RegValue sym tp)
unpackZero sym
sym StorageType
tp TypeRepr tp
tpr =
 let mismatch :: IO (RegValue sym tp)
mismatch = String -> StorageType -> TypeRepr tp -> IO (RegValue sym tp)
forall (tp :: CrucibleType) a.
String -> StorageType -> TypeRepr tp -> IO a
storageTypeMismatch String
"MemModel.unpackZero" StorageType
tp TypeRepr tp
tpr in
 case StorageType -> StorageTypeF StorageType
storageTypeF StorageType
tp of
  Bitvector Bytes
bytes ->
    sym
-> Bytes
-> (forall {w :: Natural}.
    (1 <= w) =>
    Maybe (SymNat sym, SymBV sym w) -> IO (RegValue sym tp))
-> IO (RegValue sym tp)
forall sym a.
IsSymInterface sym =>
sym
-> Bytes
-> (forall (w :: Natural).
    (1 <= w) =>
    Maybe (SymNat sym, SymBV sym w) -> IO a)
-> IO a
zeroInt sym
sym Bytes
bytes ((forall {w :: Natural}.
  (1 <= w) =>
  Maybe (SymNat sym, SymBV sym w) -> IO (RegValue sym tp))
 -> IO (RegValue sym tp))
-> (forall {w :: Natural}.
    (1 <= w) =>
    Maybe (SymNat sym, SymBV sym w) -> IO (RegValue sym tp))
-> IO (RegValue sym tp)
forall a b. (a -> b) -> a -> b
$ \case
      Maybe (SymNat sym, SymBV sym w)
Nothing -> String -> IO (RegValue sym tp)
forall a. String -> IO a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String
"Improper storable type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ StorageType -> String
forall a. Show a => a -> String
show StorageType
tp)
      Just (SymNat sym
blk, SymBV sym w
bv) ->
        case TypeRepr tp
tpr of
          LLVMPointerRepr NatRepr w
w | Just w :~: w
Refl <- NatRepr w -> NatRepr w -> Maybe (w :~: w)
forall (a :: Natural) (b :: Natural).
NatRepr a -> NatRepr b -> Maybe (a :~: b)
forall {k} (f :: k -> Type) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
testEquality (SymBV sym w -> NatRepr w
forall (w :: Natural). SymExpr sym (BaseBVType w) -> NatRepr w
forall (e :: BaseType -> Type) (w :: Natural).
IsExpr e =>
e (BaseBVType w) -> NatRepr w
bvWidth SymBV sym w
bv) NatRepr w
w -> LLVMPointer sym w -> IO (LLVMPointer sym w)
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (SymNat sym -> SymBV sym w -> LLVMPointer sym w
forall sym (w :: Natural).
SymNat sym -> SymBV sym w -> LLVMPointer sym w
LLVMPointer SymNat sym
blk SymBV sym w
bv)
          TypeRepr tp
_ -> IO (RegValue sym tp)
mismatch

  StorageTypeF StorageType
Float  ->
    case TypeRepr tp
tpr of
      FloatRepr FloatInfoRepr flt
SingleFloatRepr -> sym
-> FloatInfoRepr 'SingleFloat
-> Rational
-> IO (SymInterpretedFloat sym 'SingleFloat)
forall sym (fi :: FloatInfo).
IsInterpretedFloatExprBuilder sym =>
sym
-> FloatInfoRepr fi -> Rational -> IO (SymInterpretedFloat sym fi)
forall (fi :: FloatInfo).
sym
-> FloatInfoRepr fi -> Rational -> IO (SymInterpretedFloat sym fi)
iFloatLitRational sym
sym FloatInfoRepr 'SingleFloat
SingleFloatRepr Rational
0
      TypeRepr tp
_ -> IO (RegValue sym tp)
mismatch

  StorageTypeF StorageType
Double ->
    case TypeRepr tp
tpr of
      FloatRepr FloatInfoRepr flt
DoubleFloatRepr -> sym
-> FloatInfoRepr 'DoubleFloat
-> Rational
-> IO (SymInterpretedFloat sym 'DoubleFloat)
forall sym (fi :: FloatInfo).
IsInterpretedFloatExprBuilder sym =>
sym
-> FloatInfoRepr fi -> Rational -> IO (SymInterpretedFloat sym fi)
forall (fi :: FloatInfo).
sym
-> FloatInfoRepr fi -> Rational -> IO (SymInterpretedFloat sym fi)
iFloatLitRational sym
sym FloatInfoRepr 'DoubleFloat
DoubleFloatRepr Rational
0
      TypeRepr tp
_ -> IO (RegValue sym tp)
mismatch

  StorageTypeF StorageType
X86_FP80 ->
    case TypeRepr tp
tpr of
      FloatRepr FloatInfoRepr flt
X86_80FloatRepr -> sym
-> FloatInfoRepr 'X86_80Float
-> Rational
-> IO (SymInterpretedFloat sym 'X86_80Float)
forall sym (fi :: FloatInfo).
IsInterpretedFloatExprBuilder sym =>
sym
-> FloatInfoRepr fi -> Rational -> IO (SymInterpretedFloat sym fi)
forall (fi :: FloatInfo).
sym
-> FloatInfoRepr fi -> Rational -> IO (SymInterpretedFloat sym fi)
iFloatLitRational sym
sym FloatInfoRepr 'X86_80Float
X86_80FloatRepr Rational
0
      TypeRepr tp
_ -> IO (RegValue sym tp)
mismatch

  Array Natural
n StorageType
tp' ->
    case TypeRepr tp
tpr of
      VectorRepr TypeRepr tp1
tpr' ->
        do RegValue sym tp1
v <- sym -> StorageType -> TypeRepr tp1 -> IO (RegValue sym tp1)
forall sym (tp :: CrucibleType).
(HasCallStack, IsSymInterface sym) =>
sym -> StorageType -> TypeRepr tp -> IO (RegValue sym tp)
unpackZero sym
sym StorageType
tp' TypeRepr tp1
tpr'
           Vector (RegValue sym tp1) -> IO (Vector (RegValue sym tp1))
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Vector (RegValue sym tp1) -> IO (Vector (RegValue sym tp1)))
-> Vector (RegValue sym tp1) -> IO (Vector (RegValue sym tp1))
forall a b. (a -> b) -> a -> b
$ Int -> RegValue sym tp1 -> Vector (RegValue sym tp1)
forall a. Int -> a -> Vector a
V.replicate (Natural -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
n) RegValue sym tp1
v
      TypeRepr tp
_ -> IO (RegValue sym tp)
mismatch

  Struct Vector (Field StorageType)
flds ->
    case TypeRepr tp
tpr of
      StructRepr CtxRepr ctx
fldCtx | Vector (Field StorageType) -> Int
forall a. Vector a -> Int
V.length Vector (Field StorageType)
flds Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Size ctx -> Int
forall {k} (ctx :: Ctx k). Size ctx -> Int
Ctx.sizeInt (CtxRepr ctx -> Size ctx
forall {k} (f :: k -> Type) (ctx :: Ctx k).
Assignment f ctx -> Size ctx
Ctx.size CtxRepr ctx
fldCtx) ->
        (forall (tp :: CrucibleType).
 Index ctx tp -> TypeRepr tp -> IO (RegValue' sym tp))
-> CtxRepr ctx -> IO (Assignment (RegValue' sym) ctx)
forall {k} (m :: Type -> Type) (ctx :: Ctx k) (f :: k -> Type)
       (g :: k -> Type).
Applicative m =>
(forall (tp :: k). Index ctx tp -> f tp -> m (g tp))
-> Assignment f ctx -> m (Assignment g ctx)
Ctx.traverseWithIndex
          (\Index ctx tp
i TypeRepr tp
tpr' -> RegValue sym tp -> RegValue' sym tp
forall sym (tp :: CrucibleType).
RegValue sym tp -> RegValue' sym tp
RV (RegValue sym tp -> RegValue' sym tp)
-> IO (RegValue sym tp) -> IO (RegValue' sym tp)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> sym -> StorageType -> TypeRepr tp -> IO (RegValue sym tp)
forall sym (tp :: CrucibleType).
(HasCallStack, IsSymInterface sym) =>
sym -> StorageType -> TypeRepr tp -> IO (RegValue sym tp)
unpackZero sym
sym (Vector (Field StorageType)
flds Vector (Field StorageType) -> Int -> Field StorageType
forall a. Vector a -> Int -> a
V.! (Index ctx tp -> Int
forall k (ctx :: Ctx k) (tp :: k). Index ctx tp -> Int
Ctx.indexVal Index ctx tp
i) Field StorageType
-> Getting StorageType (Field StorageType) StorageType
-> StorageType
forall s a. s -> Getting a s a -> a
^. Getting StorageType (Field StorageType) StorageType
forall a b (f :: Type -> Type).
Functor f =>
(a -> f b) -> Field a -> f (Field b)
fieldVal) TypeRepr tp
tpr')
          CtxRepr ctx
fldCtx

      TypeRepr tp
_ -> IO (RegValue sym tp)
mismatch


storageTypeMismatch ::
  String ->
  StorageType ->
  TypeRepr tp ->
  IO a
storageTypeMismatch :: forall (tp :: CrucibleType) a.
String -> StorageType -> TypeRepr tp -> IO a
storageTypeMismatch String
nm StorageType
tp TypeRepr tp
tpr =
  String -> [String] -> IO a
forall a. HasCallStack => String -> [String] -> a
panic String
nm
  [ String
"Storage type mismatch in " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
nm
  , String
"  Storage type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ StorageType -> String
forall a. Show a => a -> String
show StorageType
tp
  , String
"  Crucible type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TypeRepr tp -> String
forall a. Show a => a -> String
show TypeRepr tp
tpr
  ]

-- | Unpack an 'LLVMVal' to produce a 'RegValue'.
unpackMemValue ::
  (HasCallStack, IsSymInterface sym) =>
  sym ->
  TypeRepr tp ->
  LLVMVal sym ->
  IO (RegValue sym tp)

unpackMemValue :: forall sym (tp :: CrucibleType).
(HasCallStack, IsSymInterface sym) =>
sym -> TypeRepr tp -> LLVMVal sym -> IO (RegValue sym tp)
unpackMemValue sym
sym TypeRepr tp
tpr (LLVMValZero StorageType
tp)  = sym -> StorageType -> TypeRepr tp -> IO (RegValue sym tp)
forall sym (tp :: CrucibleType).
(HasCallStack, IsSymInterface sym) =>
sym -> StorageType -> TypeRepr tp -> IO (RegValue sym tp)
unpackZero sym
sym StorageType
tp TypeRepr tp
tpr

unpackMemValue sym
_sym (LLVMPointerRepr NatRepr w
w) (LLVMValInt SymNat sym
blk SymBV sym w
bv)
  | Just w :~: w
Refl <- NatRepr w -> NatRepr w -> Maybe (w :~: w)
forall (a :: Natural) (b :: Natural).
NatRepr a -> NatRepr b -> Maybe (a :~: b)
forall {k} (f :: k -> Type) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
testEquality (SymBV sym w -> NatRepr w
forall (w :: Natural). SymExpr sym (BaseBVType w) -> NatRepr w
forall (e :: BaseType -> Type) (w :: Natural).
IsExpr e =>
e (BaseBVType w) -> NatRepr w
bvWidth SymBV sym w
bv) NatRepr w
w
  = RegValue sym tp -> IO (RegValue sym tp)
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (RegValue sym tp -> IO (RegValue sym tp))
-> RegValue sym tp -> IO (RegValue sym tp)
forall a b. (a -> b) -> a -> b
$ SymNat sym -> SymBV sym w -> LLVMPointer sym w
forall sym (w :: Natural).
SymNat sym -> SymBV sym w -> LLVMPointer sym w
LLVMPointer SymNat sym
blk SymBV sym w
SymBV sym w
bv

unpackMemValue sym
_ (FloatRepr FloatInfoRepr flt
SingleFloatRepr) (LLVMValFloat FloatSize fi
SingleSize SymInterpretedFloat sym fi
x) = SymExpr sym (SymInterpretedFloatType sym 'SingleFloat)
-> IO (SymExpr sym (SymInterpretedFloatType sym 'SingleFloat))
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return SymInterpretedFloat sym fi
SymExpr sym (SymInterpretedFloatType sym 'SingleFloat)
x
unpackMemValue sym
_ (FloatRepr FloatInfoRepr flt
DoubleFloatRepr) (LLVMValFloat FloatSize fi
DoubleSize SymInterpretedFloat sym fi
x) = SymExpr sym (SymInterpretedFloatType sym 'DoubleFloat)
-> IO (SymExpr sym (SymInterpretedFloatType sym 'DoubleFloat))
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return SymInterpretedFloat sym fi
SymExpr sym (SymInterpretedFloatType sym 'DoubleFloat)
x
unpackMemValue sym
_ (FloatRepr FloatInfoRepr flt
X86_80FloatRepr) (LLVMValFloat FloatSize fi
X86_FP80Size SymInterpretedFloat sym fi
x) = SymExpr sym (SymInterpretedFloatType sym 'X86_80Float)
-> IO (SymExpr sym (SymInterpretedFloatType sym 'X86_80Float))
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return SymInterpretedFloat sym fi
SymExpr sym (SymInterpretedFloatType sym 'X86_80Float)
x

unpackMemValue sym
sym (StructRepr CtxRepr ctx
ctx) (LLVMValStruct Vector (Field StorageType, LLVMVal sym)
xs)
  | Vector (Field StorageType, LLVMVal sym) -> Int
forall a. Vector a -> Int
V.length Vector (Field StorageType, LLVMVal sym)
xs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Size ctx -> Int
forall {k} (ctx :: Ctx k). Size ctx -> Int
Ctx.sizeInt (CtxRepr ctx -> Size ctx
forall {k} (f :: k -> Type) (ctx :: Ctx k).
Assignment f ctx -> Size ctx
Ctx.size CtxRepr ctx
ctx)
  = (forall (tp :: CrucibleType).
 Index ctx tp -> TypeRepr tp -> IO (RegValue' sym tp))
-> CtxRepr ctx -> IO (Assignment (RegValue' sym) ctx)
forall {k} (m :: Type -> Type) (ctx :: Ctx k) (f :: k -> Type)
       (g :: k -> Type).
Applicative m =>
(forall (tp :: k). Index ctx tp -> f tp -> m (g tp))
-> Assignment f ctx -> m (Assignment g ctx)
Ctx.traverseWithIndex
       (\Index ctx tp
i TypeRepr tp
tpr -> RegValue sym tp -> RegValue' sym tp
forall sym (tp :: CrucibleType).
RegValue sym tp -> RegValue' sym tp
RV (RegValue sym tp -> RegValue' sym tp)
-> IO (RegValue sym tp) -> IO (RegValue' sym tp)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> sym -> TypeRepr tp -> LLVMVal sym -> IO (RegValue sym tp)
forall sym (tp :: CrucibleType).
(HasCallStack, IsSymInterface sym) =>
sym -> TypeRepr tp -> LLVMVal sym -> IO (RegValue sym tp)
unpackMemValue sym
sym TypeRepr tp
tpr (Vector (Field StorageType, LLVMVal sym)
xs Vector (Field StorageType, LLVMVal sym)
-> Int -> (Field StorageType, LLVMVal sym)
forall a. Vector a -> Int -> a
V.! Index ctx tp -> Int
forall k (ctx :: Ctx k) (tp :: k). Index ctx tp -> Int
Ctx.indexVal Index ctx tp
i (Field StorageType, LLVMVal sym)
-> Getting
     (LLVMVal sym) (Field StorageType, LLVMVal sym) (LLVMVal sym)
-> LLVMVal sym
forall s a. s -> Getting a s a -> a
^. Getting
  (LLVMVal sym) (Field StorageType, LLVMVal sym) (LLVMVal sym)
forall s t a b. Field2 s t a b => Lens s t a b
Lens
  (Field StorageType, LLVMVal sym)
  (Field StorageType, LLVMVal sym)
  (LLVMVal sym)
  (LLVMVal sym)
_2))
       CtxRepr ctx
ctx

unpackMemValue sym
sym (VectorRepr TypeRepr tp1
tpr) (LLVMValArray StorageType
_tp Vector (LLVMVal sym)
xs)
  = (LLVMVal sym -> IO (RegValue sym tp1))
-> Vector (LLVMVal sym) -> IO (Vector (RegValue sym tp1))
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> Vector a -> f (Vector b)
traverse (sym -> TypeRepr tp1 -> LLVMVal sym -> IO (RegValue sym tp1)
forall sym (tp :: CrucibleType).
(HasCallStack, IsSymInterface sym) =>
sym -> TypeRepr tp -> LLVMVal sym -> IO (RegValue sym tp)
unpackMemValue sym
sym TypeRepr tp1
tpr) Vector (LLVMVal sym)
xs

-- LLVM string literals are syntactic shorthand for [<N> x i8] arrays, so we
-- defer to the LLVMValArray case above.
unpackMemValue sym
sym tpr :: TypeRepr tp
tpr@(VectorRepr TypeRepr tp1
_) (LLVMValString ByteString
str)
  = do LLVMVal sym
explodedVal <- sym -> ByteString -> IO (LLVMVal sym)
forall sym.
(IsExprBuilder sym, IsInterpretedFloatExprBuilder sym) =>
sym -> ByteString -> IO (LLVMVal sym)
explodeStringValue sym
sym ByteString
str
       sym -> TypeRepr tp -> LLVMVal sym -> IO (RegValue sym tp)
forall sym (tp :: CrucibleType).
(HasCallStack, IsSymInterface sym) =>
sym -> TypeRepr tp -> LLVMVal sym -> IO (RegValue sym tp)
unpackMemValue sym
sym TypeRepr tp
tpr LLVMVal sym
explodedVal

unpackMemValue sym
_sym ctp :: TypeRepr tp
ctp@(BVRepr NatRepr n
_) lval :: LLVMVal sym
lval@(LLVMValInt SymNat sym
_ SymBV sym w
_) =
    String -> [String] -> IO (SymExpr sym (BaseBVType n))
forall a. HasCallStack => String -> [String] -> a
panic String
"MemModel.unpackMemValue"
      [ String
"Cannot unpack an integer LLVM value to a crucible bitvector type"
      , String
"*** Crucible type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TypeRepr tp -> String
forall a. Show a => a -> String
show TypeRepr tp
ctp
      , String
"*** LLVM value: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ LLVMVal sym -> String
forall a. Show a => a -> String
show LLVMVal sym
lval
      ]

unpackMemValue sym
_ TypeRepr tp
tpr v :: LLVMVal sym
v@(LLVMValUndef StorageType
_) =
  String -> [String] -> IO (RegValue sym tp)
forall a. HasCallStack => String -> [String] -> a
panic String
"MemModel.unpackMemValue"
    [ String
"Cannot unpack an `undef` value"
    , String
"*** Crucible type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TypeRepr tp -> String
forall a. Show a => a -> String
show TypeRepr tp
tpr
    , String
"*** Undef value: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ LLVMVal sym -> String
forall a. Show a => a -> String
show LLVMVal sym
v
    ]

unpackMemValue sym
_ TypeRepr tp
tpr LLVMVal sym
v =
  String -> [String] -> IO (RegValue sym tp)
forall a. HasCallStack => String -> [String] -> a
panic String
"MemModel.unpackMemValue"
    [ String
"Crucible type mismatch when unpacking LLVM value"
    , String
"*** Crucible type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TypeRepr tp -> String
forall a. Show a => a -> String
show TypeRepr tp
tpr
    , String
"*** LLVM value: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ LLVMVal sym -> String
forall a. Show a => a -> String
show LLVMVal sym
v
    ]


-- | Pack a 'RegValue' into an 'LLVMVal'. The LLVM storage type and
-- the Crucible type must be compatible.
packMemValue ::
  IsSymInterface sym =>
  sym ->
  StorageType {- ^ LLVM storage type -} ->
  TypeRepr tp {- ^ Crucible type     -} ->
  RegValue sym tp ->
  IO (LLVMVal sym)

packMemValue :: forall sym (tp :: CrucibleType).
IsSymInterface sym =>
sym
-> StorageType
-> TypeRepr tp
-> RegValue sym tp
-> IO (LLVMVal sym)
packMemValue sym
_ (StorageType StorageTypeF StorageType
Float Bytes
_) (FloatRepr FloatInfoRepr flt
SingleFloatRepr) RegValue sym tp
x =
       LLVMVal sym -> IO (LLVMVal sym)
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (LLVMVal sym -> IO (LLVMVal sym))
-> LLVMVal sym -> IO (LLVMVal sym)
forall a b. (a -> b) -> a -> b
$ FloatSize 'SingleFloat
-> SymInterpretedFloat sym 'SingleFloat -> LLVMVal sym
forall (fi :: FloatInfo) sym.
FloatSize fi -> SymInterpretedFloat sym fi -> LLVMVal sym
LLVMValFloat FloatSize 'SingleFloat
SingleSize RegValue sym tp
SymInterpretedFloat sym 'SingleFloat
x

packMemValue sym
_ (StorageType StorageTypeF StorageType
Double Bytes
_) (FloatRepr FloatInfoRepr flt
DoubleFloatRepr) RegValue sym tp
x =
       LLVMVal sym -> IO (LLVMVal sym)
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (LLVMVal sym -> IO (LLVMVal sym))
-> LLVMVal sym -> IO (LLVMVal sym)
forall a b. (a -> b) -> a -> b
$ FloatSize 'DoubleFloat
-> SymInterpretedFloat sym 'DoubleFloat -> LLVMVal sym
forall (fi :: FloatInfo) sym.
FloatSize fi -> SymInterpretedFloat sym fi -> LLVMVal sym
LLVMValFloat FloatSize 'DoubleFloat
DoubleSize RegValue sym tp
SymInterpretedFloat sym 'DoubleFloat
x

packMemValue sym
_ (StorageType StorageTypeF StorageType
X86_FP80 Bytes
_) (FloatRepr FloatInfoRepr flt
X86_80FloatRepr) RegValue sym tp
x =
       LLVMVal sym -> IO (LLVMVal sym)
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (LLVMVal sym -> IO (LLVMVal sym))
-> LLVMVal sym -> IO (LLVMVal sym)
forall a b. (a -> b) -> a -> b
$ FloatSize 'X86_80Float
-> SymInterpretedFloat sym 'X86_80Float -> LLVMVal sym
forall (fi :: FloatInfo) sym.
FloatSize fi -> SymInterpretedFloat sym fi -> LLVMVal sym
LLVMValFloat FloatSize 'X86_80Float
X86_FP80Size RegValue sym tp
SymInterpretedFloat sym 'X86_80Float
x

packMemValue sym
sym (StorageType (Bitvector Bytes
bytes) Bytes
_) (BVRepr NatRepr n
w) RegValue sym tp
bv
  | Natural -> Bytes
forall a. Integral a => a -> Bytes
bitsToBytes (NatRepr n -> Natural
forall (n :: Natural). NatRepr n -> Natural
natValue NatRepr n
w) Bytes -> Bytes -> Bool
forall a. Eq a => a -> a -> Bool
== Bytes
bytes =
      do SymNat sym
blk0 <- sym -> Natural -> IO (SymNat sym)
forall sym. IsExprBuilder sym => sym -> Natural -> IO (SymNat sym)
natLit sym
sym Natural
0
         LLVMVal sym -> IO (LLVMVal sym)
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (LLVMVal sym -> IO (LLVMVal sym))
-> LLVMVal sym -> IO (LLVMVal sym)
forall a b. (a -> b) -> a -> b
$ SymNat sym -> SymBV sym n -> LLVMVal sym
forall (w :: Natural) sym.
(1 <= w) =>
SymNat sym -> SymBV sym w -> LLVMVal sym
LLVMValInt SymNat sym
blk0 RegValue sym tp
SymBV sym n
bv

packMemValue sym
_sym (StorageType (Bitvector Bytes
bytes) Bytes
_) (LLVMPointerRepr NatRepr w
w) (LLVMPointer SymNat sym
blk SymBV sym w
off)
  | Natural -> Bytes
forall a. Integral a => a -> Bytes
bitsToBytes (NatRepr w -> Natural
forall (n :: Natural). NatRepr n -> Natural
natValue NatRepr w
w) Bytes -> Bytes -> Bool
forall a. Eq a => a -> a -> Bool
== Bytes
bytes =
       LLVMVal sym -> IO (LLVMVal sym)
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (LLVMVal sym -> IO (LLVMVal sym))
-> LLVMVal sym -> IO (LLVMVal sym)
forall a b. (a -> b) -> a -> b
$ SymNat sym -> SymBV sym w -> LLVMVal sym
forall (w :: Natural) sym.
(1 <= w) =>
SymNat sym -> SymBV sym w -> LLVMVal sym
LLVMValInt SymNat sym
blk SymBV sym w
off

packMemValue sym
sym (StorageType (Array Natural
sz StorageType
tp) Bytes
_) (VectorRepr TypeRepr tp1
tpr) RegValue sym tp
vec
  | Vector (RegValue sym tp1) -> Int
forall a. Vector a -> Int
V.length Vector (RegValue sym tp1)
RegValue sym tp
vec Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Natural -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
sz = do
       Vector (LLVMVal sym)
vec' <- (RegValue sym tp1 -> IO (LLVMVal sym))
-> Vector (RegValue sym tp1) -> IO (Vector (LLVMVal sym))
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> Vector a -> f (Vector b)
traverse (sym
-> StorageType
-> TypeRepr tp1
-> RegValue sym tp1
-> IO (LLVMVal sym)
forall sym (tp :: CrucibleType).
IsSymInterface sym =>
sym
-> StorageType
-> TypeRepr tp
-> RegValue sym tp
-> IO (LLVMVal sym)
packMemValue sym
sym StorageType
tp TypeRepr tp1
tpr) Vector (RegValue sym tp1)
RegValue sym tp
vec
       LLVMVal sym -> IO (LLVMVal sym)
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (LLVMVal sym -> IO (LLVMVal sym))
-> LLVMVal sym -> IO (LLVMVal sym)
forall a b. (a -> b) -> a -> b
$ StorageType -> Vector (LLVMVal sym) -> LLVMVal sym
forall sym. StorageType -> Vector (LLVMVal sym) -> LLVMVal sym
LLVMValArray StorageType
tp Vector (LLVMVal sym)
vec'

packMemValue sym
sym (StorageType (Struct Vector (Field StorageType)
fls) Bytes
_) (StructRepr CtxRepr ctx
ctx) RegValue sym tp
xs = do
  Vector (Field StorageType, LLVMVal sym)
fls' <- Int
-> (Int -> IO (Field StorageType, LLVMVal sym))
-> IO (Vector (Field StorageType, LLVMVal sym))
forall (m :: Type -> Type) a.
Monad m =>
Int -> (Int -> m a) -> m (Vector a)
V.generateM (Vector (Field StorageType) -> Int
forall a. Vector a -> Int
V.length Vector (Field StorageType)
fls) ((Int -> IO (Field StorageType, LLVMVal sym))
 -> IO (Vector (Field StorageType, LLVMVal sym)))
-> (Int -> IO (Field StorageType, LLVMVal sym))
-> IO (Vector (Field StorageType, LLVMVal sym))
forall a b. (a -> b) -> a -> b
$ \Int
i -> do
              let fl :: Field StorageType
fl = Vector (Field StorageType)
fls Vector (Field StorageType) -> Int -> Field StorageType
forall a. Vector a -> Int -> a
V.! Int
i
              case Int -> Size ctx -> Maybe (Some (Index ctx))
forall {k} (ctx :: Ctx k).
Int -> Size ctx -> Maybe (Some (Index ctx))
Ctx.intIndex Int
i (CtxRepr ctx -> Size ctx
forall {k} (f :: k -> Type) (ctx :: Ctx k).
Assignment f ctx -> Size ctx
Ctx.size CtxRepr ctx
ctx) of
                Just (Some Index ctx x
idx) -> do
                  let tpr :: TypeRepr x
tpr = CtxRepr ctx
ctx CtxRepr ctx -> Index ctx x -> TypeRepr x
forall {k} (f :: k -> Type) (ctx :: Ctx k) (tp :: k).
Assignment f ctx -> Index ctx tp -> f tp
Ctx.! Index ctx x
idx
                  let RV RegValue sym x
val = RegValue sym tp
Assignment (RegValue' sym) ctx
xs Assignment (RegValue' sym) ctx -> Index ctx x -> RegValue' sym x
forall {k} (f :: k -> Type) (ctx :: Ctx k) (tp :: k).
Assignment f ctx -> Index ctx tp -> f tp
Ctx.! Index ctx x
idx
                  LLVMVal sym
val' <- sym
-> StorageType -> TypeRepr x -> RegValue sym x -> IO (LLVMVal sym)
forall sym (tp :: CrucibleType).
IsSymInterface sym =>
sym
-> StorageType
-> TypeRepr tp
-> RegValue sym tp
-> IO (LLVMVal sym)
packMemValue sym
sym (Field StorageType
flField StorageType
-> Getting StorageType (Field StorageType) StorageType
-> StorageType
forall s a. s -> Getting a s a -> a
^.Getting StorageType (Field StorageType) StorageType
forall a b (f :: Type -> Type).
Functor f =>
(a -> f b) -> Field a -> f (Field b)
fieldVal) TypeRepr x
tpr RegValue sym x
val
                  (Field StorageType, LLVMVal sym)
-> IO (Field StorageType, LLVMVal sym)
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Field StorageType
fl, LLVMVal sym
val')
                Maybe (Some (Index ctx))
_ -> String -> [String] -> IO (Field StorageType, LLVMVal sym)
forall a. HasCallStack => String -> [String] -> a
panic String
"MemModel.packMemValue"
                      [ String
"Mismatch between LLVM and Crucible types"
                      , String
"*** Filed out of bounds: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i
                      ]
  LLVMVal sym -> IO (LLVMVal sym)
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (LLVMVal sym -> IO (LLVMVal sym))
-> LLVMVal sym -> IO (LLVMVal sym)
forall a b. (a -> b) -> a -> b
$ Vector (Field StorageType, LLVMVal sym) -> LLVMVal sym
forall sym. Vector (Field StorageType, LLVMVal sym) -> LLVMVal sym
LLVMValStruct Vector (Field StorageType, LLVMVal sym)
fls'

packMemValue sym
_ StorageType
stTy TypeRepr tp
crTy RegValue sym tp
_ =
  String -> [String] -> IO (LLVMVal sym)
forall a. HasCallStack => String -> [String] -> a
panic String
"MemModel.packMemValue"
    [ String
"Type mismatch when storing value."
    , String
"*** Expected storable type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ StorageType -> String
forall a. Show a => a -> String
show StorageType
stTy
    , String
"*** Given crucible type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TypeRepr tp -> String
forall a. Show a => a -> String
show TypeRepr tp
crTy
    ]


----------------------------------------------------------------------
-- Disjointness
--

-- | Assert that two memory regions are disjoint.
-- Two memory regions are disjoint if any of the following are true:
--
--   1. Their block pointers are different
--   2. Their blocks are the same, but /dest+dlen/ <= /src/
--   3. Their blocks are the same, but /src+slen/ <= /dest/
assertDisjointRegions ::
  (1 <= w, HasPtrWidth wptr, IsSymBackend sym bak, Partial.HasLLVMAnn sym) =>
  bak ->
  MemoryOp sym wptr ->
  NatRepr w ->
  LLVMPtr sym wptr {- ^ pointer to region 1 -} ->
  SymBV sym w      {- ^ length of region 1  -} ->
  LLVMPtr sym wptr {- ^ pointer to region 2 -} ->
  SymBV sym w      {- ^ length of region 2  -} ->
  IO ()
assertDisjointRegions :: forall (w :: Natural) (wptr :: Natural) sym bak.
(1 <= w, HasPtrWidth wptr, IsSymBackend sym bak, HasLLVMAnn sym) =>
bak
-> MemoryOp sym wptr
-> NatRepr w
-> LLVMPtr sym wptr
-> SymBV sym w
-> LLVMPtr sym wptr
-> SymBV sym w
-> IO ()
assertDisjointRegions bak
bak MemoryOp sym wptr
mop NatRepr w
w LLVMPtr sym wptr
dest SymBV sym w
dlen LLVMPtr sym wptr
src SymBV sym w
slen = do
  let sym :: sym
sym = bak -> sym
forall sym bak. HasSymInterface sym bak => bak -> sym
backendGetSym bak
bak
  SymExpr sym BaseBoolType
c <- sym
-> NatRepr w
-> LLVMPtr sym wptr
-> SymBV sym w
-> LLVMPtr sym wptr
-> SymBV sym w
-> IO (SymExpr sym BaseBoolType)
forall (w :: Natural) (wptr :: Natural) sym.
(1 <= w, HasPtrWidth wptr, IsSymInterface sym) =>
sym
-> NatRepr w
-> LLVMPtr sym wptr
-> SymBV sym w
-> LLVMPtr sym wptr
-> SymBV sym w
-> IO (Pred sym)
buildDisjointRegionsAssertion sym
sym NatRepr w
w LLVMPtr sym wptr
dest SymBV sym w
dlen LLVMPtr sym wptr
src SymBV sym w
slen
  SymExpr sym BaseBoolType
c' <- sym
-> MemoryOp sym wptr
-> MemoryErrorReason
-> SymExpr sym BaseBoolType
-> IO (SymExpr sym BaseBoolType)
forall sym (w :: Natural).
(IsSymInterface sym, HasLLVMAnn sym, 1 <= w) =>
sym
-> MemoryOp sym w -> MemoryErrorReason -> Pred sym -> IO (Pred sym)
Partial.annotateME sym
sym MemoryOp sym wptr
mop MemoryErrorReason
OverlappingRegions SymExpr sym BaseBoolType
c
  bak -> SymExpr sym BaseBoolType -> SimErrorReason -> IO ()
forall sym bak.
IsSymBackend sym bak =>
bak -> Pred sym -> SimErrorReason -> IO ()
assert bak
bak SymExpr sym BaseBoolType
c' (String -> String -> SimErrorReason
AssertFailureSimError String
"Memory regions not disjoint" String
"")

buildDisjointRegionsAssertion ::
  (1 <= w, HasPtrWidth wptr, IsSymInterface sym) =>
  sym ->
  NatRepr w ->
  LLVMPtr sym wptr {- ^ pointer to region 1 -} ->
  SymBV sym w      {- ^ length of region 1  -} ->
  LLVMPtr sym wptr {- ^ pointer to region 2 -} ->
  SymBV sym w      {- ^ length of region 2  -} ->
  IO (Pred sym)
buildDisjointRegionsAssertion :: forall (w :: Natural) (wptr :: Natural) sym.
(1 <= w, HasPtrWidth wptr, IsSymInterface sym) =>
sym
-> NatRepr w
-> LLVMPtr sym wptr
-> SymBV sym w
-> LLVMPtr sym wptr
-> SymBV sym w
-> IO (Pred sym)
buildDisjointRegionsAssertion sym
sym NatRepr w
w LLVMPtr sym wptr
dest SymBV sym w
dlen LLVMPtr sym wptr
src SymBV sym w
slen = do
  let LLVMPointer SymNat sym
_dblk SymBV sym wptr
doff = LLVMPtr sym wptr
dest
  let LLVMPointer SymNat sym
_sblk SymBV sym wptr
soff = LLVMPtr sym wptr
src

  SymBV sym wptr
dend <- sym -> SymBV sym wptr -> SymBV sym wptr -> IO (SymBV sym wptr)
forall (w :: Natural).
(1 <= w) =>
sym -> SymBV sym w -> SymBV sym w -> IO (SymBV sym w)
forall sym (w :: Natural).
(IsExprBuilder sym, 1 <= w) =>
sym -> SymBV sym w -> SymBV sym w -> IO (SymBV sym w)
bvAdd sym
sym SymBV sym wptr
doff (SymBV sym wptr -> IO (SymBV sym wptr))
-> IO (SymBV sym wptr) -> IO (SymBV sym wptr)
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< sym
-> NatRepr w -> NatRepr wptr -> SymBV sym w -> IO (SymBV sym wptr)
forall (w :: Natural) (w' :: Natural) sym.
(1 <= w, 1 <= w', IsSymInterface sym) =>
sym
-> NatRepr w
-> NatRepr w'
-> SymExpr sym (BaseBVType w)
-> IO (SymExpr sym (BaseBVType w'))
sextendBVTo sym
sym NatRepr w
w NatRepr wptr
forall (w :: Natural) (w' :: Natural).
(HasPtrWidth w, w ~ w') =>
NatRepr w'
PtrWidth SymBV sym w
dlen
  SymBV sym wptr
send <- sym -> SymBV sym wptr -> SymBV sym wptr -> IO (SymBV sym wptr)
forall (w :: Natural).
(1 <= w) =>
sym -> SymBV sym w -> SymBV sym w -> IO (SymBV sym w)
forall sym (w :: Natural).
(IsExprBuilder sym, 1 <= w) =>
sym -> SymBV sym w -> SymBV sym w -> IO (SymBV sym w)
bvAdd sym
sym SymBV sym wptr
soff (SymBV sym wptr -> IO (SymBV sym wptr))
-> IO (SymBV sym wptr) -> IO (SymBV sym wptr)
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< sym
-> NatRepr w -> NatRepr wptr -> SymBV sym w -> IO (SymBV sym wptr)
forall (w :: Natural) (w' :: Natural) sym.
(1 <= w, 1 <= w', IsSymInterface sym) =>
sym
-> NatRepr w
-> NatRepr w'
-> SymExpr sym (BaseBVType w)
-> IO (SymExpr sym (BaseBVType w'))
sextendBVTo sym
sym NatRepr w
w NatRepr wptr
forall (w :: Natural) (w' :: Natural).
(HasPtrWidth w, w ~ w') =>
NatRepr w'
PtrWidth SymBV sym w
slen

  Pred sym
diffBlk   <- sym -> Pred sym -> IO (Pred sym)
forall sym. IsExprBuilder sym => sym -> Pred sym -> IO (Pred sym)
notPred sym
sym (Pred sym -> IO (Pred sym)) -> IO (Pred sym) -> IO (Pred sym)
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< sym -> LLVMPtr sym wptr -> LLVMPtr sym wptr -> IO (Pred sym)
forall (w :: Natural) sym.
(1 <= w, IsSymInterface sym) =>
sym -> LLVMPtr sym w -> LLVMPtr sym w -> IO (Pred sym)
ptrSameAlloc sym
sym LLVMPtr sym wptr
dest LLVMPtr sym wptr
src
  Pred sym
destfirst <- sym -> SymBV sym wptr -> SymBV sym wptr -> IO (Pred sym)
forall (w :: Natural).
(1 <= w) =>
sym -> SymBV sym w -> SymBV sym w -> IO (Pred sym)
forall sym (w :: Natural).
(IsExprBuilder sym, 1 <= w) =>
sym -> SymBV sym w -> SymBV sym w -> IO (Pred sym)
bvSle sym
sym SymBV sym wptr
dend SymBV sym wptr
soff
  Pred sym
srcfirst  <- sym -> SymBV sym wptr -> SymBV sym wptr -> IO (Pred sym)
forall (w :: Natural).
(1 <= w) =>
sym -> SymBV sym w -> SymBV sym w -> IO (Pred sym)
forall sym (w :: Natural).
(IsExprBuilder sym, 1 <= w) =>
sym -> SymBV sym w -> SymBV sym w -> IO (Pred sym)
bvSle sym
sym SymBV sym wptr
send SymBV sym wptr
doff

  sym -> Pred sym -> Pred sym -> IO (Pred sym)
forall sym.
IsExprBuilder sym =>
sym -> Pred sym -> Pred sym -> IO (Pred sym)
orPred sym
sym Pred sym
diffBlk (Pred sym -> IO (Pred sym)) -> IO (Pred sym) -> IO (Pred sym)
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< sym -> Pred sym -> Pred sym -> IO (Pred sym)
forall sym.
IsExprBuilder sym =>
sym -> Pred sym -> Pred sym -> IO (Pred sym)
orPred sym
sym Pred sym
destfirst Pred sym
srcfirst

-- | Build the condition that two memory regions are disjoint, using
-- subtraction and comparison to zero instead of direct comparison (that is,
-- 0 <= y - x instead of x <= y). This enables semiring and abstract domain
-- simplifications. The result if false if any offset is not positive when
-- interpreted as signed bitvector.
buildDisjointRegionsAssertionWithSub ::
  (HasPtrWidth wptr, IsSymInterface sym) =>
  sym ->
  LLVMPtr sym wptr {- ^ pointer to region 1 -} ->
  SymBV sym wptr   {- ^ length of region 1  -} ->
  LLVMPtr sym wptr {- ^ pointer to region 2 -} ->
  SymBV sym wptr   {- ^ length of region 2  -} ->
  IO (Pred sym)
buildDisjointRegionsAssertionWithSub :: forall (wptr :: Natural) sym.
(HasPtrWidth wptr, IsSymInterface sym) =>
sym
-> LLVMPtr sym wptr
-> SymBV sym wptr
-> LLVMPtr sym wptr
-> SymBV sym wptr
-> IO (Pred sym)
buildDisjointRegionsAssertionWithSub sym
sym LLVMPtr sym wptr
dest SymBV sym wptr
dlen LLVMPtr sym wptr
src SymBV sym wptr
slen = do
  let LLVMPointer SymNat sym
_dblk SymBV sym wptr
doff = LLVMPtr sym wptr
dest
  let LLVMPointer SymNat sym
_sblk SymBV sym wptr
soff = LLVMPtr sym wptr
src

  SymBV sym wptr
dend <- sym -> SymBV sym wptr -> SymBV sym wptr -> IO (SymBV sym wptr)
forall (w :: Natural).
(1 <= w) =>
sym -> SymBV sym w -> SymBV sym w -> IO (SymBV sym w)
forall sym (w :: Natural).
(IsExprBuilder sym, 1 <= w) =>
sym -> SymBV sym w -> SymBV sym w -> IO (SymBV sym w)
bvAdd sym
sym SymBV sym wptr
doff SymBV sym wptr
dlen
  SymBV sym wptr
send <- sym -> SymBV sym wptr -> SymBV sym wptr -> IO (SymBV sym wptr)
forall (w :: Natural).
(1 <= w) =>
sym -> SymBV sym w -> SymBV sym w -> IO (SymBV sym w)
forall sym (w :: Natural).
(IsExprBuilder sym, 1 <= w) =>
sym -> SymBV sym w -> SymBV sym w -> IO (SymBV sym w)
bvAdd sym
sym SymBV sym wptr
soff SymBV sym wptr
slen

  SymBV sym wptr
zero_bv <- sym -> NatRepr wptr -> IO (SymBV sym wptr)
forall (w :: Natural) sym.
(1 <= w, IsExprBuilder sym) =>
sym -> NatRepr w -> IO (SymBV sym w)
bvZero sym
sym NatRepr wptr
forall (w :: Natural) (w' :: Natural).
(HasPtrWidth w, w ~ w') =>
NatRepr w'
PtrWidth

  Pred sym
diffBlk <- sym -> Pred sym -> IO (Pred sym)
forall sym. IsExprBuilder sym => sym -> Pred sym -> IO (Pred sym)
notPred sym
sym (Pred sym -> IO (Pred sym)) -> IO (Pred sym) -> IO (Pred sym)
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< sym -> LLVMPtr sym wptr -> LLVMPtr sym wptr -> IO (Pred sym)
forall (w :: Natural) sym.
(1 <= w, IsSymInterface sym) =>
sym -> LLVMPtr sym w -> LLVMPtr sym w -> IO (Pred sym)
ptrSameAlloc sym
sym LLVMPtr sym wptr
dest LLVMPtr sym wptr
src

  Pred sym
allPos <- sym -> Fold [Pred sym] (Pred sym) -> [Pred sym] -> IO (Pred sym)
forall sym s.
IsExprBuilder sym =>
sym -> Fold s (Pred sym) -> s -> IO (Pred sym)
andAllOf sym
sym (Pred sym -> f (Pred sym)) -> [Pred sym] -> f [Pred sym]
Fold [Pred sym] (Pred sym)
forall (f :: Type -> Type) a. Foldable f => IndexedFold Int (f a) a
IndexedFold Int [Pred sym] (Pred sym)
folded ([Pred sym] -> IO (Pred sym)) -> IO [Pred sym] -> IO (Pred sym)
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< (SymBV sym wptr -> IO (Pred sym))
-> [SymBV sym wptr] -> IO [Pred sym]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m b) -> [a] -> m [b]
mapM (sym -> SymBV sym wptr -> SymBV sym wptr -> IO (Pred sym)
forall (w :: Natural).
(1 <= w) =>
sym -> SymBV sym w -> SymBV sym w -> IO (Pred sym)
forall sym (w :: Natural).
(IsExprBuilder sym, 1 <= w) =>
sym -> SymBV sym w -> SymBV sym w -> IO (Pred sym)
bvSle sym
sym SymBV sym wptr
zero_bv) [SymBV sym wptr
doff, SymBV sym wptr
dend, SymBV sym wptr
soff, SymBV sym wptr
send]
  Pred sym
destfirst <- sym -> SymBV sym wptr -> SymBV sym wptr -> IO (Pred sym)
forall (w :: Natural).
(1 <= w) =>
sym -> SymBV sym w -> SymBV sym w -> IO (Pred sym)
forall sym (w :: Natural).
(IsExprBuilder sym, 1 <= w) =>
sym -> SymBV sym w -> SymBV sym w -> IO (Pred sym)
bvSle sym
sym SymBV sym wptr
zero_bv (SymBV sym wptr -> IO (Pred sym))
-> IO (SymBV sym wptr) -> IO (Pred sym)
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< sym -> SymBV sym wptr -> SymBV sym wptr -> IO (SymBV sym wptr)
forall (w :: Natural).
(1 <= w) =>
sym -> SymBV sym w -> SymBV sym w -> IO (SymBV sym w)
forall sym (w :: Natural).
(IsExprBuilder sym, 1 <= w) =>
sym -> SymBV sym w -> SymBV sym w -> IO (SymBV sym w)
bvSub sym
sym SymBV sym wptr
soff SymBV sym wptr
dend
  Pred sym
srcfirst <- sym -> SymBV sym wptr -> SymBV sym wptr -> IO (Pred sym)
forall (w :: Natural).
(1 <= w) =>
sym -> SymBV sym w -> SymBV sym w -> IO (Pred sym)
forall sym (w :: Natural).
(IsExprBuilder sym, 1 <= w) =>
sym -> SymBV sym w -> SymBV sym w -> IO (Pred sym)
bvSle sym
sym SymBV sym wptr
zero_bv (SymBV sym wptr -> IO (Pred sym))
-> IO (SymBV sym wptr) -> IO (Pred sym)
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< sym -> SymBV sym wptr -> SymBV sym wptr -> IO (SymBV sym wptr)
forall (w :: Natural).
(1 <= w) =>
sym -> SymBV sym w -> SymBV sym w -> IO (SymBV sym w)
forall sym (w :: Natural).
(IsExprBuilder sym, 1 <= w) =>
sym -> SymBV sym w -> SymBV sym w -> IO (SymBV sym w)
bvSub sym
sym SymBV sym wptr
doff SymBV sym wptr
send

  sym -> Pred sym -> Pred sym -> IO (Pred sym)
forall sym.
IsExprBuilder sym =>
sym -> Pred sym -> Pred sym -> IO (Pred sym)
orPred sym
sym Pred sym
diffBlk (Pred sym -> IO (Pred sym)) -> IO (Pred sym) -> IO (Pred sym)
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< sym -> Pred sym -> Pred sym -> IO (Pred sym)
forall sym.
IsExprBuilder sym =>
sym -> Pred sym -> Pred sym -> IO (Pred sym)
andPred sym
sym Pred sym
allPos (Pred sym -> IO (Pred sym)) -> IO (Pred sym) -> IO (Pred sym)
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< sym -> Pred sym -> Pred sym -> IO (Pred sym)
forall sym.
IsExprBuilder sym =>
sym -> Pred sym -> Pred sym -> IO (Pred sym)
orPred sym
sym Pred sym
destfirst Pred sym
srcfirst

----------------------------------------------------------------------
-- constToLLVMVal
--

-- | This is used (by saw-script) to initialize globals.
--
-- In this translation, we lose the distinction between pointers and ints.
--
-- This is parameterized (hence, \"P\") over a function for looking up the
-- pointer values of global symbols. This parameter is used by @populateGlobal@
-- to recursively populate globals that may reference one another.
constToLLVMValP :: forall wptr sym io.
  ( MonadIO io
  , MonadFail io
  , HasPtrWidth wptr
  , IsSymInterface sym
  , HasCallStack
  ) => sym                                 -- ^ The symbolic backend
    -> (L.Symbol -> io (LLVMPtr sym wptr)) -- ^ How to look up global symbols
    -> LLVMConst                           -- ^ Constant expression to translate
    -> io (LLVMVal sym)

-- See comment on @LLVMVal@ on why we use a literal 0.
constToLLVMValP :: forall (wptr :: Natural) sym (io :: Type -> Type).
(MonadIO io, MonadFail io, HasPtrWidth wptr, IsSymInterface sym,
 HasCallStack) =>
sym
-> (Symbol -> io (LLVMPtr sym wptr))
-> LLVMConst
-> io (LLVMVal sym)
constToLLVMValP sym
sym Symbol -> io (LLVMPtr sym wptr)
_ (IntConst NatRepr w
w BV w
i) = IO (LLVMVal sym) -> io (LLVMVal sym)
forall a. IO a -> io a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (LLVMVal sym) -> io (LLVMVal sym))
-> IO (LLVMVal sym) -> io (LLVMVal sym)
forall a b. (a -> b) -> a -> b
$
  SymNat sym -> SymBV sym w -> LLVMVal sym
forall (w :: Natural) sym.
(1 <= w) =>
SymNat sym -> SymBV sym w -> LLVMVal sym
LLVMValInt (SymNat sym -> SymBV sym w -> LLVMVal sym)
-> IO (SymNat sym) -> IO (SymBV sym w -> LLVMVal sym)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> sym -> Natural -> IO (SymNat sym)
forall sym. IsExprBuilder sym => sym -> Natural -> IO (SymNat sym)
natLit sym
sym Natural
0 IO (SymBV sym w -> LLVMVal sym)
-> IO (SymBV sym w) -> IO (LLVMVal sym)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> sym -> NatRepr w -> BV w -> IO (SymBV sym w)
forall (w :: Natural).
(1 <= w) =>
sym -> NatRepr w -> BV w -> IO (SymBV sym w)
forall sym (w :: Natural).
(IsExprBuilder sym, 1 <= w) =>
sym -> NatRepr w -> BV w -> IO (SymBV sym w)
bvLit sym
sym NatRepr w
w BV w
i

constToLLVMValP sym
sym Symbol -> io (LLVMPtr sym wptr)
_ (FloatConst Float
f) = IO (LLVMVal sym) -> io (LLVMVal sym)
forall a. IO a -> io a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (LLVMVal sym) -> io (LLVMVal sym))
-> IO (LLVMVal sym) -> io (LLVMVal sym)
forall a b. (a -> b) -> a -> b
$
  FloatSize 'SingleFloat
-> SymExpr sym (SymInterpretedFloatType sym 'SingleFloat)
-> LLVMVal sym
forall (fi :: FloatInfo) sym.
FloatSize fi -> SymInterpretedFloat sym fi -> LLVMVal sym
LLVMValFloat FloatSize 'SingleFloat
SingleSize (SymExpr sym (SymInterpretedFloatType sym 'SingleFloat)
 -> LLVMVal sym)
-> IO (SymExpr sym (SymInterpretedFloatType sym 'SingleFloat))
-> IO (LLVMVal sym)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> sym
-> Float
-> IO (SymExpr sym (SymInterpretedFloatType sym 'SingleFloat))
forall sym.
IsInterpretedFloatExprBuilder sym =>
sym -> Float -> IO (SymInterpretedFloat sym 'SingleFloat)
iFloatLitSingle sym
sym Float
f

constToLLVMValP sym
sym Symbol -> io (LLVMPtr sym wptr)
_ (DoubleConst Double
d) = IO (LLVMVal sym) -> io (LLVMVal sym)
forall a. IO a -> io a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (LLVMVal sym) -> io (LLVMVal sym))
-> IO (LLVMVal sym) -> io (LLVMVal sym)
forall a b. (a -> b) -> a -> b
$
  FloatSize 'DoubleFloat
-> SymExpr sym (SymInterpretedFloatType sym 'DoubleFloat)
-> LLVMVal sym
forall (fi :: FloatInfo) sym.
FloatSize fi -> SymInterpretedFloat sym fi -> LLVMVal sym
LLVMValFloat FloatSize 'DoubleFloat
DoubleSize (SymExpr sym (SymInterpretedFloatType sym 'DoubleFloat)
 -> LLVMVal sym)
-> IO (SymExpr sym (SymInterpretedFloatType sym 'DoubleFloat))
-> IO (LLVMVal sym)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> sym
-> Double
-> IO (SymExpr sym (SymInterpretedFloatType sym 'DoubleFloat))
forall sym.
IsInterpretedFloatExprBuilder sym =>
sym -> Double -> IO (SymInterpretedFloat sym 'DoubleFloat)
iFloatLitDouble sym
sym Double
d

constToLLVMValP sym
sym Symbol -> io (LLVMPtr sym wptr)
_ (LongDoubleConst (L.FP80_LongDouble Word16
e Word64
s)) = IO (LLVMVal sym) -> io (LLVMVal sym)
forall a. IO a -> io a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (LLVMVal sym) -> io (LLVMVal sym))
-> IO (LLVMVal sym) -> io (LLVMVal sym)
forall a b. (a -> b) -> a -> b
$
  FloatSize 'X86_80Float
-> SymExpr sym (SymInterpretedFloatType sym 'X86_80Float)
-> LLVMVal sym
forall (fi :: FloatInfo) sym.
FloatSize fi -> SymInterpretedFloat sym fi -> LLVMVal sym
LLVMValFloat FloatSize 'X86_80Float
X86_FP80Size (SymExpr sym (SymInterpretedFloatType sym 'X86_80Float)
 -> LLVMVal sym)
-> IO (SymExpr sym (SymInterpretedFloatType sym 'X86_80Float))
-> IO (LLVMVal sym)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> sym
-> X86_80Val
-> IO (SymExpr sym (SymInterpretedFloatType sym 'X86_80Float))
forall sym.
IsInterpretedFloatExprBuilder sym =>
sym -> X86_80Val -> IO (SymInterpretedFloat sym 'X86_80Float)
iFloatLitLongDouble sym
sym (Word16 -> Word64 -> X86_80Val
X86_80Val Word16
e Word64
s)

constToLLVMValP sym
_ Symbol -> io (LLVMPtr sym wptr)
_ (StringConst ByteString
bs) =
  LLVMVal sym -> io (LLVMVal sym)
forall a. a -> io a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (ByteString -> LLVMVal sym
forall sym. ByteString -> LLVMVal sym
LLVMValString ByteString
bs)

constToLLVMValP sym
sym Symbol -> io (LLVMPtr sym wptr)
look (ArrayConst MemType
memty [LLVMConst]
xs) =
  StorageType -> Vector (LLVMVal sym) -> LLVMVal sym
forall sym. StorageType -> Vector (LLVMVal sym) -> LLVMVal sym
LLVMValArray (StorageType -> Vector (LLVMVal sym) -> LLVMVal sym)
-> io StorageType -> io (Vector (LLVMVal sym) -> LLVMVal sym)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> IO StorageType -> io StorageType
forall a. IO a -> io a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (MemType -> IO StorageType
forall (m :: Type -> Type) (wptr :: Natural).
(MonadFail m, HasPtrWidth wptr) =>
MemType -> m StorageType
toStorableType MemType
memty)
               io (Vector (LLVMVal sym) -> LLVMVal sym)
-> io (Vector (LLVMVal sym)) -> io (LLVMVal sym)
forall a b. io (a -> b) -> io a -> io b
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> ([LLVMVal sym] -> Vector (LLVMVal sym)
forall a. [a] -> Vector a
V.fromList ([LLVMVal sym] -> Vector (LLVMVal sym))
-> io [LLVMVal sym] -> io (Vector (LLVMVal sym))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (LLVMConst -> io (LLVMVal sym)) -> [LLVMConst] -> io [LLVMVal sym]
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (sym
-> (Symbol -> io (LLVMPtr sym wptr))
-> LLVMConst
-> io (LLVMVal sym)
forall (wptr :: Natural) sym (io :: Type -> Type).
(MonadIO io, MonadFail io, HasPtrWidth wptr, IsSymInterface sym,
 HasCallStack) =>
sym
-> (Symbol -> io (LLVMPtr sym wptr))
-> LLVMConst
-> io (LLVMVal sym)
constToLLVMValP sym
sym Symbol -> io (LLVMPtr sym wptr)
look) [LLVMConst]
xs)

-- Same as the array case
constToLLVMValP sym
sym Symbol -> io (LLVMPtr sym wptr)
look (VectorConst MemType
memty [LLVMConst]
xs) =
  StorageType -> Vector (LLVMVal sym) -> LLVMVal sym
forall sym. StorageType -> Vector (LLVMVal sym) -> LLVMVal sym
LLVMValArray (StorageType -> Vector (LLVMVal sym) -> LLVMVal sym)
-> io StorageType -> io (Vector (LLVMVal sym) -> LLVMVal sym)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> IO StorageType -> io StorageType
forall a. IO a -> io a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (MemType -> IO StorageType
forall (m :: Type -> Type) (wptr :: Natural).
(MonadFail m, HasPtrWidth wptr) =>
MemType -> m StorageType
toStorableType MemType
memty)
               io (Vector (LLVMVal sym) -> LLVMVal sym)
-> io (Vector (LLVMVal sym)) -> io (LLVMVal sym)
forall a b. io (a -> b) -> io a -> io b
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> ([LLVMVal sym] -> Vector (LLVMVal sym)
forall a. [a] -> Vector a
V.fromList ([LLVMVal sym] -> Vector (LLVMVal sym))
-> io [LLVMVal sym] -> io (Vector (LLVMVal sym))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (LLVMConst -> io (LLVMVal sym)) -> [LLVMConst] -> io [LLVMVal sym]
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (sym
-> (Symbol -> io (LLVMPtr sym wptr))
-> LLVMConst
-> io (LLVMVal sym)
forall (wptr :: Natural) sym (io :: Type -> Type).
(MonadIO io, MonadFail io, HasPtrWidth wptr, IsSymInterface sym,
 HasCallStack) =>
sym
-> (Symbol -> io (LLVMPtr sym wptr))
-> LLVMConst
-> io (LLVMVal sym)
constToLLVMValP sym
sym Symbol -> io (LLVMPtr sym wptr)
look) [LLVMConst]
xs)

constToLLVMValP sym
sym Symbol -> io (LLVMPtr sym wptr)
look (StructConst StructInfo
sInfo [LLVMConst]
xs) =
  Vector (Field StorageType, LLVMVal sym) -> LLVMVal sym
forall sym. Vector (Field StorageType, LLVMVal sym) -> LLVMVal sym
LLVMValStruct (Vector (Field StorageType, LLVMVal sym) -> LLVMVal sym)
-> io (Vector (Field StorageType, LLVMVal sym)) -> io (LLVMVal sym)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$>
    (FieldInfo -> LLVMConst -> io (Field StorageType, LLVMVal sym))
-> Vector FieldInfo
-> Vector LLVMConst
-> io (Vector (Field StorageType, LLVMVal sym))
forall (m :: Type -> Type) a b c.
Monad m =>
(a -> b -> m c) -> Vector a -> Vector b -> m (Vector c)
V.zipWithM (\FieldInfo
x LLVMConst
y -> (,) (Field StorageType
 -> LLVMVal sym -> (Field StorageType, LLVMVal sym))
-> io (Field StorageType)
-> io (LLVMVal sym -> (Field StorageType, LLVMVal sym))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Field StorageType) -> io (Field StorageType)
forall a. IO a -> io a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (FieldInfo -> IO (Field StorageType)
forall (wptr :: Natural) (m :: Type -> Type).
(HasPtrWidth wptr, MonadFail m) =>
FieldInfo -> m (Field StorageType)
fiToFT FieldInfo
x) io (LLVMVal sym -> (Field StorageType, LLVMVal sym))
-> io (LLVMVal sym) -> io (Field StorageType, LLVMVal sym)
forall a b. io (a -> b) -> io a -> io b
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> sym
-> (Symbol -> io (LLVMPtr sym wptr))
-> LLVMConst
-> io (LLVMVal sym)
forall (wptr :: Natural) sym (io :: Type -> Type).
(MonadIO io, MonadFail io, HasPtrWidth wptr, IsSymInterface sym,
 HasCallStack) =>
sym
-> (Symbol -> io (LLVMPtr sym wptr))
-> LLVMConst
-> io (LLVMVal sym)
constToLLVMValP sym
sym Symbol -> io (LLVMPtr sym wptr)
look LLVMConst
y)
               (StructInfo -> Vector FieldInfo
siFields StructInfo
sInfo)
               ([LLVMConst] -> Vector LLVMConst
forall a. [a] -> Vector a
V.fromList [LLVMConst]
xs)

-- SymbolConsts are offsets from global pointers. We translate them into the
-- pointer they represent.
constToLLVMValP sym
sym Symbol -> io (LLVMPtr sym wptr)
look (SymbolConst Symbol
symb Integer
i) = do
  -- Pointer to the global "symb"
  LLVMPointer sym wptr
ptr <- Symbol -> io (LLVMPtr sym wptr)
look Symbol
symb
  -- Offset to be added, as a bitvector
  SymExpr sym (BaseBVType wptr)
ibv <- IO (SymExpr sym (BaseBVType wptr))
-> io (SymExpr sym (BaseBVType wptr))
forall a. IO a -> io a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (SymExpr sym (BaseBVType wptr))
 -> io (SymExpr sym (BaseBVType wptr)))
-> IO (SymExpr sym (BaseBVType wptr))
-> io (SymExpr sym (BaseBVType wptr))
forall a b. (a -> b) -> a -> b
$ sym
-> NatRepr wptr -> BV wptr -> IO (SymExpr sym (BaseBVType wptr))
forall (w :: Natural).
(1 <= w) =>
sym -> NatRepr w -> BV w -> IO (SymBV sym w)
forall sym (w :: Natural).
(IsExprBuilder sym, 1 <= w) =>
sym -> NatRepr w -> BV w -> IO (SymBV sym w)
bvLit sym
sym ?ptrWidth::NatRepr wptr
NatRepr wptr
?ptrWidth (NatRepr wptr -> Integer -> BV wptr
forall (w :: Natural). NatRepr w -> Integer -> BV w
BV.mkBV ?ptrWidth::NatRepr wptr
NatRepr wptr
?ptrWidth Integer
i)

  -- blk is the allocation number that this global is stored in.
  -- In contrast to the case for @IntConst@ above, it is non-zero.
  let (SymNat sym
blk, SymExpr sym (BaseBVType wptr)
offset) = LLVMPtr sym wptr -> (SymNat sym, SymExpr sym (BaseBVType wptr))
forall sym (w :: Natural).
LLVMPtr sym w -> (SymNat sym, SymBV sym w)
llvmPointerView LLVMPtr sym wptr
LLVMPointer sym wptr
ptr
  SymNat sym -> SymExpr sym (BaseBVType wptr) -> LLVMVal sym
forall (w :: Natural) sym.
(1 <= w) =>
SymNat sym -> SymBV sym w -> LLVMVal sym
LLVMValInt SymNat sym
blk (SymExpr sym (BaseBVType wptr) -> LLVMVal sym)
-> io (SymExpr sym (BaseBVType wptr)) -> io (LLVMVal sym)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (SymExpr sym (BaseBVType wptr))
-> io (SymExpr sym (BaseBVType wptr))
forall a. IO a -> io a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (sym
-> SymExpr sym (BaseBVType wptr)
-> SymExpr sym (BaseBVType wptr)
-> IO (SymExpr sym (BaseBVType wptr))
forall (w :: Natural).
(1 <= w) =>
sym -> SymBV sym w -> SymBV sym w -> IO (SymBV sym w)
forall sym (w :: Natural).
(IsExprBuilder sym, 1 <= w) =>
sym -> SymBV sym w -> SymBV sym w -> IO (SymBV sym w)
bvAdd sym
sym SymExpr sym (BaseBVType wptr)
offset SymExpr sym (BaseBVType wptr)
ibv)

constToLLVMValP sym
_sym Symbol -> io (LLVMPtr sym wptr)
_look (ZeroConst MemType
memty) = IO (LLVMVal sym) -> io (LLVMVal sym)
forall a. IO a -> io a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (LLVMVal sym) -> io (LLVMVal sym))
-> IO (LLVMVal sym) -> io (LLVMVal sym)
forall a b. (a -> b) -> a -> b
$
  StorageType -> LLVMVal sym
forall sym. StorageType -> LLVMVal sym
LLVMValZero (StorageType -> LLVMVal sym) -> IO StorageType -> IO (LLVMVal sym)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> MemType -> IO StorageType
forall (m :: Type -> Type) (wptr :: Natural).
(MonadFail m, HasPtrWidth wptr) =>
MemType -> m StorageType
toStorableType MemType
memty
constToLLVMValP sym
_sym Symbol -> io (LLVMPtr sym wptr)
_look (UndefConst MemType
memty) = IO (LLVMVal sym) -> io (LLVMVal sym)
forall a. IO a -> io a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (LLVMVal sym) -> io (LLVMVal sym))
-> IO (LLVMVal sym) -> io (LLVMVal sym)
forall a b. (a -> b) -> a -> b
$
  StorageType -> LLVMVal sym
forall sym. StorageType -> LLVMVal sym
LLVMValUndef (StorageType -> LLVMVal sym) -> IO StorageType -> IO (LLVMVal sym)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> MemType -> IO StorageType
forall (m :: Type -> Type) (wptr :: Natural).
(MonadFail m, HasPtrWidth wptr) =>
MemType -> m StorageType
toStorableType MemType
memty


-- | Translate a constant into an LLVM runtime value. Assumes all necessary
-- globals have already been populated into the @'MemImpl'@.
constToLLVMVal :: forall wptr sym bak io.
  ( MonadIO io
  , MonadFail io
  , HasPtrWidth wptr
  , IsSymBackend sym bak
  , HasCallStack
  ) => bak               -- ^ The symbolic backend
    -> MemImpl sym       -- ^ The current memory state, for looking up globals
    -> LLVMConst         -- ^ Constant expression to translate
    -> io (LLVMVal sym)  -- ^ Runtime representation of the constant expression

-- See comment on @LLVMVal@ on why we use a literal 0.
constToLLVMVal :: forall (wptr :: Natural) sym bak (io :: Type -> Type).
(MonadIO io, MonadFail io, HasPtrWidth wptr, IsSymBackend sym bak,
 HasCallStack) =>
bak -> MemImpl sym -> LLVMConst -> io (LLVMVal sym)
constToLLVMVal bak
bak MemImpl sym
mem =
  sym
-> (Symbol -> io (LLVMPtr sym wptr))
-> LLVMConst
-> io (LLVMVal sym)
forall (wptr :: Natural) sym (io :: Type -> Type).
(MonadIO io, MonadFail io, HasPtrWidth wptr, IsSymInterface sym,
 HasCallStack) =>
sym
-> (Symbol -> io (LLVMPtr sym wptr))
-> LLVMConst
-> io (LLVMVal sym)
constToLLVMValP (bak -> sym
forall sym bak. HasSymInterface sym bak => bak -> sym
backendGetSym bak
bak)
     (\Symbol
symb -> IO (LLVMPtr sym wptr) -> io (LLVMPtr sym wptr)
forall a. IO a -> io a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (LLVMPtr sym wptr) -> io (LLVMPtr sym wptr))
-> IO (LLVMPtr sym wptr) -> io (LLVMPtr sym wptr)
forall a b. (a -> b) -> a -> b
$ bak -> MemImpl sym -> Symbol -> IO (LLVMPtr sym wptr)
forall sym bak (wptr :: Natural).
(IsSymBackend sym bak, HasPtrWidth wptr, HasCallStack) =>
bak -> MemImpl sym -> Symbol -> IO (LLVMPtr sym wptr)
doResolveGlobal bak
bak MemImpl sym
mem Symbol
symb)

-- TODO are these types just identical? Maybe we should combine them.
fiToFT :: (HasPtrWidth wptr, MonadFail m) => FieldInfo -> m (Field StorageType)
fiToFT :: forall (wptr :: Natural) (m :: Type -> Type).
(HasPtrWidth wptr, MonadFail m) =>
FieldInfo -> m (Field StorageType)
fiToFT FieldInfo
fi = (StorageType -> Field StorageType)
-> m StorageType -> m (Field StorageType)
forall a b. (a -> b) -> m a -> m b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (\StorageType
t -> Bytes -> StorageType -> Bytes -> Field StorageType
forall v. Bytes -> v -> Bytes -> Field v
mkField (FieldInfo -> Bytes
fiOffset FieldInfo
fi) StorageType
t (FieldInfo -> Bytes
fiPadding FieldInfo
fi))
                 (MemType -> m StorageType
forall (m :: Type -> Type) (wptr :: Natural).
(MonadFail m, HasPtrWidth wptr) =>
MemType -> m StorageType
toStorableType (MemType -> m StorageType) -> MemType -> m StorageType
forall a b. (a -> b) -> a -> b
$ FieldInfo -> MemType
fiType FieldInfo
fi)

----------------------------------------------------------------------
-- Globals
--

-- | Look up a 'Symbol' in the global map of the given 'MemImpl'.
-- Panic if the symbol is not present in the global map.
doResolveGlobal ::
  (IsSymBackend sym bak, HasPtrWidth wptr, HasCallStack) =>
  bak ->
  MemImpl sym ->
  L.Symbol {- ^ name of global -} ->
  IO (LLVMPtr sym wptr)
doResolveGlobal :: forall sym bak (wptr :: Natural).
(IsSymBackend sym bak, HasPtrWidth wptr, HasCallStack) =>
bak -> MemImpl sym -> Symbol -> IO (LLVMPtr sym wptr)
doResolveGlobal bak
bak MemImpl sym
mem symbol :: Symbol
symbol@(L.Symbol String
name) =
  let lookedUp :: Maybe (SomePointer sym)
lookedUp = Symbol -> Map Symbol (SomePointer sym) -> Maybe (SomePointer sym)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Symbol
symbol (MemImpl sym -> Map Symbol (SomePointer sym)
forall sym. MemImpl sym -> GlobalMap sym
memImplGlobalMap MemImpl sym
mem)
      msg1 :: String
msg1 = String
"Global allocation has incorrect width"
      msg1Details :: String
msg1Details = [String] -> String
forall a. Monoid a => [a] -> a
mconcat [ String
"Allocation associated with global symbol \""
                            , String
name
                            , String
"\" is not a pointer of the correct width"
                            ]
      msg2 :: String
msg2 = String
"Global symbol not allocated"
      msg2Details :: String
msg2Details = [String] -> String
forall a. Monoid a => [a] -> a
mconcat [ String
"Global symbol \""
                            , String
name
                            , String
"\" has no associated allocation"
                            ]
  in case Maybe (SomePointer sym)
lookedUp of
       Just (SomePointer LLVMPtr sym w
ptr) | NatRepr w
PtrWidth <- LLVMPtr sym w -> NatRepr w
forall sym (w :: Natural).
IsExprBuilder sym =>
LLVMPtr sym w -> NatRepr w
ptrWidth LLVMPtr sym w
ptr -> LLVMPointer sym wptr -> IO (LLVMPointer sym wptr)
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return LLVMPtr sym w
LLVMPointer sym wptr
ptr
       Maybe (SomePointer sym)
_ -> bak -> SimErrorReason -> IO (LLVMPtr sym wptr)
forall sym bak a.
IsSymBackend sym bak =>
bak -> SimErrorReason -> IO a
addFailedAssertion bak
bak (SimErrorReason -> IO (LLVMPtr sym wptr))
-> SimErrorReason -> IO (LLVMPtr sym wptr)
forall a b. (a -> b) -> a -> b
$
         if Maybe (SomePointer sym) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (SomePointer sym)
lookedUp
         then String -> String -> SimErrorReason
AssertFailureSimError String
msg1 String
msg1Details
         else String -> String -> SimErrorReason
AssertFailureSimError String
msg2 String
msg2Details

-- | Add an entry to the global map of the given 'MemImpl'.
--
-- This takes a list of symbols because there may be aliases to a global.
registerGlobal ::
  (IsExprBuilder sym, 1 <= wptr) =>
  MemImpl sym -> [L.Symbol] -> LLVMPtr sym wptr -> MemImpl sym
registerGlobal :: forall sym (wptr :: Natural).
(IsExprBuilder sym, 1 <= wptr) =>
MemImpl sym -> [Symbol] -> LLVMPtr sym wptr -> MemImpl sym
registerGlobal (MemImpl BlockSource
blockSource GlobalMap sym
gMap Map Natural Symbol
sMap Map Natural Dynamic
hMap Mem sym
mem) [Symbol]
symbols LLVMPtr sym wptr
ptr =
  BlockSource
-> GlobalMap sym
-> Map Natural Symbol
-> Map Natural Dynamic
-> Mem sym
-> MemImpl sym
forall sym.
BlockSource
-> GlobalMap sym
-> Map Natural Symbol
-> Map Natural Dynamic
-> Mem sym
-> MemImpl sym
MemImpl BlockSource
blockSource GlobalMap sym
gMap' Map Natural Symbol
sMap' Map Natural Dynamic
hMap Mem sym
mem
  where
    gMap' :: GlobalMap sym
gMap' = (Symbol -> GlobalMap sym -> GlobalMap sym)
-> GlobalMap sym -> [Symbol] -> GlobalMap sym
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Symbol
s GlobalMap sym
m -> Symbol -> SomePointer sym -> GlobalMap sym -> GlobalMap sym
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Symbol
s (LLVMPtr sym wptr -> SomePointer sym
forall sym (w :: Natural).
(1 <= w) =>
LLVMPtr sym w -> SomePointer sym
SomePointer LLVMPtr sym wptr
ptr) GlobalMap sym
m) GlobalMap sym
gMap [Symbol]
symbols
    sMap' :: Map Natural Symbol
sMap' =
      Map Natural Symbol
-> Maybe (Map Natural Symbol) -> Map Natural Symbol
forall a. a -> Maybe a -> a
fromMaybe Map Natural Symbol
sMap (Maybe (Map Natural Symbol) -> Map Natural Symbol)
-> Maybe (Map Natural Symbol) -> Map Natural Symbol
forall a b. (a -> b) -> a -> b
$
      do Symbol
symbol <- [Symbol] -> Maybe Symbol
forall a. [a] -> Maybe a
listToMaybe [Symbol]
symbols
         Natural
n <- SymNat sym -> Maybe Natural
forall sym. IsExpr (SymExpr sym) => SymNat sym -> Maybe Natural
asNat (LLVMPtr sym wptr -> SymNat sym
forall sym (w :: Natural). LLVMPtr sym w -> SymNat sym
llvmPointerBlock LLVMPtr sym wptr
ptr)
         BV wptr
z <- SymExpr sym (BaseBVType wptr) -> Maybe (BV wptr)
forall (w :: Natural). SymExpr sym (BaseBVType w) -> Maybe (BV w)
forall (e :: BaseType -> Type) (w :: Natural).
IsExpr e =>
e (BaseBVType w) -> Maybe (BV w)
asBV (LLVMPtr sym wptr -> SymExpr sym (BaseBVType wptr)
forall sym (w :: Natural). LLVMPtr sym w -> SymBV sym w
llvmPointerOffset LLVMPtr sym wptr
ptr)
         Bool -> Maybe ()
forall (f :: Type -> Type). Alternative f => Bool -> f ()
guard (BV wptr -> Integer
forall (w :: Natural). BV w -> Integer
BV.asUnsigned BV wptr
z Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0)
         Map Natural Symbol -> Maybe (Map Natural Symbol)
forall a. a -> Maybe a
Just (Natural -> Symbol -> Map Natural Symbol -> Map Natural Symbol
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Natural
n Symbol
symbol Map Natural Symbol
sMap)

-- | Allocate memory for each global, and register all the resulting
-- pointers in the global map.
allocGlobals ::
  ( IsSymBackend sym bak, HasPtrWidth wptr, Partial.HasLLVMAnn sym
  , ?memOpts :: MemOptions ) =>
  bak ->
  [(L.Global, [L.Symbol], Bytes, Alignment)] ->
  MemImpl sym ->
  IO (MemImpl sym)
allocGlobals :: forall sym bak (wptr :: Natural).
(IsSymBackend sym bak, HasPtrWidth wptr, HasLLVMAnn sym,
 ?memOpts::MemOptions) =>
bak
-> [(Global, [Symbol], Bytes, Alignment)]
-> MemImpl sym
-> IO (MemImpl sym)
allocGlobals bak
bak [(Global, [Symbol], Bytes, Alignment)]
gs MemImpl sym
mem = (MemImpl sym
 -> (Global, [Symbol], Bytes, Alignment) -> IO (MemImpl sym))
-> MemImpl sym
-> [(Global, [Symbol], Bytes, Alignment)]
-> IO (MemImpl sym)
forall (t :: Type -> Type) (m :: Type -> Type) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (bak
-> MemImpl sym
-> (Global, [Symbol], Bytes, Alignment)
-> IO (MemImpl sym)
forall sym bak (wptr :: Natural).
(IsSymBackend sym bak, HasPtrWidth wptr, HasLLVMAnn sym,
 ?memOpts::MemOptions) =>
bak
-> MemImpl sym
-> (Global, [Symbol], Bytes, Alignment)
-> IO (MemImpl sym)
allocGlobal bak
bak) MemImpl sym
mem [(Global, [Symbol], Bytes, Alignment)]
gs

allocGlobal ::
  ( IsSymBackend sym bak, HasPtrWidth wptr, Partial.HasLLVMAnn sym
  , ?memOpts :: MemOptions ) =>
  bak ->
  MemImpl sym ->
  (L.Global, [L.Symbol], Bytes, Alignment) ->
  IO (MemImpl sym)
allocGlobal :: forall sym bak (wptr :: Natural).
(IsSymBackend sym bak, HasPtrWidth wptr, HasLLVMAnn sym,
 ?memOpts::MemOptions) =>
bak
-> MemImpl sym
-> (Global, [Symbol], Bytes, Alignment)
-> IO (MemImpl sym)
allocGlobal bak
bak MemImpl sym
mem (Global
g, [Symbol]
aliases, Bytes
sz, Alignment
alignment) = do
  let sym :: sym
sym = bak -> sym
forall sym bak. HasSymInterface sym bak => bak -> sym
backendGetSym bak
bak
  let symbol :: Symbol
symbol@(L.Symbol String
sym_str) = Global -> Symbol
L.globalSym Global
g
  let displayName :: String
displayName = String
"[global variable  ] " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
sym_str
  let mut :: Mutability
mut = if GlobalAttrs -> Bool
L.gaConstant (Global -> GlobalAttrs
L.globalAttrs Global
g) then Mutability
G.Immutable else Mutability
G.Mutable
  SymExpr sym (BaseBVType wptr)
sz' <- sym
-> NatRepr wptr -> BV wptr -> IO (SymExpr sym (BaseBVType wptr))
forall (w :: Natural).
(1 <= w) =>
sym -> NatRepr w -> BV w -> IO (SymBV sym w)
forall sym (w :: Natural).
(IsExprBuilder sym, 1 <= w) =>
sym -> NatRepr w -> BV w -> IO (SymBV sym w)
bvLit sym
sym NatRepr wptr
forall (w :: Natural) (w' :: Natural).
(HasPtrWidth w, w ~ w') =>
NatRepr w'
PtrWidth (NatRepr wptr -> Bytes -> BV wptr
forall (w :: Natural). NatRepr w -> Bytes -> BV w
bytesToBV NatRepr wptr
forall (w :: Natural) (w' :: Natural).
(HasPtrWidth w, w ~ w') =>
NatRepr w'
PtrWidth Bytes
sz)
  -- TODO: Aliases are not propagated to doMalloc for error messages
  (LLVMPointer sym wptr
ptr, MemImpl sym
mem') <- bak
-> AllocType
-> Mutability
-> String
-> MemImpl sym
-> SymExpr sym (BaseBVType wptr)
-> Alignment
-> IO (LLVMPtr sym wptr, MemImpl sym)
forall sym bak (wptr :: Natural).
(IsSymBackend sym bak, HasPtrWidth wptr, HasLLVMAnn sym,
 ?memOpts::MemOptions) =>
bak
-> AllocType
-> Mutability
-> String
-> MemImpl sym
-> SymBV sym wptr
-> Alignment
-> IO (LLVMPtr sym wptr, MemImpl sym)
doMalloc bak
bak AllocType
G.GlobalAlloc Mutability
mut String
displayName MemImpl sym
mem SymExpr sym (BaseBVType wptr)
sz' Alignment
alignment
  MemImpl sym -> IO (MemImpl sym)
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (MemImpl sym -> [Symbol] -> LLVMPtr sym wptr -> MemImpl sym
forall sym (wptr :: Natural).
(IsExprBuilder sym, 1 <= wptr) =>
MemImpl sym -> [Symbol] -> LLVMPtr sym wptr -> MemImpl sym
registerGlobal MemImpl sym
mem' (Symbol
symbolSymbol -> [Symbol] -> [Symbol]
forall a. a -> [a] -> [a]
:[Symbol]
aliases) LLVMPtr sym wptr
LLVMPointer sym wptr
ptr)


concSomePointer ::
  IsSymInterface sym =>
  sym ->
  (forall tp. SymExpr sym tp -> IO (GroundValue tp)) ->
  SomePointer sym -> IO (SomePointer sym)
concSomePointer :: forall sym.
IsSymInterface sym =>
sym
-> (forall (tp :: BaseType). SymExpr sym tp -> IO (GroundValue tp))
-> SomePointer sym
-> IO (SomePointer sym)
concSomePointer sym
sym forall (tp :: BaseType). SymExpr sym tp -> IO (GroundValue tp)
conc (SomePointer LLVMPtr sym w
ptr) =
  LLVMPtr sym w -> SomePointer sym
LLVMPointer sym w -> SomePointer sym
forall sym (w :: Natural).
(1 <= w) =>
LLVMPtr sym w -> SomePointer sym
SomePointer (LLVMPointer sym w -> SomePointer sym)
-> IO (LLVMPointer sym w) -> IO (SomePointer sym)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> sym
-> (forall (tp :: BaseType). SymExpr sym tp -> IO (GroundValue tp))
-> LLVMPtr sym w
-> IO (LLVMPtr sym w)
forall sym (w :: Natural).
(IsExprBuilder sym, 1 <= w) =>
sym
-> (forall (tp :: BaseType). SymExpr sym tp -> IO (GroundValue tp))
-> RegValue sym (LLVMPointerType w)
-> IO (RegValue sym (LLVMPointerType w))
ML.concPtr sym
sym SymExpr sym tp -> IO (GroundValue tp)
forall (tp :: BaseType). SymExpr sym tp -> IO (GroundValue tp)
conc LLVMPtr sym w
ptr

concMemImpl ::
  IsSymInterface sym =>
  sym ->
  (forall tp. SymExpr sym tp -> IO (GroundValue tp)) ->
  MemImpl sym -> IO (MemImpl sym)
concMemImpl :: forall sym.
IsSymInterface sym =>
sym
-> (forall (tp :: BaseType). SymExpr sym tp -> IO (GroundValue tp))
-> MemImpl sym
-> IO (MemImpl sym)
concMemImpl sym
sym forall (tp :: BaseType). SymExpr sym tp -> IO (GroundValue tp)
conc MemImpl sym
mem =
  do Mem sym
heap' <- sym
-> (forall (tp :: BaseType). SymExpr sym tp -> IO (GroundValue tp))
-> Mem sym
-> IO (Mem sym)
forall sym.
IsExprBuilder sym =>
sym
-> (forall (tp :: BaseType). SymExpr sym tp -> IO (GroundValue tp))
-> Mem sym
-> IO (Mem sym)
ML.concMem sym
sym SymExpr sym tp -> IO (GroundValue tp)
forall (tp :: BaseType). SymExpr sym tp -> IO (GroundValue tp)
conc (MemImpl sym -> Mem sym
forall sym. MemImpl sym -> Mem sym
memImplHeap MemImpl sym
mem)
     Map Symbol (SomePointer sym)
gm'   <- (SomePointer sym -> IO (SomePointer sym))
-> Map Symbol (SomePointer sym)
-> IO (Map Symbol (SomePointer sym))
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> Map Symbol a -> f (Map Symbol b)
traverse (sym
-> (forall (tp :: BaseType). SymExpr sym tp -> IO (GroundValue tp))
-> SomePointer sym
-> IO (SomePointer sym)
forall sym.
IsSymInterface sym =>
sym
-> (forall (tp :: BaseType). SymExpr sym tp -> IO (GroundValue tp))
-> SomePointer sym
-> IO (SomePointer sym)
concSomePointer sym
sym SymExpr sym tp -> IO (GroundValue tp)
forall (tp :: BaseType). SymExpr sym tp -> IO (GroundValue tp)
conc) (MemImpl sym -> Map Symbol (SomePointer sym)
forall sym. MemImpl sym -> GlobalMap sym
memImplGlobalMap MemImpl sym
mem)
     MemImpl sym -> IO (MemImpl sym)
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure MemImpl sym
mem{ memImplHeap = heap', memImplGlobalMap = gm' }