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

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE UndecidableInstances #-}

module Lang.Crucible.LLVM.MemModel.Generic
  ( Mem
  , emptyMem
  , AllocType(..)
  , Mutability(..)
  , AllocInfo(..)
  , MemAllocs
  , memAllocs
  , memEndian
  , memAllocCount
  , memWriteCount
  , allocMem
  , allocAndWriteMem
  , readMem
  , isValidPointer
  , isAllocatedMutable
  , isAllocatedAlignedPointer
  , notAliasable
  , writeMem
  , writeConstMem
  , copyMem
  , setMem
  , invalidateMem
  , writeArrayMem
  , writeArrayConstMem
  , pushStackFrameMem
  , popStackFrameMem
  , freeMem
  , branchMem
  , branchAbortMem
  , mergeMem
  , asMemAllocationArrayStore
  , asMemMatchingArrayStore
  , isAligned

  , SomeAlloc(..)
  , possibleAllocs
  , possibleAllocInfo
  , ppSomeAlloc

    -- * Pretty printing
  , ppType
  , ppPtr
  , ppAllocs
  , ppMem
  , ppTermExpr
  ) where

import           Prelude hiding (pred)

import           Control.Lens
import           Control.Monad
import           Control.Monad.State.Strict
import           Control.Monad.Trans.Maybe
import           Data.IORef
import           Data.Maybe
import qualified Data.List as List
import qualified Data.Map as Map
import           Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
import           Data.Monoid
import           Data.Text (Text)
import           Numeric.Natural
import           Prettyprinter
import           Lang.Crucible.Panic (panic)

import           Data.BitVector.Sized (BV)
import qualified Data.BitVector.Sized as BV
import           Data.Parameterized.Classes
import qualified Data.Parameterized.Context as Ctx
import           Data.Parameterized.Ctx (SingleCtx)
import           Data.Parameterized.Some

import           What4.Interface
import qualified What4.Concrete as W4

import           Lang.Crucible.Backend
import           Lang.Crucible.LLVM.Bytes
import           Lang.Crucible.LLVM.DataLayout
import           Lang.Crucible.LLVM.Errors.MemoryError (MemErrContext, MemoryErrorReason(..), MemoryOp(..))
import qualified Lang.Crucible.LLVM.Errors.UndefinedBehavior as UB
import           Lang.Crucible.LLVM.MemModel.CallStack (getCallStack)
import           Lang.Crucible.LLVM.MemModel.Common
import           Lang.Crucible.LLVM.MemModel.Options
import           Lang.Crucible.LLVM.MemModel.MemLog
import           Lang.Crucible.LLVM.MemModel.Pointer
import           Lang.Crucible.LLVM.MemModel.Type
import           Lang.Crucible.LLVM.MemModel.Value
import           Lang.Crucible.LLVM.MemModel.Partial (PartLLVMVal, HasLLVMAnn)
import qualified Lang.Crucible.LLVM.MemModel.Partial as Partial
import           Lang.Crucible.LLVM.Utils
import           Lang.Crucible.Simulator.RegMap (RegValue'(..))

--------------------------------------------------------------------------------
-- Reading from memory

tgAddPtrC :: (1 <= w, IsExprBuilder sym) => sym -> NatRepr w -> LLVMPtr sym w -> Addr -> IO (LLVMPtr sym w)
tgAddPtrC :: forall (w :: Natural) sym.
(1 <= w, IsExprBuilder sym) =>
sym -> NatRepr w -> LLVMPtr sym w -> Addr -> IO (LLVMPtr sym w)
tgAddPtrC sym
sym NatRepr w
w LLVMPtr sym w
x Addr
y = sym
-> NatRepr w
-> LLVMPtr sym w
-> SymExpr sym (BaseBVType w)
-> IO (LLVMPtr sym w)
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 w
w LLVMPtr sym w
x (SymExpr sym (BaseBVType w) -> IO (LLVMPointer sym w))
-> IO (SymExpr sym (BaseBVType w)) -> IO (LLVMPointer sym w)
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< sym -> NatRepr w -> Addr -> IO (SymExpr sym (BaseBVType w))
forall (w :: Natural) sym.
(1 <= w, IsExprBuilder sym) =>
sym -> NatRepr w -> Addr -> IO (SymBV sym w)
constOffset sym
sym NatRepr w
w Addr
y

-- | An environment used to interpret 'OffsetExpr's, 'IntExpr's, and 'Cond's.
-- These data structures may contain uninterpreted variables to be filled in
-- with the offset address of a load or store, or the size of the current
-- region. Since regions may be unbounded in size, the size argument is a
-- 'Maybe' type.
data ExprEnv sym w = ExprEnv { forall sym (w :: Natural). ExprEnv sym w -> SymBV sym w
loadOffset  :: SymBV sym w
                             , forall sym (w :: Natural). ExprEnv sym w -> SymBV sym w
storeOffset :: SymBV sym w
                             , forall sym (w :: Natural). ExprEnv sym w -> Maybe (SymBV sym w)
sizeData    :: Maybe (SymBV sym w) }

ppExprEnv :: IsExprBuilder sym => ExprEnv sym w -> Doc ann
ppExprEnv :: forall sym (w :: Natural) ann.
IsExprBuilder sym =>
ExprEnv sym w -> Doc ann
ppExprEnv ExprEnv sym w
f =
  [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vcat
  [ Doc ann
"ExprEnv"
  , Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
indent Int
4 (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vcat
    [ Doc ann
"loadOffset:"  Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> SymExpr sym (BaseBVType w) -> Doc ann
forall (tp :: BaseType) ann. SymExpr sym tp -> Doc ann
forall (e :: BaseType -> Type) (tp :: BaseType) ann.
IsExpr e =>
e tp -> Doc ann
printSymExpr (ExprEnv sym w -> SymExpr sym (BaseBVType w)
forall sym (w :: Natural). ExprEnv sym w -> SymBV sym w
loadOffset ExprEnv sym w
f)
    , Doc ann
"storeOffset:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> SymExpr sym (BaseBVType w) -> Doc ann
forall (tp :: BaseType) ann. SymExpr sym tp -> Doc ann
forall (e :: BaseType -> Type) (tp :: BaseType) ann.
IsExpr e =>
e tp -> Doc ann
printSymExpr (ExprEnv sym w -> SymExpr sym (BaseBVType w)
forall sym (w :: Natural). ExprEnv sym w -> SymBV sym w
storeOffset ExprEnv sym w
f)
    , Doc ann
"sizeData:"    Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
-> (SymExpr sym (BaseBVType w) -> Doc ann)
-> Maybe (SymExpr sym (BaseBVType w))
-> Doc ann
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc ann
forall a. Monoid a => a
mempty SymExpr sym (BaseBVType w) -> Doc ann
forall (tp :: BaseType) ann. SymExpr sym tp -> Doc ann
forall (e :: BaseType -> Type) (tp :: BaseType) ann.
IsExpr e =>
e tp -> Doc ann
printSymExpr (ExprEnv sym w -> Maybe (SymExpr sym (BaseBVType w))
forall sym (w :: Natural). ExprEnv sym w -> Maybe (SymBV sym w)
sizeData ExprEnv sym w
f)
    ]
  ]

-- | Interpret an 'OffsetExpr' as a 'SymBV'. Although 'OffsetExpr's may contain
-- 'IntExpr's, which may be undefined if they refer to the size of an unbounded
-- memory region, this function will panic if both (1) the 'sizeData'
-- in the 'ExprEnv' is 'Nothing' and (2) 'StoreSize' occurs anywhere in the
-- 'OffsetExpr'.
genOffsetExpr ::
  (1 <= w, IsSymInterface sym) =>
  sym -> NatRepr w ->
  ExprEnv sym w ->
  OffsetExpr ->
  IO (SymBV sym w)
genOffsetExpr :: forall (w :: Natural) sym.
(1 <= w, IsSymInterface sym) =>
sym -> NatRepr w -> ExprEnv sym w -> OffsetExpr -> IO (SymBV sym w)
genOffsetExpr sym
sym NatRepr w
w f :: ExprEnv sym w
f@(ExprEnv SymBV sym w
load SymBV sym w
store Maybe (SymBV sym w)
_size) OffsetExpr
expr =
  case OffsetExpr
expr of
    OffsetAdd OffsetExpr
pe IntExpr
ie -> do
      SymBV sym w
pe' <- sym -> NatRepr w -> ExprEnv sym w -> OffsetExpr -> IO (SymBV sym w)
forall (w :: Natural) sym.
(1 <= w, IsSymInterface sym) =>
sym -> NatRepr w -> ExprEnv sym w -> OffsetExpr -> IO (SymBV sym w)
genOffsetExpr sym
sym NatRepr w
w ExprEnv sym w
f OffsetExpr
pe
      Maybe (SymBV sym w)
ie' <- sym
-> NatRepr w
-> ExprEnv sym w
-> IntExpr
-> IO (Maybe (SymBV sym w))
forall (w :: Natural) sym.
(1 <= w, IsSymInterface sym) =>
sym
-> NatRepr w
-> ExprEnv sym w
-> IntExpr
-> IO (Maybe (SymBV sym w))
genIntExpr sym
sym NatRepr w
w ExprEnv sym w
f IntExpr
ie
      case Maybe (SymBV sym w)
ie' of
        Maybe (SymBV sym w)
Nothing -> [Char] -> [[Char]] -> IO (SymBV sym w)
forall a. HasCallStack => [Char] -> [[Char]] -> a
panic [Char]
"Generic.genOffsetExpr"
                     [ [Char]
"Cannot construct an offset that references the size of an unbounded region"
                     , [Char]
"*** Invalid offset expression:  " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ OffsetExpr -> [Char]
forall a. Show a => a -> [Char]
show OffsetExpr
expr
                     , [Char]
"*** Under environment:  " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Doc Any -> [Char]
forall a. Show a => a -> [Char]
show (ExprEnv sym w -> Doc Any
forall sym (w :: Natural) ann.
IsExprBuilder sym =>
ExprEnv sym w -> Doc ann
ppExprEnv ExprEnv sym w
f)
                     ]
        Just SymBV sym w
ie'' -> sym -> SymBV sym w -> SymBV sym w -> IO (SymBV sym w)
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 w
pe' SymBV sym w
ie''
    OffsetExpr
Load  -> SymBV sym w -> IO (SymBV sym w)
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return SymBV sym w
load
    OffsetExpr
Store -> SymBV sym w -> IO (SymBV sym w)
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return SymBV sym w
store

-- | Interpret an 'IntExpr' as a 'SymBV'. If the 'IntExpr' contains an
-- occurrence of 'StoreSize' and the store size in the 'ExprEnv' is unbounded,
-- will return 'Nothing'.
genIntExpr ::
  (1 <= w, IsSymInterface sym) =>
  sym ->
  NatRepr w ->
  ExprEnv sym w ->
  IntExpr ->
  IO (Maybe (SymBV sym w))
genIntExpr :: forall (w :: Natural) sym.
(1 <= w, IsSymInterface sym) =>
sym
-> NatRepr w
-> ExprEnv sym w
-> IntExpr
-> IO (Maybe (SymBV sym w))
genIntExpr sym
sym NatRepr w
w f :: ExprEnv sym w
f@(ExprEnv SymBV sym w
_load SymBV sym w
_store Maybe (SymBV sym w)
size) IntExpr
expr =
  case IntExpr
expr of
    OffsetDiff OffsetExpr
e1 OffsetExpr
e2 -> do
      SymBV sym w
e1' <- sym -> NatRepr w -> ExprEnv sym w -> OffsetExpr -> IO (SymBV sym w)
forall (w :: Natural) sym.
(1 <= w, IsSymInterface sym) =>
sym -> NatRepr w -> ExprEnv sym w -> OffsetExpr -> IO (SymBV sym w)
genOffsetExpr sym
sym NatRepr w
w ExprEnv sym w
f OffsetExpr
e1
      SymBV sym w
e2' <- sym -> NatRepr w -> ExprEnv sym w -> OffsetExpr -> IO (SymBV sym w)
forall (w :: Natural) sym.
(1 <= w, IsSymInterface sym) =>
sym -> NatRepr w -> ExprEnv sym w -> OffsetExpr -> IO (SymBV sym w)
genOffsetExpr sym
sym NatRepr w
w ExprEnv sym w
f OffsetExpr
e2
      SymBV sym w -> Maybe (SymBV sym w)
forall a. a -> Maybe a
Just (SymBV sym w -> Maybe (SymBV sym w))
-> IO (SymBV sym w) -> IO (Maybe (SymBV sym w))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> sym -> SymBV sym w -> SymBV sym w -> IO (SymBV sym w)
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 w
e1' SymBV sym w
e2'
    IntAdd IntExpr
e1 IntExpr
e2 -> do
      Maybe (SymBV sym w)
e1' <- sym
-> NatRepr w
-> ExprEnv sym w
-> IntExpr
-> IO (Maybe (SymBV sym w))
forall (w :: Natural) sym.
(1 <= w, IsSymInterface sym) =>
sym
-> NatRepr w
-> ExprEnv sym w
-> IntExpr
-> IO (Maybe (SymBV sym w))
genIntExpr sym
sym NatRepr w
w ExprEnv sym w
f IntExpr
e1
      Maybe (SymBV sym w)
e2' <- sym
-> NatRepr w
-> ExprEnv sym w
-> IntExpr
-> IO (Maybe (SymBV sym w))
forall (w :: Natural) sym.
(1 <= w, IsSymInterface sym) =>
sym
-> NatRepr w
-> ExprEnv sym w
-> IntExpr
-> IO (Maybe (SymBV sym w))
genIntExpr sym
sym NatRepr w
w ExprEnv sym w
f IntExpr
e2
      case (Maybe (SymBV sym w)
e1', Maybe (SymBV sym w)
e2') of
        (Just SymBV sym w
e1'', Just SymBV sym w
e2'') -> SymBV sym w -> Maybe (SymBV sym w)
forall a. a -> Maybe a
Just (SymBV sym w -> Maybe (SymBV sym w))
-> IO (SymBV sym w) -> IO (Maybe (SymBV sym w))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> sym -> SymBV sym w -> SymBV sym w -> IO (SymBV sym w)
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 w
e1'' SymBV sym w
e2''
        (Maybe (SymBV sym w), Maybe (SymBV sym w))
_                      -> Maybe (SymBV sym w) -> IO (Maybe (SymBV sym w))
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe (SymBV sym w)
forall a. Maybe a
Nothing -- Unbounded space added to anything is unbounded
    CValue Addr
i -> SymBV sym w -> Maybe (SymBV sym w)
forall a. a -> Maybe a
Just (SymBV sym w -> Maybe (SymBV sym w))
-> IO (SymBV sym w) -> IO (Maybe (SymBV sym w))
forall (f :: Type -> Type) a b. Functor 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 (NatRepr w -> Addr -> BV w
forall (w :: Natural). NatRepr w -> Addr -> BV w
bytesToBV NatRepr w
w Addr
i)
    IntExpr
StoreSize -> Maybe (SymBV sym w) -> IO (Maybe (SymBV sym w))
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe (SymBV sym w)
size

-- | Interpret a conditional as a symbolic predicate.
genCondVar :: forall sym w.
  (1 <= w, IsSymInterface sym) =>
  sym -> NatRepr w ->
  ExprEnv sym w ->
  Cond ->
  IO (Pred sym)
genCondVar :: forall sym (w :: Natural).
(1 <= w, IsSymInterface sym) =>
sym -> NatRepr w -> ExprEnv sym w -> Cond -> IO (Pred sym)
genCondVar sym
sym NatRepr w
w ExprEnv sym w
inst Cond
c =
  case Cond
c of
    OffsetEq OffsetExpr
x OffsetExpr
y   -> IO (IO (Pred sym)) -> IO (Pred sym)
forall (m :: Type -> Type) a. Monad m => m (m a) -> m a
join (IO (IO (Pred sym)) -> IO (Pred sym))
-> IO (IO (Pred sym)) -> IO (Pred sym)
forall a b. (a -> b) -> a -> b
$ sym
-> SymExpr sym (BaseBVType w)
-> SymExpr sym (BaseBVType w)
-> 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)
bvEq sym
sym (SymExpr sym (BaseBVType w)
 -> SymExpr sym (BaseBVType w) -> IO (Pred sym))
-> IO (SymExpr sym (BaseBVType w))
-> IO (SymExpr sym (BaseBVType w) -> IO (Pred sym))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> sym
-> NatRepr w
-> ExprEnv sym w
-> OffsetExpr
-> IO (SymExpr sym (BaseBVType w))
forall (w :: Natural) sym.
(1 <= w, IsSymInterface sym) =>
sym -> NatRepr w -> ExprEnv sym w -> OffsetExpr -> IO (SymBV sym w)
genOffsetExpr sym
sym NatRepr w
w ExprEnv sym w
inst OffsetExpr
x IO (SymExpr sym (BaseBVType w) -> IO (Pred sym))
-> IO (SymExpr sym (BaseBVType w)) -> IO (IO (Pred 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
-> ExprEnv sym w
-> OffsetExpr
-> IO (SymExpr sym (BaseBVType w))
forall (w :: Natural) sym.
(1 <= w, IsSymInterface sym) =>
sym -> NatRepr w -> ExprEnv sym w -> OffsetExpr -> IO (SymBV sym w)
genOffsetExpr sym
sym NatRepr w
w ExprEnv sym w
inst OffsetExpr
y
    OffsetLe OffsetExpr
x OffsetExpr
y   -> IO (IO (Pred sym)) -> IO (Pred sym)
forall (m :: Type -> Type) a. Monad m => m (m a) -> m a
join (IO (IO (Pred sym)) -> IO (Pred sym))
-> IO (IO (Pred sym)) -> IO (Pred sym)
forall a b. (a -> b) -> a -> b
$ sym
-> SymExpr sym (BaseBVType w)
-> SymExpr sym (BaseBVType w)
-> 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)
bvUle sym
sym (SymExpr sym (BaseBVType w)
 -> SymExpr sym (BaseBVType w) -> IO (Pred sym))
-> IO (SymExpr sym (BaseBVType w))
-> IO (SymExpr sym (BaseBVType w) -> IO (Pred sym))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> sym
-> NatRepr w
-> ExprEnv sym w
-> OffsetExpr
-> IO (SymExpr sym (BaseBVType w))
forall (w :: Natural) sym.
(1 <= w, IsSymInterface sym) =>
sym -> NatRepr w -> ExprEnv sym w -> OffsetExpr -> IO (SymBV sym w)
genOffsetExpr sym
sym NatRepr w
w ExprEnv sym w
inst OffsetExpr
x IO (SymExpr sym (BaseBVType w) -> IO (Pred sym))
-> IO (SymExpr sym (BaseBVType w)) -> IO (IO (Pred 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
-> ExprEnv sym w
-> OffsetExpr
-> IO (SymExpr sym (BaseBVType w))
forall (w :: Natural) sym.
(1 <= w, IsSymInterface sym) =>
sym -> NatRepr w -> ExprEnv sym w -> OffsetExpr -> IO (SymBV sym w)
genOffsetExpr sym
sym NatRepr w
w ExprEnv sym w
inst OffsetExpr
y
    IntEq IntExpr
x IntExpr
y      -> IO (IO (Pred sym)) -> IO (Pred sym)
forall (m :: Type -> Type) a. Monad m => m (m a) -> m a
join (IO (IO (Pred sym)) -> IO (Pred sym))
-> IO (IO (Pred sym)) -> IO (Pred sym)
forall a b. (a -> b) -> a -> b
$ sym
-> Maybe (SymExpr sym (BaseBVType w))
-> Maybe (SymExpr sym (BaseBVType w))
-> IO (Pred sym)
forall (w :: Natural) sym.
(1 <= w, IsExprBuilder sym) =>
sym -> Maybe (SymBV sym w) -> Maybe (SymBV sym w) -> IO (Pred sym)
maybeBVEq sym
sym (Maybe (SymExpr sym (BaseBVType w))
 -> Maybe (SymExpr sym (BaseBVType w)) -> IO (Pred sym))
-> IO (Maybe (SymExpr sym (BaseBVType w)))
-> IO (Maybe (SymExpr sym (BaseBVType w)) -> IO (Pred sym))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> sym
-> NatRepr w
-> ExprEnv sym w
-> IntExpr
-> IO (Maybe (SymExpr sym (BaseBVType w)))
forall (w :: Natural) sym.
(1 <= w, IsSymInterface sym) =>
sym
-> NatRepr w
-> ExprEnv sym w
-> IntExpr
-> IO (Maybe (SymBV sym w))
genIntExpr sym
sym NatRepr w
w ExprEnv sym w
inst IntExpr
x IO (Maybe (SymExpr sym (BaseBVType w)) -> IO (Pred sym))
-> IO (Maybe (SymExpr sym (BaseBVType w))) -> IO (IO (Pred 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
-> ExprEnv sym w
-> IntExpr
-> IO (Maybe (SymExpr sym (BaseBVType w)))
forall (w :: Natural) sym.
(1 <= w, IsSymInterface sym) =>
sym
-> NatRepr w
-> ExprEnv sym w
-> IntExpr
-> IO (Maybe (SymBV sym w))
genIntExpr sym
sym NatRepr w
w ExprEnv sym w
inst IntExpr
y
    IntLe IntExpr
x IntExpr
y      -> IO (IO (Pred sym)) -> IO (Pred sym)
forall (m :: Type -> Type) a. Monad m => m (m a) -> m a
join (IO (IO (Pred sym)) -> IO (Pred sym))
-> IO (IO (Pred sym)) -> IO (Pred sym)
forall a b. (a -> b) -> a -> b
$ sym
-> Maybe (SymExpr sym (BaseBVType w))
-> Maybe (SymExpr sym (BaseBVType w))
-> IO (Pred sym)
forall (w :: Natural) sym.
(1 <= w, IsExprBuilder sym) =>
sym -> Maybe (SymBV sym w) -> Maybe (SymBV sym w) -> IO (Pred sym)
maybeBVLe sym
sym (Maybe (SymExpr sym (BaseBVType w))
 -> Maybe (SymExpr sym (BaseBVType w)) -> IO (Pred sym))
-> IO (Maybe (SymExpr sym (BaseBVType w)))
-> IO (Maybe (SymExpr sym (BaseBVType w)) -> IO (Pred sym))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> sym
-> NatRepr w
-> ExprEnv sym w
-> IntExpr
-> IO (Maybe (SymExpr sym (BaseBVType w)))
forall (w :: Natural) sym.
(1 <= w, IsSymInterface sym) =>
sym
-> NatRepr w
-> ExprEnv sym w
-> IntExpr
-> IO (Maybe (SymBV sym w))
genIntExpr sym
sym NatRepr w
w ExprEnv sym w
inst IntExpr
x IO (Maybe (SymExpr sym (BaseBVType w)) -> IO (Pred sym))
-> IO (Maybe (SymExpr sym (BaseBVType w))) -> IO (IO (Pred 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
-> ExprEnv sym w
-> IntExpr
-> IO (Maybe (SymExpr sym (BaseBVType w)))
forall (w :: Natural) sym.
(1 <= w, IsSymInterface sym) =>
sym
-> NatRepr w
-> ExprEnv sym w
-> IntExpr
-> IO (Maybe (SymBV sym w))
genIntExpr sym
sym NatRepr w
w ExprEnv sym w
inst IntExpr
y
    And Cond
x Cond
y        -> IO (IO (Pred sym)) -> IO (Pred sym)
forall (m :: Type -> Type) a. Monad m => m (m a) -> m a
join (IO (IO (Pred sym)) -> IO (Pred sym))
-> IO (IO (Pred sym)) -> IO (Pred sym)
forall a b. (a -> b) -> a -> 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 -> Pred sym -> IO (Pred sym))
-> IO (Pred sym) -> IO (Pred sym -> IO (Pred sym))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> sym -> NatRepr w -> ExprEnv sym w -> Cond -> IO (Pred sym)
forall sym (w :: Natural).
(1 <= w, IsSymInterface sym) =>
sym -> NatRepr w -> ExprEnv sym w -> Cond -> IO (Pred sym)
genCondVar sym
sym NatRepr w
w ExprEnv sym w
inst Cond
x IO (Pred sym -> IO (Pred sym))
-> IO (Pred sym) -> IO (IO (Pred 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 -> ExprEnv sym w -> Cond -> IO (Pred sym)
forall sym (w :: Natural).
(1 <= w, IsSymInterface sym) =>
sym -> NatRepr w -> ExprEnv sym w -> Cond -> IO (Pred sym)
genCondVar sym
sym NatRepr w
w ExprEnv sym w
inst Cond
y
    Or Cond
x Cond
y         -> IO (IO (Pred sym)) -> IO (Pred sym)
forall (m :: Type -> Type) a. Monad m => m (m a) -> m a
join (IO (IO (Pred sym)) -> IO (Pred sym))
-> IO (IO (Pred sym)) -> IO (Pred sym)
forall a b. (a -> b) -> a -> 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 -> Pred sym -> IO (Pred sym))
-> IO (Pred sym) -> IO (Pred sym -> IO (Pred sym))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> sym -> NatRepr w -> ExprEnv sym w -> Cond -> IO (Pred sym)
forall sym (w :: Natural).
(1 <= w, IsSymInterface sym) =>
sym -> NatRepr w -> ExprEnv sym w -> Cond -> IO (Pred sym)
genCondVar sym
sym NatRepr w
w ExprEnv sym w
inst Cond
x IO (Pred sym -> IO (Pred sym))
-> IO (Pred sym) -> IO (IO (Pred 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 -> ExprEnv sym w -> Cond -> IO (Pred sym)
forall sym (w :: Natural).
(1 <= w, IsSymInterface sym) =>
sym -> NatRepr w -> ExprEnv sym w -> Cond -> IO (Pred sym)
genCondVar sym
sym NatRepr w
w ExprEnv sym w
inst Cond
y

-- | Compare the equality of two @Maybe SymBV@s
maybeBVEq :: (1 <= w, IsExprBuilder sym)
          => sym -> Maybe (SymBV sym w) -> Maybe (SymBV sym w) -> IO (Pred sym)
maybeBVEq :: forall (w :: Natural) sym.
(1 <= w, IsExprBuilder sym) =>
sym -> Maybe (SymBV sym w) -> Maybe (SymBV sym w) -> IO (Pred sym)
maybeBVEq sym
sym (Just SymBV sym w
x) (Just SymBV sym w
y) = sym -> SymBV sym w -> SymBV sym w -> IO (SymExpr sym BaseBoolType)
forall (w :: Natural).
(1 <= w) =>
sym -> SymBV sym w -> SymBV sym w -> IO (SymExpr sym BaseBoolType)
forall sym (w :: Natural).
(IsExprBuilder sym, 1 <= w) =>
sym -> SymBV sym w -> SymBV sym w -> IO (Pred sym)
bvEq sym
sym SymBV sym w
x SymBV sym w
y
maybeBVEq sym
sym Maybe (SymBV sym w)
Nothing  Maybe (SymBV sym w)
Nothing  = 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 -> IO (SymExpr sym BaseBoolType))
-> SymExpr sym BaseBoolType -> IO (SymExpr sym BaseBoolType)
forall a b. (a -> b) -> a -> b
$ sym -> SymExpr sym BaseBoolType
forall sym. IsExprBuilder sym => sym -> Pred sym
truePred sym
sym
maybeBVEq sym
sym Maybe (SymBV sym w)
_        Maybe (SymBV sym w)
_        = 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 -> IO (SymExpr sym BaseBoolType))
-> SymExpr sym BaseBoolType -> IO (SymExpr sym BaseBoolType)
forall a b. (a -> b) -> a -> b
$ sym -> SymExpr sym BaseBoolType
forall sym. IsExprBuilder sym => sym -> Pred sym
falsePred sym
sym

-- | Compare two @Maybe SymBV@s
maybeBVLe :: (1 <= w, IsExprBuilder sym)
          => sym -> Maybe (SymBV sym w) -> Maybe (SymBV sym w) -> IO (Pred sym)
maybeBVLe :: forall (w :: Natural) sym.
(1 <= w, IsExprBuilder sym) =>
sym -> Maybe (SymBV sym w) -> Maybe (SymBV sym w) -> IO (Pred sym)
maybeBVLe sym
sym (Just SymBV sym w
x) (Just SymBV sym w
y) = sym -> SymBV sym w -> SymBV sym w -> IO (SymExpr sym BaseBoolType)
forall (w :: Natural).
(1 <= w) =>
sym -> SymBV sym w -> SymBV sym w -> IO (SymExpr sym BaseBoolType)
forall sym (w :: Natural).
(IsExprBuilder sym, 1 <= w) =>
sym -> SymBV sym w -> SymBV sym w -> IO (Pred sym)
bvSle sym
sym SymBV sym w
x SymBV sym w
y
maybeBVLe sym
sym Maybe (SymBV sym w)
_        Maybe (SymBV sym w)
Nothing  = 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 -> IO (SymExpr sym BaseBoolType))
-> SymExpr sym BaseBoolType -> IO (SymExpr sym BaseBoolType)
forall a b. (a -> b) -> a -> b
$ sym -> SymExpr sym BaseBoolType
forall sym. IsExprBuilder sym => sym -> Pred sym
truePred sym
sym
maybeBVLe sym
sym Maybe (SymBV sym w)
Nothing  (Just SymBV sym w
_) = 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 -> IO (SymExpr sym BaseBoolType))
-> SymExpr sym BaseBoolType -> IO (SymExpr sym BaseBoolType)
forall a b. (a -> b) -> a -> b
$ sym -> SymExpr sym BaseBoolType
forall sym. IsExprBuilder sym => sym -> Pred sym
falsePred sym
sym

-- | Given a 'ValueCtor' (of partial LLVM values), recursively traverse the
-- 'ValueCtor' to reconstruct the partial value as directed (while respecting
-- endianness)
genValueCtor :: forall sym w.
  (IsSymInterface sym, HasLLVMAnn sym, 1 <= w) =>
  sym ->
  EndianForm ->
  MemoryOp sym w ->
  ValueCtor (PartLLVMVal sym) ->
  IO (PartLLVMVal sym)
genValueCtor :: forall sym (w :: Natural).
(IsSymInterface sym, HasLLVMAnn sym, 1 <= w) =>
sym
-> EndianForm
-> MemoryOp sym w
-> ValueCtor (PartLLVMVal sym)
-> IO (PartLLVMVal sym)
genValueCtor sym
sym EndianForm
end MemoryOp sym w
errCtx ValueCtor (PartLLVMVal sym)
v =
  case ValueCtor (PartLLVMVal sym)
v of
    ValueCtorVar PartLLVMVal sym
x -> PartLLVMVal sym -> IO (PartLLVMVal sym)
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return PartLLVMVal sym
x
    ConcatBV ValueCtor (PartLLVMVal sym)
vcl ValueCtor (PartLLVMVal sym)
vch ->
      do PartLLVMVal sym
vl <- sym
-> EndianForm
-> MemoryOp sym w
-> ValueCtor (PartLLVMVal sym)
-> IO (PartLLVMVal sym)
forall sym (w :: Natural).
(IsSymInterface sym, HasLLVMAnn sym, 1 <= w) =>
sym
-> EndianForm
-> MemoryOp sym w
-> ValueCtor (PartLLVMVal sym)
-> IO (PartLLVMVal sym)
genValueCtor sym
sym EndianForm
end MemoryOp sym w
errCtx ValueCtor (PartLLVMVal sym)
vcl
         PartLLVMVal sym
vh <- sym
-> EndianForm
-> MemoryOp sym w
-> ValueCtor (PartLLVMVal sym)
-> IO (PartLLVMVal sym)
forall sym (w :: Natural).
(IsSymInterface sym, HasLLVMAnn sym, 1 <= w) =>
sym
-> EndianForm
-> MemoryOp sym w
-> ValueCtor (PartLLVMVal sym)
-> IO (PartLLVMVal sym)
genValueCtor sym
sym EndianForm
end MemoryOp sym w
errCtx ValueCtor (PartLLVMVal sym)
vch
         case EndianForm
end of
           EndianForm
BigEndian    -> sym
-> MemoryOp sym w
-> PartLLVMVal sym
-> PartLLVMVal sym
-> IO (PartLLVMVal sym)
forall sym (w :: Natural).
(IsSymInterface sym, HasLLVMAnn sym, 1 <= w) =>
sym
-> MemoryOp sym w
-> PartLLVMVal sym
-> PartLLVMVal sym
-> IO (PartLLVMVal sym)
Partial.bvConcat sym
sym MemoryOp sym w
errCtx PartLLVMVal sym
vh PartLLVMVal sym
vl
           EndianForm
LittleEndian -> sym
-> MemoryOp sym w
-> PartLLVMVal sym
-> PartLLVMVal sym
-> IO (PartLLVMVal sym)
forall sym (w :: Natural).
(IsSymInterface sym, HasLLVMAnn sym, 1 <= w) =>
sym
-> MemoryOp sym w
-> PartLLVMVal sym
-> PartLLVMVal sym
-> IO (PartLLVMVal sym)
Partial.bvConcat sym
sym MemoryOp sym w
errCtx PartLLVMVal sym
vl PartLLVMVal sym
vh
    ConsArray ValueCtor (PartLLVMVal sym)
vc1 ValueCtor (PartLLVMVal sym)
vc2 ->
      do PartLLVMVal sym
lv1 <- sym
-> EndianForm
-> MemoryOp sym w
-> ValueCtor (PartLLVMVal sym)
-> IO (PartLLVMVal sym)
forall sym (w :: Natural).
(IsSymInterface sym, HasLLVMAnn sym, 1 <= w) =>
sym
-> EndianForm
-> MemoryOp sym w
-> ValueCtor (PartLLVMVal sym)
-> IO (PartLLVMVal sym)
genValueCtor sym
sym EndianForm
end MemoryOp sym w
errCtx ValueCtor (PartLLVMVal sym)
vc1
         PartLLVMVal sym
lv2 <- sym
-> EndianForm
-> MemoryOp sym w
-> ValueCtor (PartLLVMVal sym)
-> IO (PartLLVMVal sym)
forall sym (w :: Natural).
(IsSymInterface sym, HasLLVMAnn sym, 1 <= w) =>
sym
-> EndianForm
-> MemoryOp sym w
-> ValueCtor (PartLLVMVal sym)
-> IO (PartLLVMVal sym)
genValueCtor sym
sym EndianForm
end MemoryOp sym w
errCtx ValueCtor (PartLLVMVal sym)
vc2
         sym
-> MemoryOp sym w
-> PartLLVMVal sym
-> PartLLVMVal sym
-> IO (PartLLVMVal sym)
forall sym (w :: Natural).
(IsSymInterface sym, HasLLVMAnn sym, 1 <= w) =>
sym
-> MemoryOp sym w
-> PartLLVMVal sym
-> PartLLVMVal sym
-> IO (PartLLVMVal sym)
Partial.consArray sym
sym MemoryOp sym w
errCtx PartLLVMVal sym
lv1 PartLLVMVal sym
lv2
    AppendArray ValueCtor (PartLLVMVal sym)
vc1 ValueCtor (PartLLVMVal sym)
vc2 ->
      do PartLLVMVal sym
lv1 <- sym
-> EndianForm
-> MemoryOp sym w
-> ValueCtor (PartLLVMVal sym)
-> IO (PartLLVMVal sym)
forall sym (w :: Natural).
(IsSymInterface sym, HasLLVMAnn sym, 1 <= w) =>
sym
-> EndianForm
-> MemoryOp sym w
-> ValueCtor (PartLLVMVal sym)
-> IO (PartLLVMVal sym)
genValueCtor sym
sym EndianForm
end MemoryOp sym w
errCtx ValueCtor (PartLLVMVal sym)
vc1
         PartLLVMVal sym
lv2 <- sym
-> EndianForm
-> MemoryOp sym w
-> ValueCtor (PartLLVMVal sym)
-> IO (PartLLVMVal sym)
forall sym (w :: Natural).
(IsSymInterface sym, HasLLVMAnn sym, 1 <= w) =>
sym
-> EndianForm
-> MemoryOp sym w
-> ValueCtor (PartLLVMVal sym)
-> IO (PartLLVMVal sym)
genValueCtor sym
sym EndianForm
end MemoryOp sym w
errCtx ValueCtor (PartLLVMVal sym)
vc2
         sym
-> MemoryOp sym w
-> PartLLVMVal sym
-> PartLLVMVal sym
-> IO (PartLLVMVal sym)
forall sym (w :: Natural).
(IsSymInterface sym, HasLLVMAnn sym, 1 <= w) =>
sym
-> MemoryOp sym w
-> PartLLVMVal sym
-> PartLLVMVal sym
-> IO (PartLLVMVal sym)
Partial.appendArray sym
sym MemoryOp sym w
errCtx PartLLVMVal sym
lv1 PartLLVMVal sym
lv2
    MkArray StorageType
tp Vector (ValueCtor (PartLLVMVal sym))
vv ->
      sym
-> StorageType -> Vector (PartLLVMVal sym) -> IO (PartLLVMVal sym)
forall sym.
(IsExprBuilder sym, IsSymInterface sym) =>
sym
-> StorageType -> Vector (PartLLVMVal sym) -> IO (PartLLVMVal sym)
Partial.mkArray sym
sym StorageType
tp (Vector (PartLLVMVal sym) -> IO (PartLLVMVal sym))
-> IO (Vector (PartLLVMVal sym)) -> IO (PartLLVMVal sym)
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<<
        (ValueCtor (PartLLVMVal sym) -> IO (PartLLVMVal sym))
-> Vector (ValueCtor (PartLLVMVal sym))
-> IO (Vector (PartLLVMVal 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
-> EndianForm
-> MemoryOp sym w
-> ValueCtor (PartLLVMVal sym)
-> IO (PartLLVMVal sym)
forall sym (w :: Natural).
(IsSymInterface sym, HasLLVMAnn sym, 1 <= w) =>
sym
-> EndianForm
-> MemoryOp sym w
-> ValueCtor (PartLLVMVal sym)
-> IO (PartLLVMVal sym)
genValueCtor sym
sym EndianForm
end MemoryOp sym w
errCtx) Vector (ValueCtor (PartLLVMVal sym))
vv
    MkStruct Vector (Field StorageType, ValueCtor (PartLLVMVal sym))
vv ->
      sym
-> Vector (Field StorageType, PartLLVMVal sym)
-> IO (PartLLVMVal sym)
forall sym.
IsExprBuilder sym =>
sym
-> Vector (Field StorageType, PartLLVMVal sym)
-> IO (PartLLVMVal sym)
Partial.mkStruct sym
sym (Vector (Field StorageType, PartLLVMVal sym)
 -> IO (PartLLVMVal sym))
-> IO (Vector (Field StorageType, PartLLVMVal sym))
-> IO (PartLLVMVal sym)
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<<
        ((Field StorageType, ValueCtor (PartLLVMVal sym))
 -> IO (Field StorageType, PartLLVMVal sym))
-> Vector (Field StorageType, ValueCtor (PartLLVMVal sym))
-> IO (Vector (Field StorageType, PartLLVMVal 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 ((ValueCtor (PartLLVMVal sym) -> IO (PartLLVMVal sym))
-> (Field StorageType, ValueCtor (PartLLVMVal sym))
-> IO (Field StorageType, PartLLVMVal 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) -> (Field StorageType, a) -> f (Field StorageType, b)
traverse (sym
-> EndianForm
-> MemoryOp sym w
-> ValueCtor (PartLLVMVal sym)
-> IO (PartLLVMVal sym)
forall sym (w :: Natural).
(IsSymInterface sym, HasLLVMAnn sym, 1 <= w) =>
sym
-> EndianForm
-> MemoryOp sym w
-> ValueCtor (PartLLVMVal sym)
-> IO (PartLLVMVal sym)
genValueCtor sym
sym EndianForm
end MemoryOp sym w
errCtx)) Vector (Field StorageType, ValueCtor (PartLLVMVal sym))
vv
    BVToFloat ValueCtor (PartLLVMVal sym)
x ->
      sym -> MemoryOp sym w -> PartLLVMVal sym -> IO (PartLLVMVal sym)
forall sym (w :: Natural).
(IsSymInterface sym, HasLLVMAnn sym, 1 <= w) =>
sym -> MemoryOp sym w -> PartLLVMVal sym -> IO (PartLLVMVal sym)
Partial.bvToFloat sym
sym MemoryOp sym w
errCtx (PartLLVMVal sym -> IO (PartLLVMVal sym))
-> IO (PartLLVMVal sym) -> IO (PartLLVMVal sym)
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< sym
-> EndianForm
-> MemoryOp sym w
-> ValueCtor (PartLLVMVal sym)
-> IO (PartLLVMVal sym)
forall sym (w :: Natural).
(IsSymInterface sym, HasLLVMAnn sym, 1 <= w) =>
sym
-> EndianForm
-> MemoryOp sym w
-> ValueCtor (PartLLVMVal sym)
-> IO (PartLLVMVal sym)
genValueCtor sym
sym EndianForm
end MemoryOp sym w
errCtx ValueCtor (PartLLVMVal sym)
x
    BVToDouble ValueCtor (PartLLVMVal sym)
x ->
      sym -> MemoryOp sym w -> PartLLVMVal sym -> IO (PartLLVMVal sym)
forall sym (w :: Natural).
(IsSymInterface sym, HasLLVMAnn sym, 1 <= w) =>
sym -> MemoryOp sym w -> PartLLVMVal sym -> IO (PartLLVMVal sym)
Partial.bvToDouble sym
sym MemoryOp sym w
errCtx (PartLLVMVal sym -> IO (PartLLVMVal sym))
-> IO (PartLLVMVal sym) -> IO (PartLLVMVal sym)
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< sym
-> EndianForm
-> MemoryOp sym w
-> ValueCtor (PartLLVMVal sym)
-> IO (PartLLVMVal sym)
forall sym (w :: Natural).
(IsSymInterface sym, HasLLVMAnn sym, 1 <= w) =>
sym
-> EndianForm
-> MemoryOp sym w
-> ValueCtor (PartLLVMVal sym)
-> IO (PartLLVMVal sym)
genValueCtor sym
sym EndianForm
end MemoryOp sym w
errCtx ValueCtor (PartLLVMVal sym)
x
    BVToX86_FP80 ValueCtor (PartLLVMVal sym)
x ->
      sym -> MemoryOp sym w -> PartLLVMVal sym -> IO (PartLLVMVal sym)
forall sym (w :: Natural).
(IsSymInterface sym, HasLLVMAnn sym, 1 <= w) =>
sym -> MemoryOp sym w -> PartLLVMVal sym -> IO (PartLLVMVal sym)
Partial.bvToX86_FP80 sym
sym MemoryOp sym w
errCtx (PartLLVMVal sym -> IO (PartLLVMVal sym))
-> IO (PartLLVMVal sym) -> IO (PartLLVMVal sym)
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< sym
-> EndianForm
-> MemoryOp sym w
-> ValueCtor (PartLLVMVal sym)
-> IO (PartLLVMVal sym)
forall sym (w :: Natural).
(IsSymInterface sym, HasLLVMAnn sym, 1 <= w) =>
sym
-> EndianForm
-> MemoryOp sym w
-> ValueCtor (PartLLVMVal sym)
-> IO (PartLLVMVal sym)
genValueCtor sym
sym EndianForm
end MemoryOp sym w
errCtx ValueCtor (PartLLVMVal sym)
x

-- | Compute the actual value of a value deconstructor expression.
applyView ::
  (IsSymInterface sym, HasLLVMAnn sym, 1 <= w) =>
  sym ->
  EndianForm ->
  MemErrContext sym w ->
  PartLLVMVal sym ->
  ValueView ->
  IO (PartLLVMVal sym)
applyView :: forall sym (w :: Natural).
(IsSymInterface sym, HasLLVMAnn sym, 1 <= w) =>
sym
-> EndianForm
-> MemErrContext sym w
-> PartLLVMVal sym
-> ValueView
-> IO (PartLLVMVal sym)
applyView sym
sym EndianForm
end MemErrContext sym w
errCtx PartLLVMVal sym
t ValueView
val =
  case ValueView
val of
    ValueViewVar StorageType
_ ->
      PartLLVMVal sym -> IO (PartLLVMVal sym)
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return PartLLVMVal sym
t
    SelectPrefixBV Addr
i Addr
j ValueView
v ->
      do PartLLVMVal sym
t' <- sym
-> EndianForm
-> MemErrContext sym w
-> PartLLVMVal sym
-> ValueView
-> IO (PartLLVMVal sym)
forall sym (w :: Natural).
(IsSymInterface sym, HasLLVMAnn sym, 1 <= w) =>
sym
-> EndianForm
-> MemErrContext sym w
-> PartLLVMVal sym
-> ValueView
-> IO (PartLLVMVal sym)
applyView sym
sym EndianForm
end MemErrContext sym w
errCtx PartLLVMVal sym
t ValueView
v
         case EndianForm
end of
           EndianForm
BigEndian    -> sym
-> MemErrContext sym w
-> Addr
-> Addr
-> PartLLVMVal sym
-> IO (PartLLVMVal sym)
forall sym (w :: Natural).
(IsSymInterface sym, HasLLVMAnn sym, 1 <= w) =>
sym
-> MemoryOp sym w
-> Addr
-> Addr
-> PartLLVMVal sym
-> IO (PartLLVMVal sym)
Partial.selectHighBv sym
sym MemErrContext sym w
errCtx Addr
j Addr
i PartLLVMVal sym
t'
           EndianForm
LittleEndian -> sym
-> MemErrContext sym w
-> Addr
-> Addr
-> PartLLVMVal sym
-> IO (PartLLVMVal sym)
forall sym (w :: Natural).
(IsSymInterface sym, HasLLVMAnn sym, 1 <= w) =>
sym
-> MemoryOp sym w
-> Addr
-> Addr
-> PartLLVMVal sym
-> IO (PartLLVMVal sym)
Partial.selectLowBv sym
sym MemErrContext sym w
errCtx Addr
i Addr
j PartLLVMVal sym
t'
    SelectSuffixBV Addr
i Addr
j ValueView
v ->
      do PartLLVMVal sym
t' <- sym
-> EndianForm
-> MemErrContext sym w
-> PartLLVMVal sym
-> ValueView
-> IO (PartLLVMVal sym)
forall sym (w :: Natural).
(IsSymInterface sym, HasLLVMAnn sym, 1 <= w) =>
sym
-> EndianForm
-> MemErrContext sym w
-> PartLLVMVal sym
-> ValueView
-> IO (PartLLVMVal sym)
applyView sym
sym EndianForm
end MemErrContext sym w
errCtx PartLLVMVal sym
t ValueView
v
         case EndianForm
end of
           EndianForm
BigEndian -> sym
-> MemErrContext sym w
-> Addr
-> Addr
-> PartLLVMVal sym
-> IO (PartLLVMVal sym)
forall sym (w :: Natural).
(IsSymInterface sym, HasLLVMAnn sym, 1 <= w) =>
sym
-> MemoryOp sym w
-> Addr
-> Addr
-> PartLLVMVal sym
-> IO (PartLLVMVal sym)
Partial.selectLowBv sym
sym MemErrContext sym w
errCtx Addr
j Addr
i PartLLVMVal sym
t'
           EndianForm
LittleEndian -> sym
-> MemErrContext sym w
-> Addr
-> Addr
-> PartLLVMVal sym
-> IO (PartLLVMVal sym)
forall sym (w :: Natural).
(IsSymInterface sym, HasLLVMAnn sym, 1 <= w) =>
sym
-> MemoryOp sym w
-> Addr
-> Addr
-> PartLLVMVal sym
-> IO (PartLLVMVal sym)
Partial.selectHighBv sym
sym MemErrContext sym w
errCtx Addr
i Addr
j PartLLVMVal sym
t'
    FloatToBV ValueView
v ->
      sym
-> MemErrContext sym w -> PartLLVMVal sym -> IO (PartLLVMVal sym)
forall sym (w :: Natural).
(IsSymInterface sym, HasLLVMAnn sym, 1 <= w) =>
sym -> MemoryOp sym w -> PartLLVMVal sym -> IO (PartLLVMVal sym)
Partial.floatToBV sym
sym MemErrContext sym w
errCtx (PartLLVMVal sym -> IO (PartLLVMVal sym))
-> IO (PartLLVMVal sym) -> IO (PartLLVMVal sym)
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< sym
-> EndianForm
-> MemErrContext sym w
-> PartLLVMVal sym
-> ValueView
-> IO (PartLLVMVal sym)
forall sym (w :: Natural).
(IsSymInterface sym, HasLLVMAnn sym, 1 <= w) =>
sym
-> EndianForm
-> MemErrContext sym w
-> PartLLVMVal sym
-> ValueView
-> IO (PartLLVMVal sym)
applyView sym
sym EndianForm
end MemErrContext sym w
errCtx PartLLVMVal sym
t ValueView
v
    DoubleToBV ValueView
v ->
      sym
-> MemErrContext sym w -> PartLLVMVal sym -> IO (PartLLVMVal sym)
forall sym (w :: Natural).
(IsSymInterface sym, HasLLVMAnn sym, 1 <= w) =>
sym -> MemoryOp sym w -> PartLLVMVal sym -> IO (PartLLVMVal sym)
Partial.doubleToBV sym
sym MemErrContext sym w
errCtx (PartLLVMVal sym -> IO (PartLLVMVal sym))
-> IO (PartLLVMVal sym) -> IO (PartLLVMVal sym)
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< sym
-> EndianForm
-> MemErrContext sym w
-> PartLLVMVal sym
-> ValueView
-> IO (PartLLVMVal sym)
forall sym (w :: Natural).
(IsSymInterface sym, HasLLVMAnn sym, 1 <= w) =>
sym
-> EndianForm
-> MemErrContext sym w
-> PartLLVMVal sym
-> ValueView
-> IO (PartLLVMVal sym)
applyView sym
sym EndianForm
end MemErrContext sym w
errCtx PartLLVMVal sym
t ValueView
v
    X86_FP80ToBV ValueView
v ->
      sym
-> MemErrContext sym w -> PartLLVMVal sym -> IO (PartLLVMVal sym)
forall sym (w :: Natural).
(IsSymInterface sym, HasLLVMAnn sym, 1 <= w) =>
sym -> MemoryOp sym w -> PartLLVMVal sym -> IO (PartLLVMVal sym)
Partial.fp80ToBV sym
sym MemErrContext sym w
errCtx (PartLLVMVal sym -> IO (PartLLVMVal sym))
-> IO (PartLLVMVal sym) -> IO (PartLLVMVal sym)
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< sym
-> EndianForm
-> MemErrContext sym w
-> PartLLVMVal sym
-> ValueView
-> IO (PartLLVMVal sym)
forall sym (w :: Natural).
(IsSymInterface sym, HasLLVMAnn sym, 1 <= w) =>
sym
-> EndianForm
-> MemErrContext sym w
-> PartLLVMVal sym
-> ValueView
-> IO (PartLLVMVal sym)
applyView sym
sym EndianForm
end MemErrContext sym w
errCtx PartLLVMVal sym
t ValueView
v
    ArrayElt Natural
sz StorageType
tp Natural
idx ValueView
v ->
      sym
-> MemErrContext sym w
-> Natural
-> StorageType
-> Natural
-> PartLLVMVal sym
-> IO (PartLLVMVal sym)
forall sym (w :: Natural).
(IsSymInterface sym, HasLLVMAnn sym, 1 <= w) =>
sym
-> MemoryOp sym w
-> Natural
-> StorageType
-> Natural
-> PartLLVMVal sym
-> IO (PartLLVMVal sym)
Partial.arrayElt sym
sym MemErrContext sym w
errCtx Natural
sz StorageType
tp Natural
idx (PartLLVMVal sym -> IO (PartLLVMVal sym))
-> IO (PartLLVMVal sym) -> IO (PartLLVMVal sym)
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< sym
-> EndianForm
-> MemErrContext sym w
-> PartLLVMVal sym
-> ValueView
-> IO (PartLLVMVal sym)
forall sym (w :: Natural).
(IsSymInterface sym, HasLLVMAnn sym, 1 <= w) =>
sym
-> EndianForm
-> MemErrContext sym w
-> PartLLVMVal sym
-> ValueView
-> IO (PartLLVMVal sym)
applyView sym
sym EndianForm
end MemErrContext sym w
errCtx PartLLVMVal sym
t ValueView
v
    FieldVal Vector (Field StorageType)
flds Int
idx ValueView
v ->
      sym
-> MemErrContext sym w
-> Vector (Field StorageType)
-> Int
-> PartLLVMVal sym
-> IO (PartLLVMVal sym)
forall sym (w :: Natural).
(IsSymInterface sym, HasLLVMAnn sym, 1 <= w) =>
sym
-> MemoryOp sym w
-> Vector (Field StorageType)
-> Int
-> PartLLVMVal sym
-> IO (PartLLVMVal sym)
Partial.fieldVal sym
sym MemErrContext sym w
errCtx Vector (Field StorageType)
flds Int
idx (PartLLVMVal sym -> IO (PartLLVMVal sym))
-> IO (PartLLVMVal sym) -> IO (PartLLVMVal sym)
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< sym
-> EndianForm
-> MemErrContext sym w
-> PartLLVMVal sym
-> ValueView
-> IO (PartLLVMVal sym)
forall sym (w :: Natural).
(IsSymInterface sym, HasLLVMAnn sym, 1 <= w) =>
sym
-> EndianForm
-> MemErrContext sym w
-> PartLLVMVal sym
-> ValueView
-> IO (PartLLVMVal sym)
applyView sym
sym EndianForm
end MemErrContext sym w
errCtx PartLLVMVal sym
t ValueView
v

evalMuxValueCtor ::
  forall u sym w .
  (1 <= w, IsSymInterface sym, HasLLVMAnn sym) =>
  sym ->
  NatRepr w ->
  EndianForm ->
  MemErrContext sym w ->
  ExprEnv sym w {- ^ Evaluation function -} ->
  (u -> ReadMem sym (PartLLVMVal sym)) {- ^ Function for reading specific subranges -} ->
  Mux (ValueCtor u) ->
  ReadMem sym (PartLLVMVal sym)
evalMuxValueCtor :: forall u sym (w :: Natural).
(1 <= w, IsSymInterface sym, HasLLVMAnn sym) =>
sym
-> NatRepr w
-> EndianForm
-> MemErrContext sym w
-> ExprEnv sym w
-> (u -> ReadMem sym (PartLLVMVal sym))
-> Mux (ValueCtor u)
-> ReadMem sym (PartLLVMVal sym)
evalMuxValueCtor sym
sym NatRepr w
_w EndianForm
end MemErrContext sym w
errCtx ExprEnv sym w
_vf u -> ReadMem sym (PartLLVMVal sym)
subFn (MuxVar ValueCtor u
v) =
  do ValueCtor (PartLLVMVal sym)
v' <- (u -> ReadMem sym (PartLLVMVal sym))
-> ValueCtor u -> ReadMem sym (ValueCtor (PartLLVMVal 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) -> ValueCtor a -> f (ValueCtor b)
traverse u -> ReadMem sym (PartLLVMVal sym)
subFn ValueCtor u
v
     IO (PartLLVMVal sym) -> ReadMem sym (PartLLVMVal sym)
forall a. IO a -> ReadMem sym a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (PartLLVMVal sym) -> ReadMem sym (PartLLVMVal sym))
-> IO (PartLLVMVal sym) -> ReadMem sym (PartLLVMVal sym)
forall a b. (a -> b) -> a -> b
$ sym
-> EndianForm
-> MemErrContext sym w
-> ValueCtor (PartLLVMVal sym)
-> IO (PartLLVMVal sym)
forall sym (w :: Natural).
(IsSymInterface sym, HasLLVMAnn sym, 1 <= w) =>
sym
-> EndianForm
-> MemoryOp sym w
-> ValueCtor (PartLLVMVal sym)
-> IO (PartLLVMVal sym)
genValueCtor sym
sym EndianForm
end MemErrContext sym w
errCtx ValueCtor (PartLLVMVal sym)
v'
evalMuxValueCtor sym
sym NatRepr w
w EndianForm
end MemErrContext sym w
errCtx ExprEnv sym w
vf u -> ReadMem sym (PartLLVMVal sym)
subFn (Mux Cond
c Mux (ValueCtor u)
t1 Mux (ValueCtor u)
t2) =
  do SymExpr sym BaseBoolType
c' <- IO (SymExpr sym BaseBoolType)
-> ReadMem sym (SymExpr sym BaseBoolType)
forall a. IO a -> ReadMem sym a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (SymExpr sym BaseBoolType)
 -> ReadMem sym (SymExpr sym BaseBoolType))
-> IO (SymExpr sym BaseBoolType)
-> ReadMem sym (SymExpr sym BaseBoolType)
forall a b. (a -> b) -> a -> b
$ sym
-> NatRepr w
-> ExprEnv sym w
-> Cond
-> IO (SymExpr sym BaseBoolType)
forall sym (w :: Natural).
(1 <= w, IsSymInterface sym) =>
sym -> NatRepr w -> ExprEnv sym w -> Cond -> IO (Pred sym)
genCondVar sym
sym NatRepr w
w ExprEnv sym w
vf Cond
c
     case SymExpr sym BaseBoolType -> Maybe Bool
forall (e :: BaseType -> Type).
IsExpr e =>
e BaseBoolType -> Maybe Bool
asConstantPred SymExpr sym BaseBoolType
c' of
       Just Bool
True  -> sym
-> NatRepr w
-> EndianForm
-> MemErrContext sym w
-> ExprEnv sym w
-> (u -> ReadMem sym (PartLLVMVal sym))
-> Mux (ValueCtor u)
-> ReadMem sym (PartLLVMVal sym)
forall u sym (w :: Natural).
(1 <= w, IsSymInterface sym, HasLLVMAnn sym) =>
sym
-> NatRepr w
-> EndianForm
-> MemErrContext sym w
-> ExprEnv sym w
-> (u -> ReadMem sym (PartLLVMVal sym))
-> Mux (ValueCtor u)
-> ReadMem sym (PartLLVMVal sym)
evalMuxValueCtor sym
sym NatRepr w
w EndianForm
end MemErrContext sym w
errCtx ExprEnv sym w
vf u -> ReadMem sym (PartLLVMVal sym)
subFn Mux (ValueCtor u)
t1
       Just Bool
False -> sym
-> NatRepr w
-> EndianForm
-> MemErrContext sym w
-> ExprEnv sym w
-> (u -> ReadMem sym (PartLLVMVal sym))
-> Mux (ValueCtor u)
-> ReadMem sym (PartLLVMVal sym)
forall u sym (w :: Natural).
(1 <= w, IsSymInterface sym, HasLLVMAnn sym) =>
sym
-> NatRepr w
-> EndianForm
-> MemErrContext sym w
-> ExprEnv sym w
-> (u -> ReadMem sym (PartLLVMVal sym))
-> Mux (ValueCtor u)
-> ReadMem sym (PartLLVMVal sym)
evalMuxValueCtor sym
sym NatRepr w
w EndianForm
end MemErrContext sym w
errCtx ExprEnv sym w
vf u -> ReadMem sym (PartLLVMVal sym)
subFn Mux (ValueCtor u)
t2
       Maybe Bool
Nothing ->
        do PartLLVMVal sym
t1' <- sym
-> NatRepr w
-> EndianForm
-> MemErrContext sym w
-> ExprEnv sym w
-> (u -> ReadMem sym (PartLLVMVal sym))
-> Mux (ValueCtor u)
-> ReadMem sym (PartLLVMVal sym)
forall u sym (w :: Natural).
(1 <= w, IsSymInterface sym, HasLLVMAnn sym) =>
sym
-> NatRepr w
-> EndianForm
-> MemErrContext sym w
-> ExprEnv sym w
-> (u -> ReadMem sym (PartLLVMVal sym))
-> Mux (ValueCtor u)
-> ReadMem sym (PartLLVMVal sym)
evalMuxValueCtor sym
sym NatRepr w
w EndianForm
end MemErrContext sym w
errCtx ExprEnv sym w
vf u -> ReadMem sym (PartLLVMVal sym)
subFn Mux (ValueCtor u)
t1
           PartLLVMVal sym
t2' <- sym
-> NatRepr w
-> EndianForm
-> MemErrContext sym w
-> ExprEnv sym w
-> (u -> ReadMem sym (PartLLVMVal sym))
-> Mux (ValueCtor u)
-> ReadMem sym (PartLLVMVal sym)
forall u sym (w :: Natural).
(1 <= w, IsSymInterface sym, HasLLVMAnn sym) =>
sym
-> NatRepr w
-> EndianForm
-> MemErrContext sym w
-> ExprEnv sym w
-> (u -> ReadMem sym (PartLLVMVal sym))
-> Mux (ValueCtor u)
-> ReadMem sym (PartLLVMVal sym)
evalMuxValueCtor sym
sym NatRepr w
w EndianForm
end MemErrContext sym w
errCtx ExprEnv sym w
vf u -> ReadMem sym (PartLLVMVal sym)
subFn Mux (ValueCtor u)
t2
           IO (PartLLVMVal sym) -> ReadMem sym (PartLLVMVal sym)
forall a. IO a -> ReadMem sym a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (PartLLVMVal sym) -> ReadMem sym (PartLLVMVal sym))
-> IO (PartLLVMVal sym) -> ReadMem sym (PartLLVMVal sym)
forall a b. (a -> b) -> a -> b
$ sym
-> SymExpr sym BaseBoolType
-> PartLLVMVal sym
-> PartLLVMVal sym
-> IO (PartLLVMVal sym)
forall sym.
(IsSymInterface sym, HasLLVMAnn sym) =>
sym
-> Pred sym
-> PartLLVMVal sym
-> PartLLVMVal sym
-> IO (PartLLVMVal sym)
Partial.muxLLVMVal sym
sym SymExpr sym BaseBoolType
c' PartLLVMVal sym
t1' PartLLVMVal sym
t2'

evalMuxValueCtor sym
sym NatRepr w
w EndianForm
end MemErrContext sym w
errCtx ExprEnv sym w
vf u -> ReadMem sym (PartLLVMVal sym)
subFn (MuxTable OffsetExpr
a OffsetExpr
b Map Addr (Mux (ValueCtor u))
m Mux (ValueCtor u)
t) =
  do Map Addr (PartLLVMVal sym)
m' <- (Mux (ValueCtor u) -> ReadMem sym (PartLLVMVal sym))
-> Map Addr (Mux (ValueCtor u))
-> ReadMem sym (Map Addr (PartLLVMVal 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 Addr a -> f (Map Addr b)
traverse (sym
-> NatRepr w
-> EndianForm
-> MemErrContext sym w
-> ExprEnv sym w
-> (u -> ReadMem sym (PartLLVMVal sym))
-> Mux (ValueCtor u)
-> ReadMem sym (PartLLVMVal sym)
forall u sym (w :: Natural).
(1 <= w, IsSymInterface sym, HasLLVMAnn sym) =>
sym
-> NatRepr w
-> EndianForm
-> MemErrContext sym w
-> ExprEnv sym w
-> (u -> ReadMem sym (PartLLVMVal sym))
-> Mux (ValueCtor u)
-> ReadMem sym (PartLLVMVal sym)
evalMuxValueCtor sym
sym NatRepr w
w EndianForm
end MemErrContext sym w
errCtx ExprEnv sym w
vf u -> ReadMem sym (PartLLVMVal sym)
subFn) Map Addr (Mux (ValueCtor u))
m
     PartLLVMVal sym
t' <- sym
-> NatRepr w
-> EndianForm
-> MemErrContext sym w
-> ExprEnv sym w
-> (u -> ReadMem sym (PartLLVMVal sym))
-> Mux (ValueCtor u)
-> ReadMem sym (PartLLVMVal sym)
forall u sym (w :: Natural).
(1 <= w, IsSymInterface sym, HasLLVMAnn sym) =>
sym
-> NatRepr w
-> EndianForm
-> MemErrContext sym w
-> ExprEnv sym w
-> (u -> ReadMem sym (PartLLVMVal sym))
-> Mux (ValueCtor u)
-> ReadMem sym (PartLLVMVal sym)
evalMuxValueCtor sym
sym NatRepr w
w EndianForm
end MemErrContext sym w
errCtx ExprEnv sym w
vf u -> ReadMem sym (PartLLVMVal sym)
subFn Mux (ValueCtor u)
t
     -- TODO: simplification?
     (Addr
 -> PartLLVMVal sym
 -> ReadMem sym (PartLLVMVal sym)
 -> ReadMem sym (PartLLVMVal sym))
-> ReadMem sym (PartLLVMVal sym)
-> Map Addr (PartLLVMVal sym)
-> ReadMem sym (PartLLVMVal sym)
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey Addr
-> PartLLVMVal sym
-> ReadMem sym (PartLLVMVal sym)
-> ReadMem sym (PartLLVMVal sym)
f (PartLLVMVal sym -> ReadMem sym (PartLLVMVal sym)
forall a. a -> ReadMem sym a
forall (m :: Type -> Type) a. Monad m => a -> m a
return PartLLVMVal sym
t') Map Addr (PartLLVMVal sym)
m'
  where
    f :: Bytes -> PartLLVMVal sym -> ReadMem sym (PartLLVMVal sym) -> ReadMem sym (PartLLVMVal sym)
    f :: Addr
-> PartLLVMVal sym
-> ReadMem sym (PartLLVMVal sym)
-> ReadMem sym (PartLLVMVal sym)
f Addr
n PartLLVMVal sym
t1 ReadMem sym (PartLLVMVal sym)
k =
      do SymExpr sym BaseBoolType
c' <- IO (SymExpr sym BaseBoolType)
-> ReadMem sym (SymExpr sym BaseBoolType)
forall a. IO a -> ReadMem sym a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (SymExpr sym BaseBoolType)
 -> ReadMem sym (SymExpr sym BaseBoolType))
-> IO (SymExpr sym BaseBoolType)
-> ReadMem sym (SymExpr sym BaseBoolType)
forall a b. (a -> b) -> a -> b
$ sym
-> NatRepr w
-> ExprEnv sym w
-> Cond
-> IO (SymExpr sym BaseBoolType)
forall sym (w :: Natural).
(1 <= w, IsSymInterface sym) =>
sym -> NatRepr w -> ExprEnv sym w -> Cond -> IO (Pred sym)
genCondVar sym
sym NatRepr w
w ExprEnv sym w
vf (OffsetExpr -> OffsetExpr -> Cond
OffsetEq (Addr -> OffsetExpr
aOffset Addr
n) OffsetExpr
b)
         case SymExpr sym BaseBoolType -> Maybe Bool
forall (e :: BaseType -> Type).
IsExpr e =>
e BaseBoolType -> Maybe Bool
asConstantPred SymExpr sym BaseBoolType
c' of
           Just Bool
True  -> PartLLVMVal sym -> ReadMem sym (PartLLVMVal sym)
forall a. a -> ReadMem sym a
forall (m :: Type -> Type) a. Monad m => a -> m a
return PartLLVMVal sym
t1
           Just Bool
False -> ReadMem sym (PartLLVMVal sym)
k
           Maybe Bool
Nothing    -> IO (PartLLVMVal sym) -> ReadMem sym (PartLLVMVal sym)
forall a. IO a -> ReadMem sym a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (PartLLVMVal sym) -> ReadMem sym (PartLLVMVal sym))
-> (PartLLVMVal sym -> IO (PartLLVMVal sym))
-> PartLLVMVal sym
-> ReadMem sym (PartLLVMVal sym)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. sym
-> SymExpr sym BaseBoolType
-> PartLLVMVal sym
-> PartLLVMVal sym
-> IO (PartLLVMVal sym)
forall sym.
(IsSymInterface sym, HasLLVMAnn sym) =>
sym
-> Pred sym
-> PartLLVMVal sym
-> PartLLVMVal sym
-> IO (PartLLVMVal sym)
Partial.muxLLVMVal sym
sym SymExpr sym BaseBoolType
c' PartLLVMVal sym
t1 (PartLLVMVal sym -> ReadMem sym (PartLLVMVal sym))
-> ReadMem sym (PartLLVMVal sym) -> ReadMem sym (PartLLVMVal sym)
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< ReadMem sym (PartLLVMVal sym)
k

    aOffset :: Bytes -> OffsetExpr
    aOffset :: Addr -> OffsetExpr
aOffset Addr
n = OffsetExpr -> IntExpr -> OffsetExpr
OffsetAdd OffsetExpr
a (Addr -> IntExpr
CValue Addr
n)

-- | Read from a memory with a memcopy to the same block we are reading.
readMemCopy ::
  forall sym w.
  (1 <= w, IsSymInterface sym, HasLLVMAnn sym) =>
  sym ->
  NatRepr w ->
  EndianForm ->
  MemoryOp sym w ->
  LLVMPtr sym w  {- ^ The loaded offset               -} ->
  StorageType    {- ^ The type we are reading         -} ->
  SymBV sym w    {- ^ The destination of the memcopy  -} ->
  LLVMPtr sym w  {- ^ The source of the copied region -} ->
  SymBV sym w    {- ^ The length of the copied region -} ->
  (StorageType -> LLVMPtr sym w -> ReadMem sym (PartLLVMVal sym)) ->
  ReadMem sym (PartLLVMVal sym)
readMemCopy :: forall sym (w :: Natural).
(1 <= w, IsSymInterface sym, HasLLVMAnn sym) =>
sym
-> NatRepr w
-> EndianForm
-> MemoryOp sym w
-> LLVMPtr sym w
-> StorageType
-> SymBV sym w
-> LLVMPtr sym w
-> SymBV sym w
-> (StorageType -> LLVMPtr sym w -> ReadMem sym (PartLLVMVal sym))
-> ReadMem sym (PartLLVMVal sym)
readMemCopy sym
sym NatRepr w
w EndianForm
end MemoryOp sym w
mop (LLVMPointer SymNat sym
blk SymBV sym w
off) StorageType
tp SymBV sym w
d LLVMPtr sym w
src SymBV sym w
sz StorageType -> LLVMPtr sym w -> ReadMem sym (PartLLVMVal sym)
readPrev =
  do let ld :: Maybe Integer
ld = BV w -> Integer
forall (w :: Natural). BV w -> Integer
BV.asUnsigned (BV w -> Integer) -> Maybe (BV w) -> Maybe Integer
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> SymBV sym w -> Maybe (BV w)
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 SymBV sym w
off
     let dd :: Maybe Integer
dd = BV w -> Integer
forall (w :: Natural). BV w -> Integer
BV.asUnsigned (BV w -> Integer) -> Maybe (BV w) -> Maybe Integer
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> SymBV sym w -> Maybe (BV w)
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 SymBV sym w
d
     let varFn :: ExprEnv sym w
varFn = SymBV sym w -> SymBV sym w -> Maybe (SymBV sym w) -> ExprEnv sym w
forall sym (w :: Natural).
SymBV sym w -> SymBV sym w -> Maybe (SymBV sym w) -> ExprEnv sym w
ExprEnv SymBV sym w
off SymBV sym w
d (SymBV sym w -> Maybe (SymBV sym w)
forall a. a -> Maybe a
Just SymBV sym w
sz)

     case (Maybe Integer
ld, Maybe Integer
dd) of
       -- Offset if known
       (Just Integer
lo, Just Integer
so) ->
         do let subFn :: RangeLoad Addr Addr -> ReadMem sym (PartLLVMVal sym)
                subFn :: RangeLoad Addr Addr -> ReadMem sym (PartLLVMVal sym)
subFn (OutOfRange Addr
o StorageType
tp') = do
                  SymBV sym w
o' <- IO (SymBV sym w) -> ReadMem sym (SymBV sym w)
forall a. IO a -> ReadMem sym a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (SymBV sym w) -> ReadMem sym (SymBV sym w))
-> IO (SymBV sym w) -> ReadMem sym (SymBV sym w)
forall a b. (a -> b) -> a -> 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 (NatRepr w -> Addr -> BV w
forall (w :: Natural). NatRepr w -> Addr -> BV w
bytesToBV NatRepr w
w Addr
o)
                  StorageType -> LLVMPtr sym w -> ReadMem sym (PartLLVMVal sym)
readPrev StorageType
tp' (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
o')
                subFn (InRange Addr
o StorageType
tp') =
                  StorageType -> LLVMPtr sym w -> ReadMem sym (PartLLVMVal sym)
readPrev StorageType
tp' (LLVMPointer sym w -> ReadMem sym (PartLLVMVal sym))
-> ReadMem sym (LLVMPointer sym w) -> ReadMem sym (PartLLVMVal sym)
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (LLVMPointer sym w) -> ReadMem sym (LLVMPointer sym w)
forall a. IO a -> ReadMem sym a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (sym -> NatRepr w -> LLVMPtr sym w -> Addr -> IO (LLVMPtr sym w)
forall (w :: Natural) sym.
(1 <= w, IsExprBuilder sym) =>
sym -> NatRepr w -> LLVMPtr sym w -> Addr -> IO (LLVMPtr sym w)
tgAddPtrC sym
sym NatRepr w
w LLVMPtr sym w
src Addr
o)
            case BV w -> Integer
forall (w :: Natural). BV w -> Integer
BV.asUnsigned (BV w -> Integer) -> Maybe (BV w) -> Maybe Integer
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> SymBV sym w -> Maybe (BV w)
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 SymBV sym w
sz of
              Just Integer
csz -> do
                let s :: Range
s = Addr -> Addr -> Range
R (Integer -> Addr
forall a. Num a => Integer -> a
fromInteger Integer
so) (Integer -> Addr
forall a. Num a => Integer -> a
fromInteger (Integer
so Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
csz))
                let vcr :: ValueCtor (RangeLoad Addr Addr)
vcr = Addr -> StorageType -> Range -> ValueCtor (RangeLoad Addr Addr)
rangeLoad (Integer -> Addr
forall a. Num a => Integer -> a
fromInteger Integer
lo) StorageType
tp Range
s
                IO (PartLLVMVal sym) -> ReadMem sym (PartLLVMVal sym)
forall a. IO a -> ReadMem sym a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (PartLLVMVal sym) -> ReadMem sym (PartLLVMVal sym))
-> (ValueCtor (PartLLVMVal sym) -> IO (PartLLVMVal sym))
-> ValueCtor (PartLLVMVal sym)
-> ReadMem sym (PartLLVMVal sym)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. sym
-> EndianForm
-> MemoryOp sym w
-> ValueCtor (PartLLVMVal sym)
-> IO (PartLLVMVal sym)
forall sym (w :: Natural).
(IsSymInterface sym, HasLLVMAnn sym, 1 <= w) =>
sym
-> EndianForm
-> MemoryOp sym w
-> ValueCtor (PartLLVMVal sym)
-> IO (PartLLVMVal sym)
genValueCtor sym
sym EndianForm
end MemoryOp sym w
mop (ValueCtor (PartLLVMVal sym) -> ReadMem sym (PartLLVMVal sym))
-> ReadMem sym (ValueCtor (PartLLVMVal sym))
-> ReadMem sym (PartLLVMVal sym)
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< (RangeLoad Addr Addr -> ReadMem sym (PartLLVMVal sym))
-> ValueCtor (RangeLoad Addr Addr)
-> ReadMem sym (ValueCtor (PartLLVMVal 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) -> ValueCtor a -> f (ValueCtor b)
traverse RangeLoad Addr Addr -> ReadMem sym (PartLLVMVal sym)
subFn ValueCtor (RangeLoad Addr Addr)
vcr
              Maybe Integer
_ ->
                sym
-> NatRepr w
-> EndianForm
-> MemoryOp sym w
-> ExprEnv sym w
-> (RangeLoad Addr Addr -> ReadMem sym (PartLLVMVal sym))
-> Mux (ValueCtor (RangeLoad Addr Addr))
-> ReadMem sym (PartLLVMVal sym)
forall u sym (w :: Natural).
(1 <= w, IsSymInterface sym, HasLLVMAnn sym) =>
sym
-> NatRepr w
-> EndianForm
-> MemErrContext sym w
-> ExprEnv sym w
-> (u -> ReadMem sym (PartLLVMVal sym))
-> Mux (ValueCtor u)
-> ReadMem sym (PartLLVMVal sym)
evalMuxValueCtor sym
sym NatRepr w
w EndianForm
end MemoryOp sym w
mop ExprEnv sym w
varFn RangeLoad Addr Addr -> ReadMem sym (PartLLVMVal sym)
subFn (Mux (ValueCtor (RangeLoad Addr Addr))
 -> ReadMem sym (PartLLVMVal sym))
-> Mux (ValueCtor (RangeLoad Addr Addr))
-> ReadMem sym (PartLLVMVal sym)
forall a b. (a -> b) -> a -> b
$
                  Addr
-> StorageType -> Addr -> Mux (ValueCtor (RangeLoad Addr Addr))
fixedOffsetRangeLoad (Integer -> Addr
forall a. Num a => Integer -> a
fromInteger Integer
lo) StorageType
tp (Integer -> Addr
forall a. Num a => Integer -> a
fromInteger Integer
so)
         -- Symbolic offsets
       (Maybe Integer, Maybe Integer)
_ ->
         do let subFn :: RangeLoad OffsetExpr IntExpr -> ReadMem sym (PartLLVMVal sym)
                subFn :: RangeLoad OffsetExpr IntExpr -> ReadMem sym (PartLLVMVal sym)
subFn (OutOfRange OffsetExpr
o StorageType
tp') =
                  do SymBV sym w
o' <- IO (SymBV sym w) -> ReadMem sym (SymBV sym w)
forall a. IO a -> ReadMem sym a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (SymBV sym w) -> ReadMem sym (SymBV sym w))
-> IO (SymBV sym w) -> ReadMem sym (SymBV sym w)
forall a b. (a -> b) -> a -> b
$ sym -> NatRepr w -> ExprEnv sym w -> OffsetExpr -> IO (SymBV sym w)
forall (w :: Natural) sym.
(1 <= w, IsSymInterface sym) =>
sym -> NatRepr w -> ExprEnv sym w -> OffsetExpr -> IO (SymBV sym w)
genOffsetExpr sym
sym NatRepr w
w ExprEnv sym w
varFn OffsetExpr
o
                     StorageType -> LLVMPtr sym w -> ReadMem sym (PartLLVMVal sym)
readPrev StorageType
tp' (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
o')
                subFn (InRange IntExpr
o StorageType
tp') = do
                  Maybe (SymBV sym w)
oExpr <- IO (Maybe (SymBV sym w)) -> ReadMem sym (Maybe (SymBV sym w))
forall a. IO a -> ReadMem sym a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (SymBV sym w)) -> ReadMem sym (Maybe (SymBV sym w)))
-> IO (Maybe (SymBV sym w)) -> ReadMem sym (Maybe (SymBV sym w))
forall a b. (a -> b) -> a -> b
$ sym
-> NatRepr w
-> ExprEnv sym w
-> IntExpr
-> IO (Maybe (SymBV sym w))
forall (w :: Natural) sym.
(1 <= w, IsSymInterface sym) =>
sym
-> NatRepr w
-> ExprEnv sym w
-> IntExpr
-> IO (Maybe (SymBV sym w))
genIntExpr sym
sym NatRepr w
w ExprEnv sym w
varFn IntExpr
o
                  LLVMPointer sym w
srcPlusO <- case Maybe (SymBV sym w)
oExpr of
                                Just SymBV sym w
oExpr' -> IO (LLVMPointer sym w) -> ReadMem sym (LLVMPointer sym w)
forall a. IO a -> ReadMem sym a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (LLVMPointer sym w) -> ReadMem sym (LLVMPointer sym w))
-> IO (LLVMPointer sym w) -> ReadMem sym (LLVMPointer sym w)
forall a b. (a -> b) -> a -> b
$ sym
-> NatRepr w -> LLVMPtr sym w -> SymBV sym w -> IO (LLVMPtr sym w)
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 w
w LLVMPtr sym w
src SymBV sym w
oExpr'
                                Maybe (SymBV sym w)
Nothing     -> [Char] -> [[Char]] -> ReadMem sym (LLVMPointer sym w)
forall a. HasCallStack => [Char] -> [[Char]] -> a
panic [Char]
"Generic.readMemCopy"
                                                [[Char]
"Cannot use an unbounded bitvector expression as an offset"
                                                ,[Char]
"*** In offset epxression:  " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ IntExpr -> [Char]
forall a. Show a => a -> [Char]
show IntExpr
o
                                                ,[Char]
"*** Under environment:  " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Doc Any -> [Char]
forall a. Show a => a -> [Char]
show (ExprEnv sym w -> Doc Any
forall sym (w :: Natural) ann.
IsExprBuilder sym =>
ExprEnv sym w -> Doc ann
ppExprEnv ExprEnv sym w
varFn)
                                                ]
                  StorageType -> LLVMPtr sym w -> ReadMem sym (PartLLVMVal sym)
readPrev StorageType
tp' LLVMPtr sym w
LLVMPointer sym w
srcPlusO
            let pref :: BasePreference
pref | Just{} <- Maybe Integer
dd = BasePreference
FixedStore
                     | Just{} <- Maybe Integer
ld = BasePreference
FixedLoad
                     | Bool
otherwise = BasePreference
NeitherFixed
            let mux0 :: Mux (ValueCtor (RangeLoad OffsetExpr IntExpr))
mux0 | Just Integer
csz <- BV w -> Integer
forall (w :: Natural). BV w -> Integer
BV.asUnsigned (BV w -> Integer) -> Maybe (BV w) -> Maybe Integer
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> SymBV sym w -> Maybe (BV w)
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 SymBV sym w
sz =
                         BasePreference
-> StorageType
-> Addr
-> Mux (ValueCtor (RangeLoad OffsetExpr IntExpr))
fixedSizeRangeLoad BasePreference
pref StorageType
tp (Integer -> Addr
forall a. Num a => Integer -> a
fromInteger Integer
csz)
                     | Bool
otherwise =
                         BasePreference
-> StorageType -> Mux (ValueCtor (RangeLoad OffsetExpr IntExpr))
symbolicRangeLoad BasePreference
pref StorageType
tp
            sym
-> NatRepr w
-> EndianForm
-> MemoryOp sym w
-> ExprEnv sym w
-> (RangeLoad OffsetExpr IntExpr -> ReadMem sym (PartLLVMVal sym))
-> Mux (ValueCtor (RangeLoad OffsetExpr IntExpr))
-> ReadMem sym (PartLLVMVal sym)
forall u sym (w :: Natural).
(1 <= w, IsSymInterface sym, HasLLVMAnn sym) =>
sym
-> NatRepr w
-> EndianForm
-> MemErrContext sym w
-> ExprEnv sym w
-> (u -> ReadMem sym (PartLLVMVal sym))
-> Mux (ValueCtor u)
-> ReadMem sym (PartLLVMVal sym)
evalMuxValueCtor sym
sym NatRepr w
w EndianForm
end MemoryOp sym w
mop ExprEnv sym w
varFn RangeLoad OffsetExpr IntExpr -> ReadMem sym (PartLLVMVal sym)
subFn Mux (ValueCtor (RangeLoad OffsetExpr IntExpr))
mux0

readMemSet ::
  forall sym w .
  (1 <= w, IsSymInterface sym, HasLLVMAnn sym) =>
  sym ->
  NatRepr w ->
  EndianForm ->
  MemoryOp sym w ->
  LLVMPtr sym w {- ^ The loaded offset             -} ->
  StorageType   {- ^ The type we are reading       -} ->
  SymBV sym w   {- ^ The destination of the memset -} ->
  SymBV sym 8   {- ^ The fill byte that was set    -} ->
  SymBV sym w   {- ^ The length of the set region  -} ->
  (StorageType -> LLVMPtr sym w -> ReadMem sym (PartLLVMVal sym)) ->
  ReadMem sym (PartLLVMVal sym)
readMemSet :: forall sym (w :: Natural).
(1 <= w, IsSymInterface sym, HasLLVMAnn sym) =>
sym
-> NatRepr w
-> EndianForm
-> MemoryOp sym w
-> LLVMPtr sym w
-> StorageType
-> SymBV sym w
-> SymBV sym 8
-> SymBV sym w
-> (StorageType -> LLVMPtr sym w -> ReadMem sym (PartLLVMVal sym))
-> ReadMem sym (PartLLVMVal sym)
readMemSet sym
sym NatRepr w
w EndianForm
end MemoryOp sym w
mop (LLVMPointer SymNat sym
blk SymBV sym w
off) StorageType
tp SymBV sym w
d SymBV sym 8
byte SymBV sym w
sz StorageType -> LLVMPtr sym w -> ReadMem sym (PartLLVMVal sym)
readPrev =
  do let ld :: Maybe Integer
ld = BV w -> Integer
forall (w :: Natural). BV w -> Integer
BV.asUnsigned (BV w -> Integer) -> Maybe (BV w) -> Maybe Integer
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> SymBV sym w -> Maybe (BV w)
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 SymBV sym w
off
     let dd :: Maybe Integer
dd = BV w -> Integer
forall (w :: Natural). BV w -> Integer
BV.asUnsigned (BV w -> Integer) -> Maybe (BV w) -> Maybe Integer
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> SymBV sym w -> Maybe (BV w)
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 SymBV sym w
d
     let varFn :: ExprEnv sym w
varFn = SymBV sym w -> SymBV sym w -> Maybe (SymBV sym w) -> ExprEnv sym w
forall sym (w :: Natural).
SymBV sym w -> SymBV sym w -> Maybe (SymBV sym w) -> ExprEnv sym w
ExprEnv SymBV sym w
off SymBV sym w
d (SymBV sym w -> Maybe (SymBV sym w)
forall a. a -> Maybe a
Just SymBV sym w
sz)
     case (Maybe Integer
ld, Maybe Integer
dd) of
       -- Offset if known
       (Just Integer
lo, Just Integer
so) ->
         do let subFn :: RangeLoad Addr Addr -> ReadMem sym (PartLLVMVal sym)
                subFn :: RangeLoad Addr Addr -> ReadMem sym (PartLLVMVal sym)
subFn (OutOfRange Addr
o StorageType
tp') = do
                  SymBV sym w
o' <- IO (SymBV sym w) -> ReadMem sym (SymBV sym w)
forall a. IO a -> ReadMem sym a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (SymBV sym w) -> ReadMem sym (SymBV sym w))
-> IO (SymBV sym w) -> ReadMem sym (SymBV sym w)
forall a b. (a -> b) -> a -> 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 (NatRepr w -> Addr -> BV w
forall (w :: Natural). NatRepr w -> Addr -> BV w
bytesToBV NatRepr w
w Addr
o)
                  StorageType -> LLVMPtr sym w -> ReadMem sym (PartLLVMVal sym)
readPrev StorageType
tp' (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
o')
                subFn (InRange   Addr
_o StorageType
tp') = do
                  SymNat sym
blk0 <- IO (SymNat sym) -> ReadMem sym (SymNat sym)
forall a. IO a -> ReadMem sym a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (SymNat sym) -> ReadMem sym (SymNat sym))
-> IO (SymNat sym) -> ReadMem sym (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
0
                  let val :: LLVMVal sym
val = SymNat sym -> SymBV sym 8 -> LLVMVal sym
forall (w :: Natural) sym.
(1 <= w) =>
SymNat sym -> SymBV sym w -> LLVMVal sym
LLVMValInt SymNat sym
blk0 SymBV sym 8
byte
                  let b :: PartLLVMVal sym
b   = sym -> LLVMVal sym -> PartLLVMVal sym
forall sym.
IsExprBuilder sym =>
sym -> LLVMVal sym -> PartLLVMVal sym
Partial.totalLLVMVal sym
sym LLVMVal sym
val
                  IO (PartLLVMVal sym) -> ReadMem sym (PartLLVMVal sym)
forall a. IO a -> ReadMem sym a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (PartLLVMVal sym) -> ReadMem sym (PartLLVMVal sym))
-> IO (PartLLVMVal sym) -> ReadMem sym (PartLLVMVal sym)
forall a b. (a -> b) -> a -> b
$ sym
-> EndianForm
-> MemoryOp sym w
-> ValueCtor (PartLLVMVal sym)
-> IO (PartLLVMVal sym)
forall sym (w :: Natural).
(IsSymInterface sym, HasLLVMAnn sym, 1 <= w) =>
sym
-> EndianForm
-> MemoryOp sym w
-> ValueCtor (PartLLVMVal sym)
-> IO (PartLLVMVal sym)
genValueCtor sym
sym EndianForm
end MemoryOp sym w
mop (PartLLVMVal sym -> StorageType -> ValueCtor (PartLLVMVal sym)
forall a. a -> StorageType -> ValueCtor a
memsetValue PartLLVMVal sym
b StorageType
tp')
            case BV w -> Integer
forall (w :: Natural). BV w -> Integer
BV.asUnsigned (BV w -> Integer) -> Maybe (BV w) -> Maybe Integer
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> SymBV sym w -> Maybe (BV w)
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 SymBV sym w
sz of
              Just Integer
csz -> do
                let s :: Range
s = Addr -> Addr -> Range
R (Integer -> Addr
forall a. Num a => Integer -> a
fromInteger Integer
so) (Integer -> Addr
forall a. Num a => Integer -> a
fromInteger (Integer
so Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
csz))
                let vcr :: ValueCtor (RangeLoad Addr Addr)
vcr = Addr -> StorageType -> Range -> ValueCtor (RangeLoad Addr Addr)
rangeLoad (Integer -> Addr
forall a. Num a => Integer -> a
fromInteger Integer
lo) StorageType
tp Range
s
                IO (PartLLVMVal sym) -> ReadMem sym (PartLLVMVal sym)
forall a. IO a -> ReadMem sym a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (PartLLVMVal sym) -> ReadMem sym (PartLLVMVal sym))
-> (ValueCtor (PartLLVMVal sym) -> IO (PartLLVMVal sym))
-> ValueCtor (PartLLVMVal sym)
-> ReadMem sym (PartLLVMVal sym)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. sym
-> EndianForm
-> MemoryOp sym w
-> ValueCtor (PartLLVMVal sym)
-> IO (PartLLVMVal sym)
forall sym (w :: Natural).
(IsSymInterface sym, HasLLVMAnn sym, 1 <= w) =>
sym
-> EndianForm
-> MemoryOp sym w
-> ValueCtor (PartLLVMVal sym)
-> IO (PartLLVMVal sym)
genValueCtor sym
sym EndianForm
end MemoryOp sym w
mop (ValueCtor (PartLLVMVal sym) -> ReadMem sym (PartLLVMVal sym))
-> ReadMem sym (ValueCtor (PartLLVMVal sym))
-> ReadMem sym (PartLLVMVal sym)
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< (RangeLoad Addr Addr -> ReadMem sym (PartLLVMVal sym))
-> ValueCtor (RangeLoad Addr Addr)
-> ReadMem sym (ValueCtor (PartLLVMVal 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) -> ValueCtor a -> f (ValueCtor b)
traverse RangeLoad Addr Addr -> ReadMem sym (PartLLVMVal sym)
subFn ValueCtor (RangeLoad Addr Addr)
vcr
              Maybe Integer
_ -> sym
-> NatRepr w
-> EndianForm
-> MemoryOp sym w
-> ExprEnv sym w
-> (RangeLoad Addr Addr -> ReadMem sym (PartLLVMVal sym))
-> Mux (ValueCtor (RangeLoad Addr Addr))
-> ReadMem sym (PartLLVMVal sym)
forall u sym (w :: Natural).
(1 <= w, IsSymInterface sym, HasLLVMAnn sym) =>
sym
-> NatRepr w
-> EndianForm
-> MemErrContext sym w
-> ExprEnv sym w
-> (u -> ReadMem sym (PartLLVMVal sym))
-> Mux (ValueCtor u)
-> ReadMem sym (PartLLVMVal sym)
evalMuxValueCtor sym
sym NatRepr w
w EndianForm
end MemoryOp sym w
mop ExprEnv sym w
varFn RangeLoad Addr Addr -> ReadMem sym (PartLLVMVal sym)
subFn (Mux (ValueCtor (RangeLoad Addr Addr))
 -> ReadMem sym (PartLLVMVal sym))
-> Mux (ValueCtor (RangeLoad Addr Addr))
-> ReadMem sym (PartLLVMVal sym)
forall a b. (a -> b) -> a -> b
$
                     Addr
-> StorageType -> Addr -> Mux (ValueCtor (RangeLoad Addr Addr))
fixedOffsetRangeLoad (Integer -> Addr
forall a. Num a => Integer -> a
fromInteger Integer
lo) StorageType
tp (Integer -> Addr
forall a. Num a => Integer -> a
fromInteger Integer
so)
       -- Symbolic offsets
       (Maybe Integer, Maybe Integer)
_ ->
         do let subFn :: RangeLoad OffsetExpr IntExpr -> ReadMem sym (PartLLVMVal sym)
                subFn :: RangeLoad OffsetExpr IntExpr -> ReadMem sym (PartLLVMVal sym)
subFn (OutOfRange OffsetExpr
o StorageType
tp') =
                  do SymBV sym w
o' <- IO (SymBV sym w) -> ReadMem sym (SymBV sym w)
forall a. IO a -> ReadMem sym a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (SymBV sym w) -> ReadMem sym (SymBV sym w))
-> IO (SymBV sym w) -> ReadMem sym (SymBV sym w)
forall a b. (a -> b) -> a -> b
$ sym -> NatRepr w -> ExprEnv sym w -> OffsetExpr -> IO (SymBV sym w)
forall (w :: Natural) sym.
(1 <= w, IsSymInterface sym) =>
sym -> NatRepr w -> ExprEnv sym w -> OffsetExpr -> IO (SymBV sym w)
genOffsetExpr sym
sym NatRepr w
w ExprEnv sym w
varFn OffsetExpr
o
                     StorageType -> LLVMPtr sym w -> ReadMem sym (PartLLVMVal sym)
readPrev StorageType
tp' (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
o')
                subFn (InRange IntExpr
_o StorageType
tp') = IO (PartLLVMVal sym) -> ReadMem sym (PartLLVMVal sym)
forall a. IO a -> ReadMem sym a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (PartLLVMVal sym) -> ReadMem sym (PartLLVMVal sym))
-> IO (PartLLVMVal sym) -> ReadMem sym (PartLLVMVal sym)
forall a b. (a -> b) -> a -> b
$
                  do SymNat sym
blk0 <- sym -> Natural -> IO (SymNat sym)
forall sym. IsExprBuilder sym => sym -> Natural -> IO (SymNat sym)
natLit sym
sym Natural
0
                     let val :: LLVMVal sym
val = SymNat sym -> SymBV sym 8 -> LLVMVal sym
forall (w :: Natural) sym.
(1 <= w) =>
SymNat sym -> SymBV sym w -> LLVMVal sym
LLVMValInt SymNat sym
blk0 SymBV sym 8
byte
                     let b :: PartLLVMVal sym
b = sym -> LLVMVal sym -> PartLLVMVal sym
forall sym.
IsExprBuilder sym =>
sym -> LLVMVal sym -> PartLLVMVal sym
Partial.totalLLVMVal sym
sym LLVMVal sym
val
                     sym
-> EndianForm
-> MemoryOp sym w
-> ValueCtor (PartLLVMVal sym)
-> IO (PartLLVMVal sym)
forall sym (w :: Natural).
(IsSymInterface sym, HasLLVMAnn sym, 1 <= w) =>
sym
-> EndianForm
-> MemoryOp sym w
-> ValueCtor (PartLLVMVal sym)
-> IO (PartLLVMVal sym)
genValueCtor sym
sym EndianForm
end MemoryOp sym w
mop (PartLLVMVal sym -> StorageType -> ValueCtor (PartLLVMVal sym)
forall a. a -> StorageType -> ValueCtor a
memsetValue PartLLVMVal sym
b StorageType
tp')
            let pref :: BasePreference
pref | Just{} <- Maybe Integer
dd = BasePreference
FixedStore
                     | Just{} <- Maybe Integer
ld = BasePreference
FixedLoad
                     | Bool
otherwise = BasePreference
NeitherFixed
            let mux0 :: Mux (ValueCtor (RangeLoad OffsetExpr IntExpr))
mux0 | Just Integer
csz <- BV w -> Integer
forall (w :: Natural). BV w -> Integer
BV.asUnsigned (BV w -> Integer) -> Maybe (BV w) -> Maybe Integer
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> SymBV sym w -> Maybe (BV w)
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 SymBV sym w
sz =
                         BasePreference
-> StorageType
-> Addr
-> Mux (ValueCtor (RangeLoad OffsetExpr IntExpr))
fixedSizeRangeLoad BasePreference
pref StorageType
tp (Integer -> Addr
forall a. Num a => Integer -> a
fromInteger Integer
csz)
                     | Bool
otherwise =
                         BasePreference
-> StorageType -> Mux (ValueCtor (RangeLoad OffsetExpr IntExpr))
symbolicRangeLoad BasePreference
pref StorageType
tp
            sym
-> NatRepr w
-> EndianForm
-> MemoryOp sym w
-> ExprEnv sym w
-> (RangeLoad OffsetExpr IntExpr -> ReadMem sym (PartLLVMVal sym))
-> Mux (ValueCtor (RangeLoad OffsetExpr IntExpr))
-> ReadMem sym (PartLLVMVal sym)
forall u sym (w :: Natural).
(1 <= w, IsSymInterface sym, HasLLVMAnn sym) =>
sym
-> NatRepr w
-> EndianForm
-> MemErrContext sym w
-> ExprEnv sym w
-> (u -> ReadMem sym (PartLLVMVal sym))
-> Mux (ValueCtor u)
-> ReadMem sym (PartLLVMVal sym)
evalMuxValueCtor sym
sym NatRepr w
w EndianForm
end MemoryOp sym w
mop ExprEnv sym w
varFn RangeLoad OffsetExpr IntExpr -> ReadMem sym (PartLLVMVal sym)
subFn Mux (ValueCtor (RangeLoad OffsetExpr IntExpr))
mux0

-- | Read from a memory with a store to the same block we are reading.
readMemStore ::
  forall sym w.
  (1 <= w, IsSymInterface sym, HasLLVMAnn sym) =>
  sym ->
  NatRepr w ->
  EndianForm ->
  MemoryOp sym w ->
  LLVMPtr sym w {- ^ The loaded address                 -} ->
  StorageType   {- ^ The type we are reading            -} ->
  SymBV sym w   {- ^ The destination of the store       -} ->
  LLVMVal sym   {- ^ The value that was stored          -} ->
  StorageType   {- ^ The type of value that was written -} ->
  Alignment     {- ^ The alignment of the pointer we are reading from -} ->
  Alignment     {- ^ The alignment of the store from which we are reading -} ->
  (StorageType -> LLVMPtr sym w -> ReadMem sym (PartLLVMVal sym))
  {- ^ A callback function for when reading fails -} ->
  ReadMem sym (PartLLVMVal sym)
readMemStore :: forall sym (w :: Natural).
(1 <= w, IsSymInterface sym, HasLLVMAnn sym) =>
sym
-> NatRepr w
-> EndianForm
-> MemoryOp sym w
-> LLVMPtr sym w
-> StorageType
-> SymBV sym w
-> LLVMVal sym
-> StorageType
-> Alignment
-> Alignment
-> (StorageType -> LLVMPtr sym w -> ReadMem sym (PartLLVMVal sym))
-> ReadMem sym (PartLLVMVal sym)
readMemStore sym
sym NatRepr w
w EndianForm
end MemoryOp sym w
mop (LLVMPointer SymNat sym
blk SymBV sym w
off) StorageType
ltp SymBV sym w
d LLVMVal sym
t StorageType
stp Alignment
loadAlign Alignment
storeAlign StorageType -> LLVMPtr sym w -> ReadMem sym (PartLLVMVal sym)
readPrev =
  do SymBV sym w
ssz <- IO (SymBV sym w) -> ReadMem sym (SymBV sym w)
forall a. IO a -> ReadMem sym a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (SymBV sym w) -> ReadMem sym (SymBV sym w))
-> IO (SymBV sym w) -> ReadMem sym (SymBV sym w)
forall a b. (a -> b) -> a -> 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 (NatRepr w -> Addr -> BV w
forall (w :: Natural). NatRepr w -> Addr -> BV w
bytesToBV NatRepr w
w (StorageType -> Addr
storageTypeSize StorageType
stp))
     let varFn :: ExprEnv sym w
varFn = SymBV sym w -> SymBV sym w -> Maybe (SymBV sym w) -> ExprEnv sym w
forall sym (w :: Natural).
SymBV sym w -> SymBV sym w -> Maybe (SymBV sym w) -> ExprEnv sym w
ExprEnv SymBV sym w
off SymBV sym w
d (SymBV sym w -> Maybe (SymBV sym w)
forall a. a -> Maybe a
Just SymBV sym w
ssz)
     let ld :: Maybe Integer
ld = BV w -> Integer
forall (w :: Natural). BV w -> Integer
BV.asUnsigned (BV w -> Integer) -> Maybe (BV w) -> Maybe Integer
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> SymBV sym w -> Maybe (BV w)
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 SymBV sym w
off
     let dd :: Maybe Integer
dd = BV w -> Integer
forall (w :: Natural). BV w -> Integer
BV.asUnsigned (BV w -> Integer) -> Maybe (BV w) -> Maybe Integer
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> SymBV sym w -> Maybe (BV w)
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 SymBV sym w
d
     case (Maybe Integer
ld, Maybe Integer
dd) of
       -- Offset if known
       (Just Integer
lo, Just Integer
so) ->
         do let subFn :: ValueLoad Addr -> ReadMem sym (PartLLVMVal sym)
                subFn :: ValueLoad Addr -> ReadMem sym (PartLLVMVal sym)
subFn (OldMemory Addr
o StorageType
tp')  =
                  StorageType -> LLVMPtr sym w -> ReadMem sym (PartLLVMVal sym)
readPrev StorageType
tp' (LLVMPointer sym w -> ReadMem sym (PartLLVMVal sym))
-> (SymBV sym w -> LLVMPointer sym w)
-> SymBV sym w
-> ReadMem sym (PartLLVMVal sym)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 -> ReadMem sym (PartLLVMVal sym))
-> ReadMem sym (SymBV sym w) -> ReadMem sym (PartLLVMVal sym)
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<<
                    IO (SymBV sym w) -> ReadMem sym (SymBV sym w)
forall a. IO a -> ReadMem sym a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (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 (NatRepr w -> Addr -> BV w
forall (w :: Natural). NatRepr w -> Addr -> BV w
bytesToBV NatRepr w
w Addr
o))
                subFn (LastStore ValueView
v)      = IO (PartLLVMVal sym) -> ReadMem sym (PartLLVMVal sym)
forall a. IO a -> ReadMem sym a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (PartLLVMVal sym) -> ReadMem sym (PartLLVMVal sym))
-> IO (PartLLVMVal sym) -> ReadMem sym (PartLLVMVal sym)
forall a b. (a -> b) -> a -> b
$
                  sym
-> EndianForm
-> MemoryOp sym w
-> PartLLVMVal sym
-> ValueView
-> IO (PartLLVMVal sym)
forall sym (w :: Natural).
(IsSymInterface sym, HasLLVMAnn sym, 1 <= w) =>
sym
-> EndianForm
-> MemErrContext sym w
-> PartLLVMVal sym
-> ValueView
-> IO (PartLLVMVal sym)
applyView sym
sym EndianForm
end MemoryOp sym w
mop (sym -> LLVMVal sym -> PartLLVMVal sym
forall sym.
IsExprBuilder sym =>
sym -> LLVMVal sym -> PartLLVMVal sym
Partial.totalLLVMVal sym
sym LLVMVal sym
t) ValueView
v
                subFn (InvalidMemory StorageType
tp) = IO (PartLLVMVal sym) -> ReadMem sym (PartLLVMVal sym)
forall a. IO a -> ReadMem sym a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (sym -> MemoryOp sym w -> MemoryErrorReason -> IO (PartLLVMVal sym)
forall sym (w :: Natural).
(IsSymInterface sym, HasLLVMAnn sym, 1 <= w) =>
sym -> MemoryOp sym w -> MemoryErrorReason -> IO (PartLLVMVal sym)
Partial.partErr sym
sym MemoryOp sym w
mop (MemoryErrorReason -> IO (PartLLVMVal sym))
-> MemoryErrorReason -> IO (PartLLVMVal sym)
forall a b. (a -> b) -> a -> b
$ StorageType -> MemoryErrorReason
Invalid StorageType
tp)
            let vcr :: ValueCtor (ValueLoad Addr)
vcr = Addr
-> StorageType -> Addr -> ValueView -> ValueCtor (ValueLoad Addr)
valueLoad (Integer -> Addr
forall a. Num a => Integer -> a
fromInteger Integer
lo) StorageType
ltp (Integer -> Addr
forall a. Num a => Integer -> a
fromInteger Integer
so) (StorageType -> ValueView
ValueViewVar StorageType
stp)
            IO (PartLLVMVal sym) -> ReadMem sym (PartLLVMVal sym)
forall a. IO a -> ReadMem sym a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (PartLLVMVal sym) -> ReadMem sym (PartLLVMVal sym))
-> (ValueCtor (PartLLVMVal sym) -> IO (PartLLVMVal sym))
-> ValueCtor (PartLLVMVal sym)
-> ReadMem sym (PartLLVMVal sym)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. sym
-> EndianForm
-> MemoryOp sym w
-> ValueCtor (PartLLVMVal sym)
-> IO (PartLLVMVal sym)
forall sym (w :: Natural).
(IsSymInterface sym, HasLLVMAnn sym, 1 <= w) =>
sym
-> EndianForm
-> MemoryOp sym w
-> ValueCtor (PartLLVMVal sym)
-> IO (PartLLVMVal sym)
genValueCtor sym
sym EndianForm
end MemoryOp sym w
mop (ValueCtor (PartLLVMVal sym) -> ReadMem sym (PartLLVMVal sym))
-> ReadMem sym (ValueCtor (PartLLVMVal sym))
-> ReadMem sym (PartLLVMVal sym)
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< (ValueLoad Addr -> ReadMem sym (PartLLVMVal sym))
-> ValueCtor (ValueLoad Addr)
-> ReadMem sym (ValueCtor (PartLLVMVal 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) -> ValueCtor a -> f (ValueCtor b)
traverse ValueLoad Addr -> ReadMem sym (PartLLVMVal sym)
subFn ValueCtor (ValueLoad Addr)
vcr
       -- Symbolic offsets
       (Maybe Integer, Maybe Integer)
_ ->
         do let subFn :: ValueLoad OffsetExpr -> ReadMem sym (PartLLVMVal sym)
                subFn :: ValueLoad OffsetExpr -> ReadMem sym (PartLLVMVal sym)
subFn (OldMemory OffsetExpr
o StorageType
tp')  = do
                  SymBV sym w
o' <- IO (SymBV sym w) -> ReadMem sym (SymBV sym w)
forall a. IO a -> ReadMem sym a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (SymBV sym w) -> ReadMem sym (SymBV sym w))
-> IO (SymBV sym w) -> ReadMem sym (SymBV sym w)
forall a b. (a -> b) -> a -> b
$ sym -> NatRepr w -> ExprEnv sym w -> OffsetExpr -> IO (SymBV sym w)
forall (w :: Natural) sym.
(1 <= w, IsSymInterface sym) =>
sym -> NatRepr w -> ExprEnv sym w -> OffsetExpr -> IO (SymBV sym w)
genOffsetExpr sym
sym NatRepr w
w ExprEnv sym w
varFn OffsetExpr
o
                  StorageType -> LLVMPtr sym w -> ReadMem sym (PartLLVMVal sym)
readPrev StorageType
tp' (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
o')
                subFn (LastStore ValueView
v)      = IO (PartLLVMVal sym) -> ReadMem sym (PartLLVMVal sym)
forall a. IO a -> ReadMem sym a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (PartLLVMVal sym) -> ReadMem sym (PartLLVMVal sym))
-> IO (PartLLVMVal sym) -> ReadMem sym (PartLLVMVal sym)
forall a b. (a -> b) -> a -> b
$
                  sym
-> EndianForm
-> MemoryOp sym w
-> PartLLVMVal sym
-> ValueView
-> IO (PartLLVMVal sym)
forall sym (w :: Natural).
(IsSymInterface sym, HasLLVMAnn sym, 1 <= w) =>
sym
-> EndianForm
-> MemErrContext sym w
-> PartLLVMVal sym
-> ValueView
-> IO (PartLLVMVal sym)
applyView sym
sym EndianForm
end MemoryOp sym w
mop (sym -> LLVMVal sym -> PartLLVMVal sym
forall sym.
IsExprBuilder sym =>
sym -> LLVMVal sym -> PartLLVMVal sym
Partial.totalLLVMVal sym
sym LLVMVal sym
t) ValueView
v
                subFn (InvalidMemory StorageType
tp) = IO (PartLLVMVal sym) -> ReadMem sym (PartLLVMVal sym)
forall a. IO a -> ReadMem sym a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (sym -> MemoryOp sym w -> MemoryErrorReason -> IO (PartLLVMVal sym)
forall sym (w :: Natural).
(IsSymInterface sym, HasLLVMAnn sym, 1 <= w) =>
sym -> MemoryOp sym w -> MemoryErrorReason -> IO (PartLLVMVal sym)
Partial.partErr sym
sym MemoryOp sym w
mop (MemoryErrorReason -> IO (PartLLVMVal sym))
-> MemoryErrorReason -> IO (PartLLVMVal sym)
forall a b. (a -> b) -> a -> b
$ StorageType -> MemoryErrorReason
Invalid StorageType
tp)
            let pref :: BasePreference
pref | Just{} <- Maybe Integer
dd = BasePreference
FixedStore
                     | Just{} <- Maybe Integer
ld = BasePreference
FixedLoad
                     | Bool
otherwise = BasePreference
NeitherFixed

            let alignStride :: Addr
alignStride = Alignment -> Addr
fromAlignment (Alignment -> Addr) -> Alignment -> Addr
forall a b. (a -> b) -> a -> b
$ Alignment -> Alignment -> Alignment
forall a. Ord a => a -> a -> a
min Alignment
loadAlign Alignment
storeAlign

            -- compute the linear form of (load offset - store offset)
            let (Addr
diffStride, Addr
diffDelta)
                  | Just (ConcreteVal (BaseBVType w)
load_a, SymBV sym w
_x, ConcreteVal (BaseBVType w)
load_b) <- SymBV sym w
-> Maybe
     (ConcreteVal (BaseBVType w), SymBV sym w,
      ConcreteVal (BaseBVType w))
forall (tp :: BaseType).
SymExpr sym tp
-> Maybe (ConcreteVal tp, SymExpr sym tp, ConcreteVal tp)
forall (e :: BaseType -> Type) (tp :: BaseType).
IsExpr e =>
e tp -> Maybe (ConcreteVal tp, e tp, ConcreteVal tp)
asAffineVar SymBV sym w
off
                  , Just (ConcreteVal (BaseBVType w)
store_a, SymBV sym w
_y, ConcreteVal (BaseBVType w)
store_b) <- SymBV sym w
-> Maybe
     (ConcreteVal (BaseBVType w), SymBV sym w,
      ConcreteVal (BaseBVType w))
forall (tp :: BaseType).
SymExpr sym tp
-> Maybe (ConcreteVal tp, SymExpr sym tp, ConcreteVal tp)
forall (e :: BaseType -> Type) (tp :: BaseType).
IsExpr e =>
e tp -> Maybe (ConcreteVal tp, e tp, ConcreteVal tp)
asAffineVar SymBV sym w
d = do
                    let stride' :: Integer
stride' = Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
gcd
                          (BV w -> Integer
forall (w :: Natural). BV w -> Integer
BV.asUnsigned (ConcreteVal (BaseBVType w) -> BV w
forall (w :: Natural). ConcreteVal (BaseBVType w) -> BV w
W4.fromConcreteBV ConcreteVal (BaseBVType w)
load_a))
                          (BV w -> Integer
forall (w :: Natural). BV w -> Integer
BV.asUnsigned (ConcreteVal (BaseBVType w) -> BV w
forall (w :: Natural). ConcreteVal (BaseBVType w) -> BV w
W4.fromConcreteBV ConcreteVal (BaseBVType w)
store_a))
                    -- mod returns a non-negative integer
                    let delta' :: Integer
delta' = Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
mod
                          (BV w -> Integer
forall (w :: Natural). BV w -> Integer
BV.asUnsigned (ConcreteVal (BaseBVType w) -> BV w
forall (w :: Natural). ConcreteVal (BaseBVType w) -> BV w
W4.fromConcreteBV ConcreteVal (BaseBVType w)
load_b) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
-
                           BV w -> Integer
forall (w :: Natural). BV w -> Integer
BV.asUnsigned (ConcreteVal (BaseBVType w) -> BV w
forall (w :: Natural). ConcreteVal (BaseBVType w) -> BV w
W4.fromConcreteBV ConcreteVal (BaseBVType w)
store_b))
                          Integer
stride'
                    (Integer -> Addr
forall a. Num a => Integer -> a
fromInteger Integer
stride', Integer -> Addr
forall a. Num a => Integer -> a
fromInteger Integer
delta')
                  | Just (ConcreteVal (BaseBVType w)
load_a, SymBV sym w
_x, ConcreteVal (BaseBVType w)
load_b) <- SymBV sym w
-> Maybe
     (ConcreteVal (BaseBVType w), SymBV sym w,
      ConcreteVal (BaseBVType w))
forall (tp :: BaseType).
SymExpr sym tp
-> Maybe (ConcreteVal tp, SymExpr sym tp, ConcreteVal tp)
forall (e :: BaseType -> Type) (tp :: BaseType).
IsExpr e =>
e tp -> Maybe (ConcreteVal tp, e tp, ConcreteVal tp)
asAffineVar SymBV sym w
off
                  , Just Integer
store_b <- BV w -> Integer
forall (w :: Natural). BV w -> Integer
BV.asUnsigned (BV w -> Integer) -> Maybe (BV w) -> Maybe Integer
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> SymBV sym w -> Maybe (BV w)
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 SymBV sym w
d = do
                    let stride' :: Integer
stride' = BV w -> Integer
forall (w :: Natural). BV w -> Integer
BV.asUnsigned (ConcreteVal (BaseBVType w) -> BV w
forall (w :: Natural). ConcreteVal (BaseBVType w) -> BV w
W4.fromConcreteBV ConcreteVal (BaseBVType w)
load_a)
                    let delta' :: Integer
delta' = Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
mod (BV w -> Integer
forall (w :: Natural). BV w -> Integer
BV.asUnsigned (ConcreteVal (BaseBVType w) -> BV w
forall (w :: Natural). ConcreteVal (BaseBVType w) -> BV w
W4.fromConcreteBV ConcreteVal (BaseBVType w)
load_b) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
store_b) Integer
stride'
                    (Integer -> Addr
forall a. Num a => Integer -> a
fromInteger Integer
stride', Integer -> Addr
forall a. Num a => Integer -> a
fromInteger Integer
delta')
                  | Just Integer
load_b <- BV w -> Integer
forall (w :: Natural). BV w -> Integer
BV.asUnsigned (BV w -> Integer) -> Maybe (BV w) -> Maybe Integer
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> SymBV sym w -> Maybe (BV w)
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 SymBV sym w
off
                  , Just (ConcreteVal (BaseBVType w)
store_a, SymBV sym w
_y, ConcreteVal (BaseBVType w)
store_b) <- SymBV sym w
-> Maybe
     (ConcreteVal (BaseBVType w), SymBV sym w,
      ConcreteVal (BaseBVType w))
forall (tp :: BaseType).
SymExpr sym tp
-> Maybe (ConcreteVal tp, SymExpr sym tp, ConcreteVal tp)
forall (e :: BaseType -> Type) (tp :: BaseType).
IsExpr e =>
e tp -> Maybe (ConcreteVal tp, e tp, ConcreteVal tp)
asAffineVar SymBV sym w
d = do
                    let stride' :: Integer
stride' = BV w -> Integer
forall (w :: Natural). BV w -> Integer
BV.asUnsigned (ConcreteVal (BaseBVType w) -> BV w
forall (w :: Natural). ConcreteVal (BaseBVType w) -> BV w
W4.fromConcreteBV ConcreteVal (BaseBVType w)
store_a)
                    let delta' :: Integer
delta' = Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
mod (Integer
load_b Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- BV w -> Integer
forall (w :: Natural). BV w -> Integer
BV.asUnsigned (ConcreteVal (BaseBVType w) -> BV w
forall (w :: Natural). ConcreteVal (BaseBVType w) -> BV w
W4.fromConcreteBV ConcreteVal (BaseBVType w)
store_b)) Integer
stride'
                    (Integer -> Addr
forall a. Num a => Integer -> a
fromInteger Integer
stride', Integer -> Addr
forall a. Num a => Integer -> a
fromInteger Integer
delta')
                  | Bool
otherwise = (Addr
1, Addr
0)

            let (Addr
stride, Addr
delta) = if Addr
diffStride Addr -> Addr -> Bool
forall a. Ord a => a -> a -> Bool
>= Addr
alignStride
                  then (Addr
diffStride, Addr
diffDelta)
                  else (Addr
alignStride, Addr
0)

            SymBV sym w
diff <- IO (SymBV sym w) -> ReadMem sym (SymBV sym w)
forall a. IO a -> ReadMem sym a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (SymBV sym w) -> ReadMem sym (SymBV sym w))
-> IO (SymBV sym w) -> ReadMem sym (SymBV sym w)
forall a b. (a -> b) -> a -> b
$ sym -> SymBV sym w -> SymBV sym w -> IO (SymBV sym w)
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 w
off SymBV sym w
d

            -- skip computing the mux tree if it would be empty
            if StorageType -> Addr
storageTypeSize StorageType
stp Addr -> Addr -> Bool
forall a. Ord a => a -> a -> Bool
<= Addr
delta Bool -> Bool -> Bool
&& (Addr -> StorageType -> Addr
typeEnd Addr
0 StorageType
ltp) Addr -> Addr -> Bool
forall a. Ord a => a -> a -> Bool
<= (Addr
stride Addr -> Addr -> Addr
forall a. Num a => a -> a -> a
- Addr
delta)
              then StorageType -> LLVMPtr sym w -> ReadMem sym (PartLLVMVal sym)
readPrev StorageType
ltp (LLVMPtr sym w -> ReadMem sym (PartLLVMVal sym))
-> LLVMPtr sym w -> ReadMem sym (PartLLVMVal sym)
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
off
              else sym
-> NatRepr w
-> EndianForm
-> MemoryOp sym w
-> ExprEnv sym w
-> (ValueLoad OffsetExpr -> ReadMem sym (PartLLVMVal sym))
-> Mux (ValueCtor (ValueLoad OffsetExpr))
-> ReadMem sym (PartLLVMVal sym)
forall u sym (w :: Natural).
(1 <= w, IsSymInterface sym, HasLLVMAnn sym) =>
sym
-> NatRepr w
-> EndianForm
-> MemErrContext sym w
-> ExprEnv sym w
-> (u -> ReadMem sym (PartLLVMVal sym))
-> Mux (ValueCtor u)
-> ReadMem sym (PartLLVMVal sym)
evalMuxValueCtor sym
sym NatRepr w
w EndianForm
end MemoryOp sym w
mop ExprEnv sym w
varFn ValueLoad OffsetExpr -> ReadMem sym (PartLLVMVal sym)
subFn (Mux (ValueCtor (ValueLoad OffsetExpr))
 -> ReadMem sym (PartLLVMVal sym))
-> Mux (ValueCtor (ValueLoad OffsetExpr))
-> ReadMem sym (PartLLVMVal sym)
forall a b. (a -> b) -> a -> b
$
                BasePreference
-> StorageType
-> Maybe (Integer, Integer)
-> ValueView
-> LinearLoadStoreOffsetDiff
-> Mux (ValueCtor (ValueLoad OffsetExpr))
symbolicValueLoad
                  BasePreference
pref
                  StorageType
ltp
                  (SymBV sym w -> Maybe (Integer, Integer)
forall (w :: Natural).
(1 <= w) =>
SymExpr sym (BaseBVType w) -> Maybe (Integer, Integer)
forall (e :: BaseType -> Type) (w :: Natural).
(IsExpr e, 1 <= w) =>
e (BaseBVType w) -> Maybe (Integer, Integer)
signedBVBounds SymBV sym w
diff)
                  (StorageType -> ValueView
ValueViewVar StorageType
stp)
                  (Addr -> Addr -> LinearLoadStoreOffsetDiff
LinearLoadStoreOffsetDiff Addr
stride Addr
delta)

-- | Read from a memory with an array store to the same block we are reading.
--
-- NOTE: This case should only fire if a write is straddling an array store and
-- another write, as the top-level case of 'readMem' should handle the case
-- where a read is completely covered by a write to an array.
readMemArrayStore
  :: forall sym w
   . (1 <= w, IsSymInterface sym, HasLLVMAnn sym)
  => sym
  -> NatRepr w
  -> EndianForm
  -> MemoryOp sym w
  -> LLVMPtr sym w {- ^ The loaded offset -}
  -> StorageType {- ^ The type we are reading -}
  -> SymBV sym w {- ^ The offset of the mem array store from the base pointer -}
  -> SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8) {- ^ The stored array -}
  -> Maybe (SymBV sym w) {- ^ The length of the stored array -}
  -> (StorageType -> LLVMPtr sym w -> ReadMem sym (PartLLVMVal sym))
  -> ReadMem sym (PartLLVMVal sym)
readMemArrayStore :: forall sym (w :: Natural).
(1 <= w, IsSymInterface sym, HasLLVMAnn sym) =>
sym
-> NatRepr w
-> EndianForm
-> MemoryOp sym w
-> LLVMPtr sym w
-> StorageType
-> SymBV sym w
-> SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)
-> Maybe (SymBV sym w)
-> (StorageType -> LLVMPtr sym w -> ReadMem sym (PartLLVMVal sym))
-> ReadMem sym (PartLLVMVal sym)
readMemArrayStore sym
sym NatRepr w
w EndianForm
end MemoryOp sym w
mop (LLVMPointer SymNat sym
blk SymBV sym w
read_off) StorageType
tp SymBV sym w
write_off SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)
arr Maybe (SymBV sym w)
size StorageType -> LLVMPtr sym w -> ReadMem sym (PartLLVMVal sym)
read_prev = do
  let loadFn :: SymBV sym w -> StorageType -> ReadMem sym (PartLLVMVal sym)
      loadFn :: SymBV sym w -> StorageType -> ReadMem sym (PartLLVMVal sym)
loadFn SymBV sym w
base StorageType
tp' = IO (PartLLVMVal sym) -> ReadMem sym (PartLLVMVal sym)
forall a. IO a -> ReadMem sym a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (PartLLVMVal sym) -> ReadMem sym (PartLLVMVal sym))
-> IO (PartLLVMVal sym) -> ReadMem sym (PartLLVMVal sym)
forall a b. (a -> b) -> a -> b
$ do
        let loadArrayByteFn :: Offset -> IO (PartLLVMVal sym)
            loadArrayByteFn :: Addr -> IO (PartLLVMVal sym)
loadArrayByteFn Addr
off = do
              SymNat sym
blk0 <- sym -> Natural -> IO (SymNat sym)
forall sym. IsExprBuilder sym => sym -> Natural -> IO (SymNat sym)
natLit sym
sym Natural
0
              SymBV sym w
idx <- sym -> SymBV sym w -> SymBV sym w -> IO (SymBV sym w)
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 w
base (SymBV sym w -> IO (SymBV sym w))
-> IO (SymBV sym w) -> IO (SymBV sym w)
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m 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 (NatRepr w -> Addr -> BV w
forall (w :: Natural). NatRepr w -> Addr -> BV w
bytesToBV NatRepr w
w Addr
off)
              SymExpr sym (BaseBVType 8)
byte <- sym
-> SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)
-> Assignment (SymExpr sym) (SingleCtx (BaseBVType w))
-> IO (SymExpr sym (BaseBVType 8))
forall sym (idx :: Ctx BaseType) (tp :: BaseType) (b :: BaseType).
IsExprBuilder sym =>
sym
-> SymArray sym (idx ::> tp) b
-> Assignment (SymExpr sym) (idx ::> tp)
-> IO (SymExpr sym b)
forall (idx :: Ctx BaseType) (tp :: BaseType) (b :: BaseType).
sym
-> SymArray sym (idx ::> tp) b
-> Assignment (SymExpr sym) (idx ::> tp)
-> IO (SymExpr sym b)
arrayLookup sym
sym SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)
arr (Assignment (SymExpr sym) (SingleCtx (BaseBVType w))
 -> IO (SymExpr sym (BaseBVType 8)))
-> Assignment (SymExpr sym) (SingleCtx (BaseBVType w))
-> IO (SymExpr sym (BaseBVType 8))
forall a b. (a -> b) -> a -> b
$ SymBV sym w -> Assignment (SymExpr sym) (SingleCtx (BaseBVType w))
forall {k} (f :: k -> Type) (tp :: k).
f tp -> Assignment f (EmptyCtx ::> tp)
Ctx.singleton SymBV sym w
idx
              PartLLVMVal sym -> IO (PartLLVMVal sym)
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (PartLLVMVal sym -> IO (PartLLVMVal sym))
-> PartLLVMVal sym -> IO (PartLLVMVal sym)
forall a b. (a -> b) -> a -> b
$ sym -> LLVMVal sym -> PartLLVMVal sym
forall sym.
IsExprBuilder sym =>
sym -> LLVMVal sym -> PartLLVMVal sym
Partial.totalLLVMVal sym
sym (LLVMVal sym -> PartLLVMVal sym) -> LLVMVal sym -> PartLLVMVal sym
forall a b. (a -> b) -> a -> b
$ SymNat sym -> SymExpr sym (BaseBVType 8) -> LLVMVal sym
forall (w :: Natural) sym.
(1 <= w) =>
SymNat sym -> SymBV sym w -> LLVMVal sym
LLVMValInt SymNat sym
blk0 SymExpr sym (BaseBVType 8)
byte
        sym
-> EndianForm
-> MemoryOp sym w
-> ValueCtor (PartLLVMVal sym)
-> IO (PartLLVMVal sym)
forall sym (w :: Natural).
(IsSymInterface sym, HasLLVMAnn sym, 1 <= w) =>
sym
-> EndianForm
-> MemoryOp sym w
-> ValueCtor (PartLLVMVal sym)
-> IO (PartLLVMVal sym)
genValueCtor sym
sym EndianForm
end MemoryOp sym w
mop (ValueCtor (PartLLVMVal sym) -> IO (PartLLVMVal sym))
-> IO (ValueCtor (PartLLVMVal sym)) -> IO (PartLLVMVal sym)
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< Addr
-> StorageType
-> (Addr -> IO (PartLLVMVal sym))
-> IO (ValueCtor (PartLLVMVal sym))
forall a. Addr -> StorageType -> (Addr -> IO a) -> IO (ValueCtor a)
loadTypedValueFromBytes Addr
0 StorageType
tp' Addr -> IO (PartLLVMVal sym)
loadArrayByteFn
  let varFn :: ExprEnv sym w
varFn = SymBV sym w -> SymBV sym w -> Maybe (SymBV sym w) -> ExprEnv sym w
forall sym (w :: Natural).
SymBV sym w -> SymBV sym w -> Maybe (SymBV sym w) -> ExprEnv sym w
ExprEnv SymBV sym w
read_off SymBV sym w
write_off Maybe (SymBV sym w)
size
  case (BV w -> Integer
forall (w :: Natural). BV w -> Integer
BV.asUnsigned (BV w -> Integer) -> Maybe (BV w) -> Maybe Integer
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> SymBV sym w -> Maybe (BV w)
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 SymBV sym w
read_off, BV w -> Integer
forall (w :: Natural). BV w -> Integer
BV.asUnsigned (BV w -> Integer) -> Maybe (BV w) -> Maybe Integer
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> SymBV sym w -> Maybe (BV w)
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 SymBV sym w
write_off) of
    -- In this case, both the read and write offsets are concrete
    (Just Integer
lo, Just Integer
so) -> do
      let subFn :: RangeLoad Addr Addr -> ReadMem sym (PartLLVMVal sym)
          subFn :: RangeLoad Addr Addr -> ReadMem sym (PartLLVMVal sym)
subFn = \case
            OutOfRange Addr
o StorageType
tp' -> do
              SymBV sym w
o' <- IO (SymBV sym w) -> ReadMem sym (SymBV sym w)
forall a. IO a -> ReadMem sym a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (SymBV sym w) -> ReadMem sym (SymBV sym w))
-> IO (SymBV sym w) -> ReadMem sym (SymBV sym w)
forall a b. (a -> b) -> a -> 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 -> IO (SymBV sym w)) -> BV w -> IO (SymBV sym w)
forall a b. (a -> b) -> a -> b
$ NatRepr w -> Addr -> BV w
forall (w :: Natural). NatRepr w -> Addr -> BV w
bytesToBV NatRepr w
w Addr
o
              StorageType -> LLVMPtr sym w -> ReadMem sym (PartLLVMVal sym)
read_prev StorageType
tp' (LLVMPtr sym w -> ReadMem sym (PartLLVMVal sym))
-> LLVMPtr sym w -> ReadMem sym (PartLLVMVal sym)
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
o'
            InRange Addr
o StorageType
tp' -> do
              SymBV sym w
o' <- IO (SymBV sym w) -> ReadMem sym (SymBV sym w)
forall a. IO a -> ReadMem sym a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (SymBV sym w) -> ReadMem sym (SymBV sym w))
-> IO (SymBV sym w) -> ReadMem sym (SymBV sym w)
forall a b. (a -> b) -> a -> 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 -> IO (SymBV sym w)) -> BV w -> IO (SymBV sym w)
forall a b. (a -> b) -> a -> b
$ NatRepr w -> Addr -> BV w
forall (w :: Natural). NatRepr w -> Addr -> BV w
bytesToBV NatRepr w
w Addr
o
              SymBV sym w -> StorageType -> ReadMem sym (PartLLVMVal sym)
loadFn SymBV sym w
o' StorageType
tp'
      case BV w -> Integer
forall (w :: Natural). BV w -> Integer
BV.asUnsigned (BV w -> Integer) -> Maybe (BV w) -> Maybe Integer
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (SymBV sym w -> Maybe (BV w)
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 (SymBV sym w -> Maybe (BV w))
-> Maybe (SymBV sym w) -> Maybe (BV w)
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe (SymBV sym w)
size) of
        -- The size of the backing SMT array is also concrete, so we can generate a mux-free value
        Just Integer
concrete_size -> do
          let s :: Range
s = Addr -> Addr -> Range
R (Integer -> Addr
forall a. Num a => Integer -> a
fromInteger Integer
so) (Integer -> Addr
forall a. Num a => Integer -> a
fromInteger (Integer
so Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
concrete_size))
          let vcr :: ValueCtor (RangeLoad Addr Addr)
vcr = Addr -> StorageType -> Range -> ValueCtor (RangeLoad Addr Addr)
rangeLoad (Integer -> Addr
forall a. Num a => Integer -> a
fromInteger Integer
lo) StorageType
tp Range
s
          IO (PartLLVMVal sym) -> ReadMem sym (PartLLVMVal sym)
forall a. IO a -> ReadMem sym a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (PartLLVMVal sym) -> ReadMem sym (PartLLVMVal sym))
-> (ValueCtor (PartLLVMVal sym) -> IO (PartLLVMVal sym))
-> ValueCtor (PartLLVMVal sym)
-> ReadMem sym (PartLLVMVal sym)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. sym
-> EndianForm
-> MemoryOp sym w
-> ValueCtor (PartLLVMVal sym)
-> IO (PartLLVMVal sym)
forall sym (w :: Natural).
(IsSymInterface sym, HasLLVMAnn sym, 1 <= w) =>
sym
-> EndianForm
-> MemoryOp sym w
-> ValueCtor (PartLLVMVal sym)
-> IO (PartLLVMVal sym)
genValueCtor sym
sym EndianForm
end MemoryOp sym w
mop (ValueCtor (PartLLVMVal sym) -> ReadMem sym (PartLLVMVal sym))
-> ReadMem sym (ValueCtor (PartLLVMVal sym))
-> ReadMem sym (PartLLVMVal sym)
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< (RangeLoad Addr Addr -> ReadMem sym (PartLLVMVal sym))
-> ValueCtor (RangeLoad Addr Addr)
-> ReadMem sym (ValueCtor (PartLLVMVal 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) -> ValueCtor a -> f (ValueCtor b)
traverse RangeLoad Addr Addr -> ReadMem sym (PartLLVMVal sym)
subFn ValueCtor (RangeLoad Addr Addr)
vcr
        -- Otherwise, the size of the array is unbounded or symbolic
        --
        -- The generated mux covers the possible cases where the read straddles
        -- the store in various configurations
        --
        -- FIXME/Question: Does this properly handle the unbounded array case? Does it
        -- need special handling of that case at all?
        Maybe Integer
_ -> sym
-> NatRepr w
-> EndianForm
-> MemoryOp sym w
-> ExprEnv sym w
-> (RangeLoad Addr Addr -> ReadMem sym (PartLLVMVal sym))
-> Mux (ValueCtor (RangeLoad Addr Addr))
-> ReadMem sym (PartLLVMVal sym)
forall u sym (w :: Natural).
(1 <= w, IsSymInterface sym, HasLLVMAnn sym) =>
sym
-> NatRepr w
-> EndianForm
-> MemErrContext sym w
-> ExprEnv sym w
-> (u -> ReadMem sym (PartLLVMVal sym))
-> Mux (ValueCtor u)
-> ReadMem sym (PartLLVMVal sym)
evalMuxValueCtor sym
sym NatRepr w
w EndianForm
end MemoryOp sym w
mop ExprEnv sym w
varFn RangeLoad Addr Addr -> ReadMem sym (PartLLVMVal sym)
subFn (Mux (ValueCtor (RangeLoad Addr Addr))
 -> ReadMem sym (PartLLVMVal sym))
-> Mux (ValueCtor (RangeLoad Addr Addr))
-> ReadMem sym (PartLLVMVal sym)
forall a b. (a -> b) -> a -> b
$
          Addr
-> StorageType -> Addr -> Mux (ValueCtor (RangeLoad Addr Addr))
fixedOffsetRangeLoad (Integer -> Addr
forall a. Num a => Integer -> a
fromInteger Integer
lo) StorageType
tp (Integer -> Addr
forall a. Num a => Integer -> a
fromInteger Integer
so)
    -- Otherwise, at least one of the offsets is symbolic (and we will have to generate additional muxes)
    (Maybe Integer, Maybe Integer)
_ -> do
      let subFn :: RangeLoad OffsetExpr IntExpr -> ReadMem sym (PartLLVMVal sym)
          subFn :: RangeLoad OffsetExpr IntExpr -> ReadMem sym (PartLLVMVal sym)
subFn = \case
            OutOfRange OffsetExpr
o StorageType
tp' -> do
              SymBV sym w
o' <- IO (SymBV sym w) -> ReadMem sym (SymBV sym w)
forall a. IO a -> ReadMem sym a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (SymBV sym w) -> ReadMem sym (SymBV sym w))
-> IO (SymBV sym w) -> ReadMem sym (SymBV sym w)
forall a b. (a -> b) -> a -> b
$ sym -> NatRepr w -> ExprEnv sym w -> OffsetExpr -> IO (SymBV sym w)
forall (w :: Natural) sym.
(1 <= w, IsSymInterface sym) =>
sym -> NatRepr w -> ExprEnv sym w -> OffsetExpr -> IO (SymBV sym w)
genOffsetExpr sym
sym NatRepr w
w ExprEnv sym w
varFn OffsetExpr
o
              StorageType -> LLVMPtr sym w -> ReadMem sym (PartLLVMVal sym)
read_prev StorageType
tp' (LLVMPtr sym w -> ReadMem sym (PartLLVMVal sym))
-> LLVMPtr sym w -> ReadMem sym (PartLLVMVal sym)
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
o'
            InRange IntExpr
o StorageType
tp' -> do
              Maybe (SymBV sym w)
o' <- IO (Maybe (SymBV sym w)) -> ReadMem sym (Maybe (SymBV sym w))
forall a. IO a -> ReadMem sym a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (SymBV sym w)) -> ReadMem sym (Maybe (SymBV sym w)))
-> IO (Maybe (SymBV sym w)) -> ReadMem sym (Maybe (SymBV sym w))
forall a b. (a -> b) -> a -> b
$ sym
-> NatRepr w
-> ExprEnv sym w
-> IntExpr
-> IO (Maybe (SymBV sym w))
forall (w :: Natural) sym.
(1 <= w, IsSymInterface sym) =>
sym
-> NatRepr w
-> ExprEnv sym w
-> IntExpr
-> IO (Maybe (SymBV sym w))
genIntExpr sym
sym NatRepr w
w ExprEnv sym w
varFn IntExpr
o
              -- should always produce a defined value
              case Maybe (SymBV sym w)
o' of
                Just SymBV sym w
o'' -> SymBV sym w -> StorageType -> ReadMem sym (PartLLVMVal sym)
loadFn SymBV sym w
o'' StorageType
tp'
                Maybe (SymBV sym w)
Nothing  -> [Char] -> [[Char]] -> ReadMem sym (PartLLVMVal sym)
forall a. HasCallStack => [Char] -> [[Char]] -> a
panic [Char]
"Generic.readMemArrayStore"
                              [ [Char]
"Unexpected unbounded size in RangeLoad"
                              , [Char]
"*** Integer expression:  " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ IntExpr -> [Char]
forall a. Show a => a -> [Char]
show IntExpr
o
                              , [Char]
"*** Under environment:  " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Doc Any -> [Char]
forall a. Show a => a -> [Char]
show (ExprEnv sym w -> Doc Any
forall sym (w :: Natural) ann.
IsExprBuilder sym =>
ExprEnv sym w -> Doc ann
ppExprEnv ExprEnv sym w
varFn)
                              ]
      let pref :: BasePreference
pref
            | Just{} <- BV w -> Integer
forall (w :: Natural). BV w -> Integer
BV.asUnsigned (BV w -> Integer) -> Maybe (BV w) -> Maybe Integer
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> SymBV sym w -> Maybe (BV w)
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 SymBV sym w
write_off = BasePreference
FixedStore
            | Just{} <- BV w -> Integer
forall (w :: Natural). BV w -> Integer
BV.asUnsigned (BV w -> Integer) -> Maybe (BV w) -> Maybe Integer
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> SymBV sym w -> Maybe (BV w)
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 SymBV sym w
read_off = BasePreference
FixedLoad
            | Bool
otherwise = BasePreference
NeitherFixed
      let rngLd :: Mux (ValueCtor (RangeLoad OffsetExpr IntExpr))
rngLd
            -- if the size of the data is bounded, use symbolicRangeLoad
            | Just SymBV sym w
_  <- Maybe (SymBV sym w)
size = BasePreference
-> StorageType -> Mux (ValueCtor (RangeLoad OffsetExpr IntExpr))
symbolicRangeLoad BasePreference
pref StorageType
tp
            -- otherwise, use symbolicUnboundedRangeLoad
            | Maybe (SymBV sym w)
Nothing <- Maybe (SymBV sym w)
size = BasePreference
-> StorageType -> Mux (ValueCtor (RangeLoad OffsetExpr IntExpr))
symbolicUnboundedRangeLoad BasePreference
pref StorageType
tp
      sym
-> NatRepr w
-> EndianForm
-> MemoryOp sym w
-> ExprEnv sym w
-> (RangeLoad OffsetExpr IntExpr -> ReadMem sym (PartLLVMVal sym))
-> Mux (ValueCtor (RangeLoad OffsetExpr IntExpr))
-> ReadMem sym (PartLLVMVal sym)
forall u sym (w :: Natural).
(1 <= w, IsSymInterface sym, HasLLVMAnn sym) =>
sym
-> NatRepr w
-> EndianForm
-> MemErrContext sym w
-> ExprEnv sym w
-> (u -> ReadMem sym (PartLLVMVal sym))
-> Mux (ValueCtor u)
-> ReadMem sym (PartLLVMVal sym)
evalMuxValueCtor sym
sym NatRepr w
w EndianForm
end MemoryOp sym w
mop ExprEnv sym w
varFn RangeLoad OffsetExpr IntExpr -> ReadMem sym (PartLLVMVal sym)
subFn Mux (ValueCtor (RangeLoad OffsetExpr IntExpr))
rngLd

readMemInvalidate ::
  forall sym w .
  ( 1 <= w, IsSymInterface sym, HasLLVMAnn sym
  , ?memOpts :: MemOptions ) =>
  sym -> NatRepr w ->
  EndianForm ->
  MemoryOp sym w ->
  LLVMPtr sym w {- ^ The loaded offset                   -} ->
  StorageType   {- ^ The type we are reading             -} ->
  SymBV sym w   {- ^ The destination of the invalidation -} ->
  Text          {- ^ The error message                   -} ->
  SymBV sym w   {- ^ The length of the set region        -} ->
  (StorageType -> LLVMPtr sym w -> ReadMem sym (PartLLVMVal sym)) ->
  ReadMem sym (PartLLVMVal sym)
readMemInvalidate :: forall sym (w :: Natural).
(1 <= w, IsSymInterface sym, HasLLVMAnn sym,
 ?memOpts::MemOptions) =>
sym
-> NatRepr w
-> EndianForm
-> MemoryOp sym w
-> LLVMPtr sym w
-> StorageType
-> SymBV sym w
-> Text
-> SymBV sym w
-> (StorageType -> LLVMPtr sym w -> ReadMem sym (PartLLVMVal sym))
-> ReadMem sym (PartLLVMVal sym)
readMemInvalidate sym
sym NatRepr w
w EndianForm
end MemoryOp sym w
mop (LLVMPointer SymNat sym
blk SymBV sym w
off) StorageType
tp SymBV sym w
d Text
msg SymBV sym w
sz StorageType -> LLVMPtr sym w -> ReadMem sym (PartLLVMVal sym)
readPrev =
  do let ld :: Maybe Integer
ld = BV w -> Integer
forall (w :: Natural). BV w -> Integer
BV.asUnsigned (BV w -> Integer) -> Maybe (BV w) -> Maybe Integer
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> SymBV sym w -> Maybe (BV w)
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 SymBV sym w
off
     let dd :: Maybe Integer
dd = BV w -> Integer
forall (w :: Natural). BV w -> Integer
BV.asUnsigned (BV w -> Integer) -> Maybe (BV w) -> Maybe Integer
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> SymBV sym w -> Maybe (BV w)
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 SymBV sym w
d
     let varFn :: ExprEnv sym w
varFn = SymBV sym w -> SymBV sym w -> Maybe (SymBV sym w) -> ExprEnv sym w
forall sym (w :: Natural).
SymBV sym w -> SymBV sym w -> Maybe (SymBV sym w) -> ExprEnv sym w
ExprEnv SymBV sym w
off SymBV sym w
d (SymBV sym w -> Maybe (SymBV sym w)
forall a. a -> Maybe a
Just SymBV sym w
sz)
     case (Maybe Integer
ld, Maybe Integer
dd) of
       -- Offset if known
       (Just Integer
lo, Just Integer
so) ->
         do let subFn :: RangeLoad Addr Addr -> ReadMem sym (PartLLVMVal sym)
                subFn :: RangeLoad Addr Addr -> ReadMem sym (PartLLVMVal sym)
subFn (OutOfRange Addr
o StorageType
tp') = do
                  SymBV sym w
o' <- IO (SymBV sym w) -> ReadMem sym (SymBV sym w)
forall a. IO a -> ReadMem sym a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (SymBV sym w) -> ReadMem sym (SymBV sym w))
-> IO (SymBV sym w) -> ReadMem sym (SymBV sym w)
forall a b. (a -> b) -> a -> 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 (NatRepr w -> Addr -> BV w
forall (w :: Natural). NatRepr w -> Addr -> BV w
bytesToBV NatRepr w
w Addr
o)
                  StorageType -> LLVMPtr sym w -> ReadMem sym (PartLLVMVal sym)
readPrev StorageType
tp' (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
o')
                subFn (InRange Addr
_o StorageType
tp') =
                  StorageType -> ReadMem sym (PartLLVMVal sym)
readInRange StorageType
tp'
            case BV w -> Integer
forall (w :: Natural). BV w -> Integer
BV.asUnsigned (BV w -> Integer) -> Maybe (BV w) -> Maybe Integer
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> SymBV sym w -> Maybe (BV w)
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 SymBV sym w
sz of
              Just Integer
csz -> do
                let s :: Range
s = Addr -> Addr -> Range
R (Integer -> Addr
forall a. Num a => Integer -> a
fromInteger Integer
so) (Integer -> Addr
forall a. Num a => Integer -> a
fromInteger (Integer
so Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
csz))
                let vcr :: ValueCtor (RangeLoad Addr Addr)
vcr = Addr -> StorageType -> Range -> ValueCtor (RangeLoad Addr Addr)
rangeLoad (Integer -> Addr
forall a. Num a => Integer -> a
fromInteger Integer
lo) StorageType
tp Range
s
                IO (PartLLVMVal sym) -> ReadMem sym (PartLLVMVal sym)
forall a. IO a -> ReadMem sym a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (PartLLVMVal sym) -> ReadMem sym (PartLLVMVal sym))
-> (ValueCtor (PartLLVMVal sym) -> IO (PartLLVMVal sym))
-> ValueCtor (PartLLVMVal sym)
-> ReadMem sym (PartLLVMVal sym)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. sym
-> EndianForm
-> MemoryOp sym w
-> ValueCtor (PartLLVMVal sym)
-> IO (PartLLVMVal sym)
forall sym (w :: Natural).
(IsSymInterface sym, HasLLVMAnn sym, 1 <= w) =>
sym
-> EndianForm
-> MemoryOp sym w
-> ValueCtor (PartLLVMVal sym)
-> IO (PartLLVMVal sym)
genValueCtor sym
sym EndianForm
end MemoryOp sym w
mop (ValueCtor (PartLLVMVal sym) -> ReadMem sym (PartLLVMVal sym))
-> ReadMem sym (ValueCtor (PartLLVMVal sym))
-> ReadMem sym (PartLLVMVal sym)
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< (RangeLoad Addr Addr -> ReadMem sym (PartLLVMVal sym))
-> ValueCtor (RangeLoad Addr Addr)
-> ReadMem sym (ValueCtor (PartLLVMVal 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) -> ValueCtor a -> f (ValueCtor b)
traverse RangeLoad Addr Addr -> ReadMem sym (PartLLVMVal sym)
subFn ValueCtor (RangeLoad Addr Addr)
vcr
              Maybe Integer
_ -> sym
-> NatRepr w
-> EndianForm
-> MemoryOp sym w
-> ExprEnv sym w
-> (RangeLoad Addr Addr -> ReadMem sym (PartLLVMVal sym))
-> Mux (ValueCtor (RangeLoad Addr Addr))
-> ReadMem sym (PartLLVMVal sym)
forall u sym (w :: Natural).
(1 <= w, IsSymInterface sym, HasLLVMAnn sym) =>
sym
-> NatRepr w
-> EndianForm
-> MemErrContext sym w
-> ExprEnv sym w
-> (u -> ReadMem sym (PartLLVMVal sym))
-> Mux (ValueCtor u)
-> ReadMem sym (PartLLVMVal sym)
evalMuxValueCtor sym
sym NatRepr w
w EndianForm
end MemoryOp sym w
mop ExprEnv sym w
varFn RangeLoad Addr Addr -> ReadMem sym (PartLLVMVal sym)
subFn (Mux (ValueCtor (RangeLoad Addr Addr))
 -> ReadMem sym (PartLLVMVal sym))
-> Mux (ValueCtor (RangeLoad Addr Addr))
-> ReadMem sym (PartLLVMVal sym)
forall a b. (a -> b) -> a -> b
$
                     Addr
-> StorageType -> Addr -> Mux (ValueCtor (RangeLoad Addr Addr))
fixedOffsetRangeLoad (Integer -> Addr
forall a. Num a => Integer -> a
fromInteger Integer
lo) StorageType
tp (Integer -> Addr
forall a. Num a => Integer -> a
fromInteger Integer
so)
       -- Symbolic offsets
       (Maybe Integer, Maybe Integer)
_ ->
         do let subFn :: RangeLoad OffsetExpr IntExpr -> ReadMem sym (PartLLVMVal sym)
                subFn :: RangeLoad OffsetExpr IntExpr -> ReadMem sym (PartLLVMVal sym)
subFn (OutOfRange OffsetExpr
o StorageType
tp') = do
                  SymBV sym w
o' <- IO (SymBV sym w) -> ReadMem sym (SymBV sym w)
forall a. IO a -> ReadMem sym a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (SymBV sym w) -> ReadMem sym (SymBV sym w))
-> IO (SymBV sym w) -> ReadMem sym (SymBV sym w)
forall a b. (a -> b) -> a -> b
$ sym -> NatRepr w -> ExprEnv sym w -> OffsetExpr -> IO (SymBV sym w)
forall (w :: Natural) sym.
(1 <= w, IsSymInterface sym) =>
sym -> NatRepr w -> ExprEnv sym w -> OffsetExpr -> IO (SymBV sym w)
genOffsetExpr sym
sym NatRepr w
w ExprEnv sym w
varFn OffsetExpr
o
                  StorageType -> LLVMPtr sym w -> ReadMem sym (PartLLVMVal sym)
readPrev StorageType
tp' (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
o')
                subFn (InRange IntExpr
_o StorageType
tp') =
                  StorageType -> ReadMem sym (PartLLVMVal sym)
readInRange StorageType
tp'
            let pref :: BasePreference
pref | Just{} <- Maybe Integer
dd = BasePreference
FixedStore
                     | Just{} <- Maybe Integer
ld = BasePreference
FixedLoad
                     | Bool
otherwise = BasePreference
NeitherFixed
            let mux0 :: Mux (ValueCtor (RangeLoad OffsetExpr IntExpr))
mux0 | Just Integer
csz <- BV w -> Integer
forall (w :: Natural). BV w -> Integer
BV.asUnsigned (BV w -> Integer) -> Maybe (BV w) -> Maybe Integer
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> SymBV sym w -> Maybe (BV w)
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 SymBV sym w
sz =
                         BasePreference
-> StorageType
-> Addr
-> Mux (ValueCtor (RangeLoad OffsetExpr IntExpr))
fixedSizeRangeLoad BasePreference
pref StorageType
tp (Integer -> Addr
forall a. Num a => Integer -> a
fromInteger Integer
csz)
                     | Bool
otherwise =
                         BasePreference
-> StorageType -> Mux (ValueCtor (RangeLoad OffsetExpr IntExpr))
symbolicRangeLoad BasePreference
pref StorageType
tp
            sym
-> NatRepr w
-> EndianForm
-> MemoryOp sym w
-> ExprEnv sym w
-> (RangeLoad OffsetExpr IntExpr -> ReadMem sym (PartLLVMVal sym))
-> Mux (ValueCtor (RangeLoad OffsetExpr IntExpr))
-> ReadMem sym (PartLLVMVal sym)
forall u sym (w :: Natural).
(1 <= w, IsSymInterface sym, HasLLVMAnn sym) =>
sym
-> NatRepr w
-> EndianForm
-> MemErrContext sym w
-> ExprEnv sym w
-> (u -> ReadMem sym (PartLLVMVal sym))
-> Mux (ValueCtor u)
-> ReadMem sym (PartLLVMVal sym)
evalMuxValueCtor sym
sym NatRepr w
w EndianForm
end MemoryOp sym w
mop ExprEnv sym w
varFn RangeLoad OffsetExpr IntExpr -> ReadMem sym (PartLLVMVal sym)
subFn Mux (ValueCtor (RangeLoad OffsetExpr IntExpr))
mux0
  where
    readInRange :: StorageType -> ReadMem sym (PartLLVMVal sym)
    readInRange :: StorageType -> ReadMem sym (PartLLVMVal sym)
readInRange StorageType
tp'
      | 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
UnstableSymbolic
      = IO (PartLLVMVal sym) -> ReadMem sym (PartLLVMVal sym)
forall a. IO a -> ReadMem sym a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (sym -> LLVMVal sym -> PartLLVMVal sym
forall sym.
IsExprBuilder sym =>
sym -> LLVMVal sym -> PartLLVMVal sym
Partial.totalLLVMVal sym
sym (LLVMVal sym -> PartLLVMVal sym)
-> IO (LLVMVal sym) -> IO (PartLLVMVal sym)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> sym -> StorageType -> IO (LLVMVal sym)
forall sym.
IsSymInterface sym =>
sym -> StorageType -> IO (LLVMVal sym)
freshLLVMVal sym
sym StorageType
tp')
      | Bool
otherwise
      = IO (PartLLVMVal sym) -> ReadMem sym (PartLLVMVal sym)
forall a. IO a -> ReadMem sym a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (sym -> MemoryOp sym w -> MemoryErrorReason -> IO (PartLLVMVal sym)
forall sym (w :: Natural).
(IsSymInterface sym, HasLLVMAnn sym, 1 <= w) =>
sym -> MemoryOp sym w -> MemoryErrorReason -> IO (PartLLVMVal sym)
Partial.partErr sym
sym MemoryOp sym w
mop (MemoryErrorReason -> IO (PartLLVMVal sym))
-> MemoryErrorReason -> IO (PartLLVMVal sym)
forall a b. (a -> b) -> a -> b
$ Text -> MemoryErrorReason
Invalidated Text
msg)

-- | Read a value from memory.
readMem :: forall sym w.
  ( 1 <= w, IsSymInterface sym, HasLLVMAnn sym
  , ?memOpts :: MemOptions ) =>
  sym ->
  NatRepr w ->
  Maybe String ->
  LLVMPtr sym w ->
  StorageType ->
  Alignment ->
  Mem sym ->
  IO (PartLLVMVal sym)
readMem :: forall sym (w :: Natural).
(1 <= w, IsSymInterface sym, HasLLVMAnn sym,
 ?memOpts::MemOptions) =>
sym
-> NatRepr w
-> Maybe [Char]
-> LLVMPtr sym w
-> StorageType
-> Alignment
-> Mem sym
-> IO (PartLLVMVal sym)
readMem sym
sym NatRepr w
w Maybe [Char]
gsym LLVMPtr sym w
l StorageType
tp Alignment
alignment Mem sym
m = do
  SymExpr sym (BaseBVType w)
sz         <- sym -> NatRepr w -> BV w -> IO (SymExpr sym (BaseBVType 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 (NatRepr w -> Addr -> BV w
forall (w :: Natural). NatRepr w -> Addr -> BV w
bytesToBV NatRepr w
w (Addr -> StorageType -> Addr
typeEnd Addr
0 StorageType
tp))
  SymExpr sym BaseBoolType
p1         <- sym
-> NatRepr w
-> Alignment
-> LLVMPtr sym w
-> Maybe (SymExpr sym (BaseBVType w))
-> Mem sym
-> IO (SymExpr sym BaseBoolType)
forall sym (w :: Natural).
(1 <= w, IsSymInterface sym) =>
sym
-> NatRepr w
-> Alignment
-> LLVMPtr sym w
-> Maybe (SymBV sym w)
-> Mem sym
-> IO (Pred sym)
isAllocated sym
sym NatRepr w
w Alignment
alignment LLVMPtr sym w
l (SymExpr sym (BaseBVType w) -> Maybe (SymExpr sym (BaseBVType w))
forall a. a -> Maybe a
Just SymExpr sym (BaseBVType w)
sz) Mem sym
m
  SymExpr sym BaseBoolType
p2         <- sym
-> NatRepr w
-> LLVMPtr sym w
-> Alignment
-> IO (SymExpr sym BaseBoolType)
forall sym (w :: Natural).
(1 <= w, IsSymInterface sym) =>
sym -> NatRepr w -> LLVMPtr sym w -> Alignment -> IO (Pred sym)
isAligned sym
sym NatRepr w
w LLVMPtr sym w
l Alignment
alignment
  Maybe
  (SymExpr sym BaseBoolType,
   SymExpr
     sym (BaseArrayType (SingleCtx (BaseBVType w)) (BaseBVType 8)),
   SymExpr sym (BaseBVType w))
maybe_allocation_array <- sym
-> NatRepr w
-> LLVMPtr sym w
-> Mem sym
-> IO
     (Maybe
        (SymExpr sym BaseBoolType,
         SymExpr
           sym (BaseArrayType (SingleCtx (BaseBVType w)) (BaseBVType 8)),
         SymExpr sym (BaseBVType w)))
forall sym (w :: Natural).
(IsSymInterface sym, 1 <= w) =>
sym
-> NatRepr w
-> LLVMPtr sym w
-> Mem sym
-> IO
     (Maybe
        (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8),
         SymBV sym w))
asMemAllocationArrayStore sym
sym NatRepr w
w LLVMPtr sym w
l Mem sym
m

  let mop :: MemoryOp sym w
mop = StorageType
-> Maybe [Char] -> LLVMPtr sym w -> Mem sym -> MemoryOp sym w
forall sym (w :: Natural).
StorageType
-> Maybe [Char] -> LLVMPtr sym w -> Mem sym -> MemoryOp sym w
MemLoadOp StorageType
tp Maybe [Char]
gsym LLVMPtr sym w
l Mem sym
m

  PartLLVMVal sym
part_val <- case Maybe
  (SymExpr sym BaseBoolType,
   SymExpr
     sym (BaseArrayType (SingleCtx (BaseBVType w)) (BaseBVType 8)),
   SymExpr sym (BaseBVType w))
maybe_allocation_array of
    -- If this read is inside an allocation backed by a SMT array store,
    -- then decompose this read into reading the individual bytes and
    -- assembling them to obtain the value, without introducing any
    -- ite operations
    Just (SymExpr sym BaseBoolType
ok, SymExpr
  sym (BaseArrayType (SingleCtx (BaseBVType w)) (BaseBVType 8))
arr, SymExpr sym (BaseBVType w)
_arr_sz) | Just Bool
True <- SymExpr sym BaseBoolType -> Maybe Bool
forall (e :: BaseType -> Type).
IsExpr e =>
e BaseBoolType -> Maybe Bool
asConstantPred SymExpr sym BaseBoolType
ok -> do
      let loadArrayByteFn :: Offset -> IO (PartLLVMVal sym)
          loadArrayByteFn :: Addr -> IO (PartLLVMVal sym)
loadArrayByteFn Addr
off = do
            SymNat sym
blk0 <- sym -> Natural -> IO (SymNat sym)
forall sym. IsExprBuilder sym => sym -> Natural -> IO (SymNat sym)
natLit sym
sym Natural
0
            SymExpr sym (BaseBVType w)
idx <- sym
-> SymExpr sym (BaseBVType w)
-> SymExpr sym (BaseBVType w)
-> IO (SymExpr sym (BaseBVType w))
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 (LLVMPtr sym w -> SymExpr sym (BaseBVType w)
forall sym (w :: Natural). LLVMPtr sym w -> SymBV sym w
llvmPointerOffset LLVMPtr sym w
l)
              (SymExpr sym (BaseBVType w) -> IO (SymExpr sym (BaseBVType w)))
-> IO (SymExpr sym (BaseBVType w))
-> IO (SymExpr sym (BaseBVType w))
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< sym -> NatRepr w -> BV w -> IO (SymExpr sym (BaseBVType 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 (NatRepr w -> Addr -> BV w
forall (w :: Natural). NatRepr w -> Addr -> BV w
bytesToBV NatRepr w
w Addr
off)
            SymExpr sym (BaseBVType 8)
byte <- sym
-> SymExpr
     sym (BaseArrayType (SingleCtx (BaseBVType w)) (BaseBVType 8))
-> Assignment (SymExpr sym) (SingleCtx (BaseBVType w))
-> IO (SymExpr sym (BaseBVType 8))
forall sym (idx :: Ctx BaseType) (tp :: BaseType) (b :: BaseType).
IsExprBuilder sym =>
sym
-> SymArray sym (idx ::> tp) b
-> Assignment (SymExpr sym) (idx ::> tp)
-> IO (SymExpr sym b)
forall (idx :: Ctx BaseType) (tp :: BaseType) (b :: BaseType).
sym
-> SymArray sym (idx ::> tp) b
-> Assignment (SymExpr sym) (idx ::> tp)
-> IO (SymExpr sym b)
arrayLookup sym
sym SymExpr
  sym (BaseArrayType (SingleCtx (BaseBVType w)) (BaseBVType 8))
arr (Assignment (SymExpr sym) (SingleCtx (BaseBVType w))
 -> IO (SymExpr sym (BaseBVType 8)))
-> Assignment (SymExpr sym) (SingleCtx (BaseBVType w))
-> IO (SymExpr sym (BaseBVType 8))
forall a b. (a -> b) -> a -> b
$ SymExpr sym (BaseBVType w)
-> Assignment (SymExpr sym) (SingleCtx (BaseBVType w))
forall {k} (f :: k -> Type) (tp :: k).
f tp -> Assignment f (EmptyCtx ::> tp)
Ctx.singleton SymExpr sym (BaseBVType w)
idx
            PartLLVMVal sym -> IO (PartLLVMVal sym)
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (PartLLVMVal sym -> IO (PartLLVMVal sym))
-> PartLLVMVal sym -> IO (PartLLVMVal sym)
forall a b. (a -> b) -> a -> b
$ sym -> LLVMVal sym -> PartLLVMVal sym
forall sym.
IsExprBuilder sym =>
sym -> LLVMVal sym -> PartLLVMVal sym
Partial.totalLLVMVal sym
sym (LLVMVal sym -> PartLLVMVal sym) -> LLVMVal sym -> PartLLVMVal sym
forall a b. (a -> b) -> a -> b
$ SymNat sym -> SymExpr sym (BaseBVType 8) -> LLVMVal sym
forall (w :: Natural) sym.
(1 <= w) =>
SymNat sym -> SymBV sym w -> LLVMVal sym
LLVMValInt SymNat sym
blk0 SymExpr sym (BaseBVType 8)
byte
      sym
-> EndianForm
-> MemoryOp sym w
-> ValueCtor (PartLLVMVal sym)
-> IO (PartLLVMVal sym)
forall sym (w :: Natural).
(IsSymInterface sym, HasLLVMAnn sym, 1 <= w) =>
sym
-> EndianForm
-> MemoryOp sym w
-> ValueCtor (PartLLVMVal sym)
-> IO (PartLLVMVal sym)
genValueCtor sym
sym (Mem sym -> EndianForm
forall sym. Mem sym -> EndianForm
memEndianForm Mem sym
m) MemoryOp sym w
mop
        (ValueCtor (PartLLVMVal sym) -> IO (PartLLVMVal sym))
-> IO (ValueCtor (PartLLVMVal sym)) -> IO (PartLLVMVal sym)
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< Addr
-> StorageType
-> (Addr -> IO (PartLLVMVal sym))
-> IO (ValueCtor (PartLLVMVal sym))
forall a. Addr -> StorageType -> (Addr -> IO a) -> IO (ValueCtor a)
loadTypedValueFromBytes Addr
0 StorageType
tp Addr -> IO (PartLLVMVal sym)
loadArrayByteFn
    -- Otherwise, fall back to the less-optimized read case
    Maybe
  (SymExpr sym BaseBoolType,
   SymExpr
     sym (BaseArrayType (SingleCtx (BaseBVType w)) (BaseBVType 8)),
   SymExpr sym (BaseBVType w))
_ -> sym
-> NatRepr w
-> EndianForm
-> Maybe [Char]
-> LLVMPtr sym w
-> Mem sym
-> StorageType
-> Alignment
-> MemWrites sym
-> IO (PartLLVMVal sym)
forall (w :: Natural) sym.
(1 <= w, IsSymInterface sym, HasLLVMAnn sym,
 ?memOpts::MemOptions) =>
sym
-> NatRepr w
-> EndianForm
-> Maybe [Char]
-> LLVMPtr sym w
-> Mem sym
-> StorageType
-> Alignment
-> MemWrites sym
-> IO (PartLLVMVal sym)
readMem' sym
sym NatRepr w
w (Mem sym -> EndianForm
forall sym. Mem sym -> EndianForm
memEndianForm Mem sym
m) Maybe [Char]
gsym LLVMPtr sym w
l Mem sym
m StorageType
tp Alignment
alignment (Mem sym -> MemWrites sym
forall sym. Mem sym -> MemWrites sym
memWrites Mem sym
m)

  let stack :: CallStack
stack = MemState sym -> CallStack
forall sym. MemState sym -> CallStack
getCallStack (Mem sym
m Mem sym
-> Getting (MemState sym) (Mem sym) (MemState sym) -> MemState sym
forall s a. s -> Getting a s a -> a
^. Getting (MemState sym) (Mem sym) (MemState sym)
forall sym (f :: Type -> Type).
Functor f =>
(MemState sym -> f (MemState sym)) -> Mem sym -> f (Mem sym)
memState)
  PartLLVMVal sym
part_val' <- Bool
-> (PartLLVMVal sym -> IO (PartLLVMVal sym))
-> PartLLVMVal sym
-> IO (PartLLVMVal sym)
forall (f :: Type -> Type) a.
Applicative f =>
Bool -> (a -> f a) -> a -> f a
applyUnless (MemOptions -> Bool
laxLoadsAndStores ?memOpts::MemOptions
MemOptions
?memOpts)
                           (sym
-> CallStack
-> SymExpr sym BaseBoolType
-> UndefinedBehavior (RegValue' sym)
-> PartLLVMVal sym
-> IO (PartLLVMVal sym)
forall sym.
(IsSymInterface sym, HasLLVMAnn sym) =>
sym
-> CallStack
-> Pred sym
-> UndefinedBehavior (RegValue' sym)
-> PartLLVMVal sym
-> IO (PartLLVMVal sym)
Partial.attachSideCondition sym
sym CallStack
stack 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.ReadBadAlignment (LLVMPtr sym w -> RegValue' sym (LLVMPointerType w)
forall sym (tp :: CrucibleType).
RegValue sym tp -> RegValue' sym tp
RV LLVMPtr sym w
l) Alignment
alignment))
                           PartLLVMVal sym
part_val
  Bool
-> (PartLLVMVal sym -> IO (PartLLVMVal sym))
-> PartLLVMVal sym
-> IO (PartLLVMVal sym)
forall (f :: Type -> Type) a.
Applicative f =>
Bool -> (a -> f a) -> a -> f a
applyUnless (MemOptions -> Bool
laxLoadsAndStores ?memOpts::MemOptions
MemOptions
?memOpts)
              (sym
-> SymExpr sym BaseBoolType
-> MemoryOp sym w
-> MemoryErrorReason
-> PartLLVMVal sym
-> IO (PartLLVMVal sym)
forall (w :: Natural) sym.
(1 <= w, IsSymInterface sym, HasLLVMAnn sym) =>
sym
-> Pred sym
-> MemoryOp sym w
-> MemoryErrorReason
-> PartLLVMVal sym
-> IO (PartLLVMVal sym)
Partial.attachMemoryError sym
sym SymExpr sym BaseBoolType
p1 MemoryOp sym w
mop MemoryErrorReason
UnreadableRegion)
              PartLLVMVal sym
part_val'

data CacheEntry sym w =
  CacheEntry !(StorageType) !(SymNat sym) !(SymBV sym w)

instance (TestEquality (SymExpr sym)) => Eq (CacheEntry sym w) where
  (CacheEntry StorageType
tp1 SymNat sym
blk1 SymBV sym w
off1) == :: CacheEntry sym w -> CacheEntry sym w -> Bool
== (CacheEntry StorageType
tp2 SymNat sym
blk2 SymBV sym w
off2) =
    StorageType
tp1 StorageType -> StorageType -> Bool
forall a. Eq a => a -> a -> Bool
== StorageType
tp2 Bool -> Bool -> Bool
&& (SymNat sym
blk1 SymNat sym -> SymNat sym -> Bool
forall a. Eq a => a -> a -> Bool
== SymNat sym
blk2) Bool -> Bool -> Bool
&& (Maybe ('BaseBVType w :~: 'BaseBVType w) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe ('BaseBVType w :~: 'BaseBVType w) -> Bool)
-> Maybe ('BaseBVType w :~: 'BaseBVType w) -> Bool
forall a b. (a -> b) -> a -> b
$ SymBV sym w
-> SymBV sym w -> Maybe ('BaseBVType w :~: 'BaseBVType w)
forall {k} (f :: k -> Type) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
forall (a :: BaseType) (b :: BaseType).
SymExpr sym a -> SymExpr sym b -> Maybe (a :~: b)
testEquality SymBV sym w
off1 SymBV sym w
off2)

instance IsSymInterface sym => Ord (CacheEntry sym w) where
  compare :: CacheEntry sym w -> CacheEntry sym w -> Ordering
compare (CacheEntry StorageType
tp1 SymNat sym
blk1 SymBV sym w
off1) (CacheEntry StorageType
tp2 SymNat sym
blk2 SymBV sym w
off2) =
    StorageType -> StorageType -> Ordering
forall a. Ord a => a -> a -> Ordering
compare StorageType
tp1 StorageType
tp2
      Ordering -> Ordering -> Ordering
forall a. Monoid a => a -> a -> a
`mappend` SymNat sym -> SymNat sym -> Ordering
forall a. Ord a => a -> a -> Ordering
compare SymNat sym
blk1 SymNat sym
blk2
      Ordering -> Ordering -> Ordering
forall a. Monoid a => a -> a -> a
`mappend` OrderingF ('BaseBVType w) ('BaseBVType w) -> Ordering
forall {k} (x :: k) (y :: k). OrderingF x y -> Ordering
toOrdering (SymBV sym w
-> SymBV sym w -> OrderingF ('BaseBVType w) ('BaseBVType w)
forall k (ktp :: k -> Type) (x :: k) (y :: k).
OrdF ktp =>
ktp x -> ktp y -> OrderingF x y
forall (x :: BaseType) (y :: BaseType).
SymExpr sym x -> SymExpr sym y -> OrderingF x y
compareF SymBV sym w
off1 SymBV sym w
off2)

toCacheEntry :: StorageType -> LLVMPtr sym w -> CacheEntry sym w
toCacheEntry :: forall sym (w :: Natural).
StorageType -> LLVMPtr sym w -> CacheEntry sym w
toCacheEntry StorageType
tp (LLVMPtr sym w -> (SymNat sym, SymBV sym w)
forall sym (w :: Natural).
LLVMPtr sym w -> (SymNat sym, SymBV sym w)
llvmPointerView -> (SymNat sym
blk, SymBV sym w
bv)) = StorageType -> SymNat sym -> SymBV sym w -> CacheEntry sym w
forall sym (w :: Natural).
StorageType -> SymNat sym -> SymBV sym w -> CacheEntry sym w
CacheEntry StorageType
tp SymNat sym
blk SymBV sym w
bv


-- | Read a value from memory given a list of writes.
--
-- Note that the case where a read is entirely backed by an SMT array store is
-- handled in 'readMem'.
readMem' ::
  forall w sym.
  ( 1 <= w, IsSymInterface sym, HasLLVMAnn sym
  , ?memOpts :: MemOptions ) =>
  sym ->
  NatRepr w ->
  EndianForm ->
  Maybe String ->
  LLVMPtr sym w  {- ^ Address we are reading            -} ->
  Mem sym        {- ^ The original memory state         -} ->
  StorageType    {- ^ The type to read from memory      -} ->
  Alignment      {- ^ Alignment of pointer to read from -} ->
  MemWrites sym  {- ^ List of writes                    -} ->
  IO (PartLLVMVal sym)
readMem' :: forall (w :: Natural) sym.
(1 <= w, IsSymInterface sym, HasLLVMAnn sym,
 ?memOpts::MemOptions) =>
sym
-> NatRepr w
-> EndianForm
-> Maybe [Char]
-> LLVMPtr sym w
-> Mem sym
-> StorageType
-> Alignment
-> MemWrites sym
-> IO (PartLLVMVal sym)
readMem' sym
sym NatRepr w
w EndianForm
end Maybe [Char]
gsym LLVMPtr sym w
l0 Mem sym
origMem StorageType
tp0 Alignment
alignment (MemWrites [MemWritesChunk sym]
ws) =
   do ReadMem sym (PartLLVMVal sym) -> IO (PartLLVMVal sym)
forall sym a. ReadMem sym a -> IO a
runReadMem ((StorageType -> LLVMPtr sym w -> ReadMem sym (PartLLVMVal sym))
-> LLVMPtr sym w
-> StorageType
-> [MemWrite sym]
-> [MemWritesChunk sym]
-> ReadMem sym (PartLLVMVal sym)
go StorageType -> LLVMPtr sym w -> ReadMem sym (PartLLVMVal sym)
fallback0 LLVMPtr sym w
l0 StorageType
tp0 [] [MemWritesChunk sym]
ws)
  where
    mop :: MemoryOp sym w
mop = StorageType
-> Maybe [Char] -> LLVMPtr sym w -> Mem sym -> MemoryOp sym w
forall sym (w :: Natural).
StorageType
-> Maybe [Char] -> LLVMPtr sym w -> Mem sym -> MemoryOp sym w
MemLoadOp StorageType
tp0 Maybe [Char]
gsym LLVMPtr sym w
l0 Mem sym
origMem

    fallback0 ::
      StorageType ->
      LLVMPtr sym w ->
      ReadMem sym (PartLLVMVal sym)
    fallback0 :: StorageType -> LLVMPtr sym w -> ReadMem sym (PartLLVMVal sym)
fallback0 StorageType
tp LLVMPtr sym w
_l =
      IO (PartLLVMVal sym) -> ReadMem sym (PartLLVMVal sym)
forall a. IO a -> ReadMem sym a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (PartLLVMVal sym) -> ReadMem sym (PartLLVMVal sym))
-> IO (PartLLVMVal sym) -> ReadMem sym (PartLLVMVal sym)
forall a b. (a -> b) -> a -> b
$
        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
UnstableSymbolic
        then sym -> LLVMVal sym -> PartLLVMVal sym
forall sym.
IsExprBuilder sym =>
sym -> LLVMVal sym -> PartLLVMVal sym
Partial.totalLLVMVal sym
sym (LLVMVal sym -> PartLLVMVal sym)
-> IO (LLVMVal sym) -> IO (PartLLVMVal sym)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> sym -> StorageType -> IO (LLVMVal sym)
forall sym.
IsSymInterface sym =>
sym -> StorageType -> IO (LLVMVal sym)
freshLLVMVal sym
sym StorageType
tp
        else do -- We're playing a trick here.  By making a fresh constant a proof obligation, we can be
                -- sure it always fails.  But, because it's a variable, it won't be constant-folded away
                -- and we can be relatively sure the annotation will survive.
                SymExpr sym BaseBoolType
b <- if MemOptions -> Bool
noSatisfyingWriteFreshConstant ?memOpts::MemOptions
MemOptions
?memOpts
                  then sym
-> SolverSymbol
-> BaseTypeRepr BaseBoolType
-> IO (SymExpr sym BaseBoolType)
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 ([Char] -> SolverSymbol
safeSymbol [Char]
"noSatisfyingWrite") BaseTypeRepr BaseBoolType
BaseBoolRepr
                  else 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 -> IO (SymExpr sym BaseBoolType))
-> SymExpr sym BaseBoolType -> IO (SymExpr sym BaseBoolType)
forall a b. (a -> b) -> a -> b
$ sym -> SymExpr sym BaseBoolType
forall sym. IsExprBuilder sym => sym -> Pred sym
falsePred sym
sym
                SymExpr sym BaseBoolType -> PartLLVMVal sym
forall sym. Pred sym -> PartLLVMVal sym
Partial.Err (SymExpr sym BaseBoolType -> PartLLVMVal sym)
-> IO (SymExpr sym BaseBoolType) -> IO (PartLLVMVal sym)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$>
                  sym
-> MemoryOp sym w
-> 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 w
mop (StorageType -> MemoryErrorReason
NoSatisfyingWrite StorageType
tp) SymExpr sym BaseBoolType
b

    go :: (StorageType -> LLVMPtr sym w -> ReadMem sym (PartLLVMVal sym)) ->
          LLVMPtr sym w ->
          StorageType ->
          [MemWrite sym] ->
          [MemWritesChunk sym] ->
          ReadMem sym (PartLLVMVal sym)
    go :: (StorageType -> LLVMPtr sym w -> ReadMem sym (PartLLVMVal sym))
-> LLVMPtr sym w
-> StorageType
-> [MemWrite sym]
-> [MemWritesChunk sym]
-> ReadMem sym (PartLLVMVal sym)
go StorageType -> LLVMPtr sym w -> ReadMem sym (PartLLVMVal sym)
fallback LLVMPtr sym w
l StorageType
tp [] [] = StorageType -> LLVMPtr sym w -> ReadMem sym (PartLLVMVal sym)
fallback StorageType
tp LLVMPtr sym w
l
    go StorageType -> LLVMPtr sym w -> ReadMem sym (PartLLVMVal sym)
fallback LLVMPtr sym w
l StorageType
tp [] (MemWritesChunk sym
head_chunk : [MemWritesChunk sym]
tail_chunks) =
      (StorageType -> LLVMPtr sym w -> ReadMem sym (PartLLVMVal sym))
-> LLVMPtr sym w
-> StorageType
-> [MemWrite sym]
-> [MemWritesChunk sym]
-> ReadMem sym (PartLLVMVal sym)
go StorageType -> LLVMPtr sym w -> ReadMem sym (PartLLVMVal sym)
fallback LLVMPtr sym w
l StorageType
tp (LLVMPtr sym w -> MemWritesChunk sym -> [MemWrite sym]
forall sym (w :: Natural).
IsExprBuilder sym =>
LLVMPtr sym w -> MemWritesChunk sym -> [MemWrite sym]
memWritesChunkAt LLVMPtr sym w
l MemWritesChunk sym
head_chunk) [MemWritesChunk sym]
tail_chunks
    go StorageType -> LLVMPtr sym w -> ReadMem sym (PartLLVMVal sym)
fallback LLVMPtr sym w
l StorageType
tp (MemWrite sym
h : [MemWrite sym]
r) [MemWritesChunk sym]
rest_chunks =
      do IORef (Map (CacheEntry sym w) (PartLLVMVal sym))
cache <- IO (IORef (Map (CacheEntry sym w) (PartLLVMVal sym)))
-> ReadMem sym (IORef (Map (CacheEntry sym w) (PartLLVMVal sym)))
forall a. IO a -> ReadMem sym a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (IORef (Map (CacheEntry sym w) (PartLLVMVal sym)))
 -> ReadMem sym (IORef (Map (CacheEntry sym w) (PartLLVMVal sym))))
-> IO (IORef (Map (CacheEntry sym w) (PartLLVMVal sym)))
-> ReadMem sym (IORef (Map (CacheEntry sym w) (PartLLVMVal sym)))
forall a b. (a -> b) -> a -> b
$ Map (CacheEntry sym w) (PartLLVMVal sym)
-> IO (IORef (Map (CacheEntry sym w) (PartLLVMVal sym)))
forall a. a -> IO (IORef a)
newIORef Map (CacheEntry sym w) (PartLLVMVal sym)
forall k a. Map k a
Map.empty
         let readPrev ::
               StorageType ->
               LLVMPtr sym w ->
               ReadMem sym (PartLLVMVal sym)
             readPrev :: StorageType -> LLVMPtr sym w -> ReadMem sym (PartLLVMVal sym)
readPrev StorageType
tp' LLVMPtr sym w
l' = do
               Map (CacheEntry sym w) (PartLLVMVal sym)
m <- IO (Map (CacheEntry sym w) (PartLLVMVal sym))
-> ReadMem sym (Map (CacheEntry sym w) (PartLLVMVal sym))
forall a. IO a -> ReadMem sym a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (Map (CacheEntry sym w) (PartLLVMVal sym))
 -> ReadMem sym (Map (CacheEntry sym w) (PartLLVMVal sym)))
-> IO (Map (CacheEntry sym w) (PartLLVMVal sym))
-> ReadMem sym (Map (CacheEntry sym w) (PartLLVMVal sym))
forall a b. (a -> b) -> a -> b
$ IORef (Map (CacheEntry sym w) (PartLLVMVal sym))
-> IO (Map (CacheEntry sym w) (PartLLVMVal sym))
forall a. IORef a -> IO a
readIORef IORef (Map (CacheEntry sym w) (PartLLVMVal sym))
cache
               case CacheEntry sym w
-> Map (CacheEntry sym w) (PartLLVMVal sym)
-> Maybe (PartLLVMVal sym)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (StorageType -> LLVMPtr sym w -> CacheEntry sym w
forall sym (w :: Natural).
StorageType -> LLVMPtr sym w -> CacheEntry sym w
toCacheEntry StorageType
tp' LLVMPtr sym w
l') Map (CacheEntry sym w) (PartLLVMVal sym)
m of
                 Just PartLLVMVal sym
x -> PartLLVMVal sym -> ReadMem sym (PartLLVMVal sym)
forall a. a -> ReadMem sym a
forall (m :: Type -> Type) a. Monad m => a -> m a
return PartLLVMVal sym
x
                 Maybe (PartLLVMVal sym)
Nothing -> do
                   PartLLVMVal sym
x <- (StorageType -> LLVMPtr sym w -> ReadMem sym (PartLLVMVal sym))
-> LLVMPtr sym w
-> StorageType
-> [MemWrite sym]
-> [MemWritesChunk sym]
-> ReadMem sym (PartLLVMVal sym)
go StorageType -> LLVMPtr sym w -> ReadMem sym (PartLLVMVal sym)
fallback LLVMPtr sym w
l' StorageType
tp' [MemWrite sym]
r [MemWritesChunk sym]
rest_chunks
                   IO () -> ReadMem sym ()
forall a. IO a -> ReadMem sym a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReadMem sym ()) -> IO () -> ReadMem sym ()
forall a b. (a -> b) -> a -> b
$ IORef (Map (CacheEntry sym w) (PartLLVMVal sym))
-> Map (CacheEntry sym w) (PartLLVMVal sym) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Map (CacheEntry sym w) (PartLLVMVal sym))
cache (Map (CacheEntry sym w) (PartLLVMVal sym) -> IO ())
-> Map (CacheEntry sym w) (PartLLVMVal sym) -> IO ()
forall a b. (a -> b) -> a -> b
$ CacheEntry sym w
-> PartLLVMVal sym
-> Map (CacheEntry sym w) (PartLLVMVal sym)
-> Map (CacheEntry sym w) (PartLLVMVal sym)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (StorageType -> LLVMPtr sym w -> CacheEntry sym w
forall sym (w :: Natural).
StorageType -> LLVMPtr sym w -> CacheEntry sym w
toCacheEntry StorageType
tp' LLVMPtr sym w
l') PartLLVMVal sym
x Map (CacheEntry sym w) (PartLLVMVal sym)
m
                   PartLLVMVal sym -> ReadMem sym (PartLLVMVal sym)
forall a. a -> ReadMem sym a
forall (m :: Type -> Type) a. Monad m => a -> m a
return PartLLVMVal sym
x
         case MemWrite sym
h of
           WriteMerge SymExpr sym BaseBoolType
_ (MemWrites []) (MemWrites []) ->
             (StorageType -> LLVMPtr sym w -> ReadMem sym (PartLLVMVal sym))
-> LLVMPtr sym w
-> StorageType
-> [MemWrite sym]
-> [MemWritesChunk sym]
-> ReadMem sym (PartLLVMVal sym)
go StorageType -> LLVMPtr sym w -> ReadMem sym (PartLLVMVal sym)
fallback LLVMPtr sym w
l StorageType
tp [MemWrite sym]
r [MemWritesChunk sym]
rest_chunks
           WriteMerge SymExpr sym BaseBoolType
c (MemWrites [MemWritesChunk sym]
xr) (MemWrites [MemWritesChunk sym]
yr) ->
             do PartLLVMVal sym
x <- (StorageType -> LLVMPtr sym w -> ReadMem sym (PartLLVMVal sym))
-> LLVMPtr sym w
-> StorageType
-> [MemWrite sym]
-> [MemWritesChunk sym]
-> ReadMem sym (PartLLVMVal sym)
go StorageType -> LLVMPtr sym w -> ReadMem sym (PartLLVMVal sym)
readPrev LLVMPtr sym w
l StorageType
tp [] [MemWritesChunk sym]
xr
                PartLLVMVal sym
y <- (StorageType -> LLVMPtr sym w -> ReadMem sym (PartLLVMVal sym))
-> LLVMPtr sym w
-> StorageType
-> [MemWrite sym]
-> [MemWritesChunk sym]
-> ReadMem sym (PartLLVMVal sym)
go StorageType -> LLVMPtr sym w -> ReadMem sym (PartLLVMVal sym)
readPrev LLVMPtr sym w
l StorageType
tp [] [MemWritesChunk sym]
yr
                IO (PartLLVMVal sym) -> ReadMem sym (PartLLVMVal sym)
forall a. IO a -> ReadMem sym a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (PartLLVMVal sym) -> ReadMem sym (PartLLVMVal sym))
-> IO (PartLLVMVal sym) -> ReadMem sym (PartLLVMVal sym)
forall a b. (a -> b) -> a -> b
$ sym
-> SymExpr sym BaseBoolType
-> PartLLVMVal sym
-> PartLLVMVal sym
-> IO (PartLLVMVal sym)
forall sym.
(IsSymInterface sym, HasLLVMAnn sym) =>
sym
-> Pred sym
-> PartLLVMVal sym
-> PartLLVMVal sym
-> IO (PartLLVMVal sym)
Partial.muxLLVMVal sym
sym SymExpr sym BaseBoolType
c PartLLVMVal sym
x PartLLVMVal sym
y
           MemWrite LLVMPtr sym w
dst WriteSource sym w
wsrc ->
             case 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 (LLVMPtr sym w -> NatRepr w
forall sym (w :: Natural).
IsExprBuilder sym =>
LLVMPtr sym w -> NatRepr w
ptrWidth LLVMPtr sym w
dst) NatRepr w
w of
               Maybe (w :~: w)
Nothing   -> StorageType -> LLVMPtr sym w -> ReadMem sym (PartLLVMVal sym)
readPrev StorageType
tp LLVMPtr sym w
l
               Just w :~: w
Refl ->
                 do let LLVMPointer SymNat sym
blk1 SymBV sym w
_ = LLVMPtr sym w
l
                    let LLVMPointer SymNat sym
blk2 SymBV sym w
d = LLVMPtr sym w
dst
                    let readCurrent :: ReadMem sym (PartLLVMVal sym)
readCurrent =
                          case WriteSource sym w
wsrc of
                            MemCopy LLVMPtr sym w
src SymBV sym w
sz -> sym
-> NatRepr w
-> EndianForm
-> MemoryOp sym w
-> LLVMPtr sym w
-> StorageType
-> SymBV sym w
-> LLVMPtr sym w
-> SymBV sym w
-> (StorageType -> LLVMPtr sym w -> ReadMem sym (PartLLVMVal sym))
-> ReadMem sym (PartLLVMVal sym)
forall sym (w :: Natural).
(1 <= w, IsSymInterface sym, HasLLVMAnn sym) =>
sym
-> NatRepr w
-> EndianForm
-> MemoryOp sym w
-> LLVMPtr sym w
-> StorageType
-> SymBV sym w
-> LLVMPtr sym w
-> SymBV sym w
-> (StorageType -> LLVMPtr sym w -> ReadMem sym (PartLLVMVal sym))
-> ReadMem sym (PartLLVMVal sym)
readMemCopy sym
sym NatRepr w
w EndianForm
end MemoryOp sym w
mop LLVMPtr sym w
l StorageType
tp SymBV sym w
d LLVMPtr sym w
LLVMPtr sym w
src SymBV sym w
SymBV sym w
sz StorageType -> LLVMPtr sym w -> ReadMem sym (PartLLVMVal sym)
readPrev
                            MemSet SymBV sym 8
v SymBV sym w
sz    -> sym
-> NatRepr w
-> EndianForm
-> MemoryOp sym w
-> LLVMPtr sym w
-> StorageType
-> SymBV sym w
-> SymBV sym 8
-> SymBV sym w
-> (StorageType -> LLVMPtr sym w -> ReadMem sym (PartLLVMVal sym))
-> ReadMem sym (PartLLVMVal sym)
forall sym (w :: Natural).
(1 <= w, IsSymInterface sym, HasLLVMAnn sym) =>
sym
-> NatRepr w
-> EndianForm
-> MemoryOp sym w
-> LLVMPtr sym w
-> StorageType
-> SymBV sym w
-> SymBV sym 8
-> SymBV sym w
-> (StorageType -> LLVMPtr sym w -> ReadMem sym (PartLLVMVal sym))
-> ReadMem sym (PartLLVMVal sym)
readMemSet sym
sym NatRepr w
w EndianForm
end MemoryOp sym w
mop LLVMPtr sym w
l StorageType
tp SymBV sym w
d SymBV sym 8
v SymBV sym w
SymBV sym w
sz StorageType -> LLVMPtr sym w -> ReadMem sym (PartLLVMVal sym)
readPrev
                            MemStore LLVMVal sym
v StorageType
stp Alignment
storeAlign -> sym
-> NatRepr w
-> EndianForm
-> MemoryOp sym w
-> LLVMPtr sym w
-> StorageType
-> SymBV sym w
-> LLVMVal sym
-> StorageType
-> Alignment
-> Alignment
-> (StorageType -> LLVMPtr sym w -> ReadMem sym (PartLLVMVal sym))
-> ReadMem sym (PartLLVMVal sym)
forall sym (w :: Natural).
(1 <= w, IsSymInterface sym, HasLLVMAnn sym) =>
sym
-> NatRepr w
-> EndianForm
-> MemoryOp sym w
-> LLVMPtr sym w
-> StorageType
-> SymBV sym w
-> LLVMVal sym
-> StorageType
-> Alignment
-> Alignment
-> (StorageType -> LLVMPtr sym w -> ReadMem sym (PartLLVMVal sym))
-> ReadMem sym (PartLLVMVal sym)
readMemStore sym
sym NatRepr w
w EndianForm
end MemoryOp sym w
mop LLVMPtr sym w
l StorageType
tp SymBV sym w
d LLVMVal sym
v StorageType
stp Alignment
alignment Alignment
storeAlign StorageType -> LLVMPtr sym w -> ReadMem sym (PartLLVMVal sym)
readPrev
                            MemArrayStore SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)
arr Maybe (SymBV sym w)
sz -> sym
-> NatRepr w
-> EndianForm
-> MemoryOp sym w
-> LLVMPtr sym w
-> StorageType
-> SymBV sym w
-> SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)
-> Maybe (SymBV sym w)
-> (StorageType -> LLVMPtr sym w -> ReadMem sym (PartLLVMVal sym))
-> ReadMem sym (PartLLVMVal sym)
forall sym (w :: Natural).
(1 <= w, IsSymInterface sym, HasLLVMAnn sym) =>
sym
-> NatRepr w
-> EndianForm
-> MemoryOp sym w
-> LLVMPtr sym w
-> StorageType
-> SymBV sym w
-> SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)
-> Maybe (SymBV sym w)
-> (StorageType -> LLVMPtr sym w -> ReadMem sym (PartLLVMVal sym))
-> ReadMem sym (PartLLVMVal sym)
readMemArrayStore sym
sym NatRepr w
w EndianForm
end MemoryOp sym w
mop LLVMPtr sym w
l StorageType
tp SymBV sym w
d SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)
SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)
arr Maybe (SymBV sym w)
Maybe (SymBV sym w)
sz StorageType -> LLVMPtr sym w -> ReadMem sym (PartLLVMVal sym)
readPrev
                            MemInvalidate Text
msg SymBV sym w
sz -> sym
-> NatRepr w
-> EndianForm
-> MemoryOp sym w
-> LLVMPtr sym w
-> StorageType
-> SymBV sym w
-> Text
-> SymBV sym w
-> (StorageType -> LLVMPtr sym w -> ReadMem sym (PartLLVMVal sym))
-> ReadMem sym (PartLLVMVal sym)
forall sym (w :: Natural).
(1 <= w, IsSymInterface sym, HasLLVMAnn sym,
 ?memOpts::MemOptions) =>
sym
-> NatRepr w
-> EndianForm
-> MemoryOp sym w
-> LLVMPtr sym w
-> StorageType
-> SymBV sym w
-> Text
-> SymBV sym w
-> (StorageType -> LLVMPtr sym w -> ReadMem sym (PartLLVMVal sym))
-> ReadMem sym (PartLLVMVal sym)
readMemInvalidate sym
sym NatRepr w
w EndianForm
end MemoryOp sym w
mop LLVMPtr sym w
l StorageType
tp SymBV sym w
d Text
msg SymBV sym w
SymBV sym w
sz StorageType -> LLVMPtr sym w -> ReadMem sym (PartLLVMVal sym)
readPrev
                    SymExpr sym BaseBoolType
sameBlock <- IO (SymExpr sym BaseBoolType)
-> ReadMem sym (SymExpr sym BaseBoolType)
forall a. IO a -> ReadMem sym a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (SymExpr sym BaseBoolType)
 -> ReadMem sym (SymExpr sym BaseBoolType))
-> IO (SymExpr sym BaseBoolType)
-> ReadMem sym (SymExpr sym BaseBoolType)
forall a b. (a -> b) -> a -> b
$ sym -> SymNat sym -> SymNat sym -> IO (SymExpr sym BaseBoolType)
forall sym.
IsExprBuilder sym =>
sym -> SymNat sym -> SymNat sym -> IO (Pred sym)
natEq sym
sym SymNat sym
blk1 SymNat sym
blk2
                    case SymExpr sym BaseBoolType -> Maybe Bool
forall (e :: BaseType -> Type).
IsExpr e =>
e BaseBoolType -> Maybe Bool
asConstantPred SymExpr sym BaseBoolType
sameBlock of
                      Just Bool
True  -> do
                        PartLLVMVal sym
result <- ReadMem sym (PartLLVMVal sym)
readCurrent
                        PartLLVMVal sym -> ReadMem sym (PartLLVMVal sym)
forall a. a -> ReadMem sym a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure PartLLVMVal sym
result
                      Just Bool
False -> StorageType -> LLVMPtr sym w -> ReadMem sym (PartLLVMVal sym)
readPrev StorageType
tp LLVMPtr sym w
l
                      Maybe Bool
Nothing ->
                        do PartLLVMVal sym
x <- ReadMem sym (PartLLVMVal sym)
readCurrent
                           PartLLVMVal sym
y <- StorageType -> LLVMPtr sym w -> ReadMem sym (PartLLVMVal sym)
readPrev StorageType
tp LLVMPtr sym w
l
                           IO (PartLLVMVal sym) -> ReadMem sym (PartLLVMVal sym)
forall a. IO a -> ReadMem sym a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (PartLLVMVal sym) -> ReadMem sym (PartLLVMVal sym))
-> IO (PartLLVMVal sym) -> ReadMem sym (PartLLVMVal sym)
forall a b. (a -> b) -> a -> b
$ sym
-> SymExpr sym BaseBoolType
-> PartLLVMVal sym
-> PartLLVMVal sym
-> IO (PartLLVMVal sym)
forall sym.
(IsSymInterface sym, HasLLVMAnn sym) =>
sym
-> Pred sym
-> PartLLVMVal sym
-> PartLLVMVal sym
-> IO (PartLLVMVal sym)
Partial.muxLLVMVal sym
sym SymExpr sym BaseBoolType
sameBlock PartLLVMVal sym
x PartLLVMVal sym
y

--------------------------------------------------------------------------------

-- | Dummy newtype for now...
--   It may be useful later to add additional plumbing
--   to this monad.
newtype ReadMem sym a = ReadMem { forall sym a. ReadMem sym a -> IO a
runReadMem :: IO a }
  deriving (Functor (ReadMem sym)
Functor (ReadMem sym) =>
(forall a. a -> ReadMem sym a)
-> (forall a b.
    ReadMem sym (a -> b) -> ReadMem sym a -> ReadMem sym b)
-> (forall a b c.
    (a -> b -> c) -> ReadMem sym a -> ReadMem sym b -> ReadMem sym c)
-> (forall a b. ReadMem sym a -> ReadMem sym b -> ReadMem sym b)
-> (forall a b. ReadMem sym a -> ReadMem sym b -> ReadMem sym a)
-> Applicative (ReadMem sym)
forall sym. Functor (ReadMem sym)
forall a. a -> ReadMem sym a
forall sym a. a -> ReadMem sym a
forall a b. ReadMem sym a -> ReadMem sym b -> ReadMem sym a
forall a b. ReadMem sym a -> ReadMem sym b -> ReadMem sym b
forall a b. ReadMem sym (a -> b) -> ReadMem sym a -> ReadMem sym b
forall sym a b. ReadMem sym a -> ReadMem sym b -> ReadMem sym a
forall sym a b. ReadMem sym a -> ReadMem sym b -> ReadMem sym b
forall sym a b.
ReadMem sym (a -> b) -> ReadMem sym a -> ReadMem sym b
forall a b c.
(a -> b -> c) -> ReadMem sym a -> ReadMem sym b -> ReadMem sym c
forall sym a b c.
(a -> b -> c) -> ReadMem sym a -> ReadMem sym b -> ReadMem sym c
forall (f :: Type -> Type).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall sym a. a -> ReadMem sym a
pure :: forall a. a -> ReadMem sym a
$c<*> :: forall sym a b.
ReadMem sym (a -> b) -> ReadMem sym a -> ReadMem sym b
<*> :: forall a b. ReadMem sym (a -> b) -> ReadMem sym a -> ReadMem sym b
$cliftA2 :: forall sym a b c.
(a -> b -> c) -> ReadMem sym a -> ReadMem sym b -> ReadMem sym c
liftA2 :: forall a b c.
(a -> b -> c) -> ReadMem sym a -> ReadMem sym b -> ReadMem sym c
$c*> :: forall sym a b. ReadMem sym a -> ReadMem sym b -> ReadMem sym b
*> :: forall a b. ReadMem sym a -> ReadMem sym b -> ReadMem sym b
$c<* :: forall sym a b. ReadMem sym a -> ReadMem sym b -> ReadMem sym a
<* :: forall a b. ReadMem sym a -> ReadMem sym b -> ReadMem sym a
Applicative, (forall a b. (a -> b) -> ReadMem sym a -> ReadMem sym b)
-> (forall a b. a -> ReadMem sym b -> ReadMem sym a)
-> Functor (ReadMem sym)
forall a b. a -> ReadMem sym b -> ReadMem sym a
forall a b. (a -> b) -> ReadMem sym a -> ReadMem sym b
forall sym a b. a -> ReadMem sym b -> ReadMem sym a
forall sym a b. (a -> b) -> ReadMem sym a -> ReadMem sym b
forall (f :: Type -> Type).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall sym a b. (a -> b) -> ReadMem sym a -> ReadMem sym b
fmap :: forall a b. (a -> b) -> ReadMem sym a -> ReadMem sym b
$c<$ :: forall sym a b. a -> ReadMem sym b -> ReadMem sym a
<$ :: forall a b. a -> ReadMem sym b -> ReadMem sym a
Functor, Applicative (ReadMem sym)
Applicative (ReadMem sym) =>
(forall a b.
 ReadMem sym a -> (a -> ReadMem sym b) -> ReadMem sym b)
-> (forall a b. ReadMem sym a -> ReadMem sym b -> ReadMem sym b)
-> (forall a. a -> ReadMem sym a)
-> Monad (ReadMem sym)
forall sym. Applicative (ReadMem sym)
forall a. a -> ReadMem sym a
forall sym a. a -> ReadMem sym a
forall a b. ReadMem sym a -> ReadMem sym b -> ReadMem sym b
forall a b. ReadMem sym a -> (a -> ReadMem sym b) -> ReadMem sym b
forall sym a b. ReadMem sym a -> ReadMem sym b -> ReadMem sym b
forall sym a b.
ReadMem sym a -> (a -> ReadMem sym b) -> ReadMem sym b
forall (m :: Type -> Type).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall sym a b.
ReadMem sym a -> (a -> ReadMem sym b) -> ReadMem sym b
>>= :: forall a b. ReadMem sym a -> (a -> ReadMem sym b) -> ReadMem sym b
$c>> :: forall sym a b. ReadMem sym a -> ReadMem sym b -> ReadMem sym b
>> :: forall a b. ReadMem sym a -> ReadMem sym b -> ReadMem sym b
$creturn :: forall sym a. a -> ReadMem sym a
return :: forall a. a -> ReadMem sym a
Monad, Monad (ReadMem sym)
Monad (ReadMem sym) =>
(forall a. IO a -> ReadMem sym a) -> MonadIO (ReadMem sym)
forall sym. Monad (ReadMem sym)
forall a. IO a -> ReadMem sym a
forall sym a. IO a -> ReadMem sym a
forall (m :: Type -> Type).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
$cliftIO :: forall sym a. IO a -> ReadMem sym a
liftIO :: forall a. IO a -> ReadMem sym a
MonadIO)


--------------------------------------------------------------------------------

memWritesSize :: MemWrites sym -> Int
memWritesSize :: forall sym. MemWrites sym -> Int
memWritesSize (MemWrites [MemWritesChunk sym]
writes) = Sum Int -> Int
forall a. Sum a -> a
getSum (Sum Int -> Int) -> Sum Int -> Int
forall a b. (a -> b) -> a -> b
$ (MemWritesChunk sym -> Sum Int) -> [MemWritesChunk sym] -> Sum Int
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: Type -> Type) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap
  (\case
    MemWritesChunkIndexed IntMap [MemWrite sym]
indexed_writes ->
      ([MemWrite sym] -> Sum Int) -> IntMap [MemWrite sym] -> Sum Int
forall m a. Monoid m => (a -> m) -> IntMap a -> m
forall (t :: Type -> Type) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Int -> Sum Int
forall a. a -> Sum a
Sum (Int -> Sum Int)
-> ([MemWrite sym] -> Int) -> [MemWrite sym] -> Sum Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [MemWrite sym] -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length) IntMap [MemWrite sym]
indexed_writes
    MemWritesChunkFlat [MemWrite sym]
flat_writes -> Int -> Sum Int
forall a. a -> Sum a
Sum (Int -> Sum Int) -> Int -> Sum Int
forall a b. (a -> b) -> a -> b
$ [MemWrite sym] -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [MemWrite sym]
flat_writes)
  [MemWritesChunk sym]
writes

muxChanges :: IsExpr (SymExpr sym) => Pred sym -> MemChanges sym -> MemChanges sym -> MemChanges sym
muxChanges :: forall sym.
IsExpr (SymExpr sym) =>
Pred sym -> MemChanges sym -> MemChanges sym -> MemChanges sym
muxChanges Pred sym
c (MemAllocs sym
left_allocs, MemWrites sym
lhs_writes) (MemAllocs sym
rhs_allocs, MemWrites sym
rhs_writes) =
  ( Pred sym -> MemAllocs sym -> MemAllocs sym -> MemAllocs sym
forall sym.
IsExpr (SymExpr sym) =>
Pred sym -> MemAllocs sym -> MemAllocs sym -> MemAllocs sym
muxMemAllocs Pred sym
c MemAllocs sym
left_allocs MemAllocs sym
rhs_allocs
  , Pred sym -> MemWrites sym -> MemWrites sym -> MemWrites sym
forall sym.
IsExpr (SymExpr sym) =>
Pred sym -> MemWrites sym -> MemWrites sym -> MemWrites sym
muxWrites Pred sym
c MemWrites sym
lhs_writes MemWrites sym
rhs_writes
  )

muxWrites :: IsExpr (SymExpr sym) => Pred sym -> MemWrites sym -> MemWrites sym -> MemWrites sym
muxWrites :: forall sym.
IsExpr (SymExpr sym) =>
Pred sym -> MemWrites sym -> MemWrites sym -> MemWrites sym
muxWrites Pred sym
_ (MemWrites []) (MemWrites []) = [MemWritesChunk sym] -> MemWrites sym
forall sym. [MemWritesChunk sym] -> MemWrites sym
MemWrites []

muxWrites Pred sym
c MemWrites sym
lhs_writes MemWrites sym
rhs_writes
  | Just Bool
b <- Pred sym -> Maybe Bool
forall (e :: BaseType -> Type).
IsExpr e =>
e BaseBoolType -> Maybe Bool
asConstantPred Pred sym
c = if Bool
b then MemWrites sym
lhs_writes else MemWrites sym
rhs_writes

muxWrites Pred sym
c MemWrites sym
lhs_writes MemWrites sym
rhs_writes
  | Just IntMap [MemWrite sym]
lhs_indexed_writes <- MemWrites sym -> Maybe (IntMap [MemWrite sym])
forall sym. MemWrites sym -> Maybe (IntMap [MemWrite sym])
asIndexedChunkMap MemWrites sym
lhs_writes
  , Just IntMap [MemWrite sym]
rhs_indexed_writes <- MemWrites sym -> Maybe (IntMap [MemWrite sym])
forall sym. MemWrites sym -> Maybe (IntMap [MemWrite sym])
asIndexedChunkMap MemWrites sym
rhs_writes =
      [MemWritesChunk sym] -> MemWrites sym
forall sym. [MemWritesChunk sym] -> MemWrites sym
MemWrites
        [ IntMap [MemWrite sym] -> MemWritesChunk sym
forall sym. IntMap [MemWrite sym] -> MemWritesChunk sym
MemWritesChunkIndexed (IntMap [MemWrite sym] -> MemWritesChunk sym)
-> IntMap [MemWrite sym] -> MemWritesChunk sym
forall a b. (a -> b) -> a -> b
$
            ([MemWrite sym] -> [MemWrite sym] -> [MemWrite sym])
-> IntMap [MemWrite sym]
-> IntMap [MemWrite sym]
-> IntMap [MemWrite sym]
forall sym.
([MemWrite sym] -> [MemWrite sym] -> [MemWrite sym])
-> IntMap [MemWrite sym]
-> IntMap [MemWrite sym]
-> IntMap [MemWrite sym]
mergeMemWritesChunkIndexed
              (\[MemWrite sym]
lhs [MemWrite sym]
rhs ->
                 [ Pred sym -> MemWrites sym -> MemWrites sym -> MemWrite sym
forall sym.
Pred sym -> MemWrites sym -> MemWrites sym -> MemWrite sym
WriteMerge
                     Pred sym
c
                     ([MemWritesChunk sym] -> MemWrites sym
forall sym. [MemWritesChunk sym] -> MemWrites sym
MemWrites [[MemWrite sym] -> MemWritesChunk sym
forall sym. [MemWrite sym] -> MemWritesChunk sym
MemWritesChunkFlat [MemWrite sym]
lhs])
                     ([MemWritesChunk sym] -> MemWrites sym
forall sym. [MemWritesChunk sym] -> MemWrites sym
MemWrites [[MemWrite sym] -> MemWritesChunk sym
forall sym. [MemWrite sym] -> MemWritesChunk sym
MemWritesChunkFlat [MemWrite sym]
rhs])
                 ])
              IntMap [MemWrite sym]
lhs_indexed_writes
              IntMap [MemWrite sym]
rhs_indexed_writes
        ]
  | Bool
otherwise =
    [MemWritesChunk sym] -> MemWrites sym
forall sym. [MemWritesChunk sym] -> MemWrites sym
MemWrites [[MemWrite sym] -> MemWritesChunk sym
forall sym. [MemWrite sym] -> MemWritesChunk sym
MemWritesChunkFlat [Pred sym -> MemWrites sym -> MemWrites sym -> MemWrite sym
forall sym.
Pred sym -> MemWrites sym -> MemWrites sym -> MemWrite sym
WriteMerge Pred sym
c MemWrites sym
lhs_writes MemWrites sym
rhs_writes]]
  where asIndexedChunkMap :: MemWrites sym -> Maybe (IntMap [MemWrite sym])
        asIndexedChunkMap :: forall sym. MemWrites sym -> Maybe (IntMap [MemWrite sym])
asIndexedChunkMap (MemWrites [MemWritesChunkIndexed IntMap [MemWrite sym]
m]) = IntMap [MemWrite sym] -> Maybe (IntMap [MemWrite sym])
forall a. a -> Maybe a
Just IntMap [MemWrite sym]
m
        asIndexedChunkMap (MemWrites []) = IntMap [MemWrite sym] -> Maybe (IntMap [MemWrite sym])
forall a. a -> Maybe a
Just IntMap [MemWrite sym]
forall a. IntMap a
IntMap.empty
        asIndexedChunkMap MemWrites sym
_ = Maybe (IntMap [MemWrite sym])
forall a. Maybe a
Nothing

mergeMemWritesChunkIndexed ::
  ([MemWrite sym] -> [MemWrite sym] -> [MemWrite sym]) ->
  IntMap [MemWrite sym] ->
  IntMap [MemWrite sym] ->
  IntMap [MemWrite sym]
mergeMemWritesChunkIndexed :: forall sym.
([MemWrite sym] -> [MemWrite sym] -> [MemWrite sym])
-> IntMap [MemWrite sym]
-> IntMap [MemWrite sym]
-> IntMap [MemWrite sym]
mergeMemWritesChunkIndexed [MemWrite sym] -> [MemWrite sym] -> [MemWrite sym]
merge_func = (Int -> [MemWrite sym] -> [MemWrite sym] -> Maybe [MemWrite sym])
-> (IntMap [MemWrite sym] -> IntMap [MemWrite sym])
-> (IntMap [MemWrite sym] -> IntMap [MemWrite sym])
-> IntMap [MemWrite sym]
-> IntMap [MemWrite sym]
-> IntMap [MemWrite sym]
forall a b c.
(Int -> a -> b -> Maybe c)
-> (IntMap a -> IntMap c)
-> (IntMap b -> IntMap c)
-> IntMap a
-> IntMap b
-> IntMap c
IntMap.mergeWithKey
  (\Int
_ [MemWrite sym]
lhs_alloc_writes [MemWrite sym]
rhs_alloc_writes -> [MemWrite sym] -> Maybe [MemWrite sym]
forall a. a -> Maybe a
Just ([MemWrite sym] -> Maybe [MemWrite sym])
-> [MemWrite sym] -> Maybe [MemWrite sym]
forall a b. (a -> b) -> a -> b
$
    [MemWrite sym] -> [MemWrite sym] -> [MemWrite sym]
merge_func [MemWrite sym]
lhs_alloc_writes [MemWrite sym]
rhs_alloc_writes)
  (([MemWrite sym] -> [MemWrite sym])
-> IntMap [MemWrite sym] -> IntMap [MemWrite sym]
forall a b. (a -> b) -> IntMap a -> IntMap b
IntMap.map (([MemWrite sym] -> [MemWrite sym])
 -> IntMap [MemWrite sym] -> IntMap [MemWrite sym])
-> ([MemWrite sym] -> [MemWrite sym])
-> IntMap [MemWrite sym]
-> IntMap [MemWrite sym]
forall a b. (a -> b) -> a -> b
$ \[MemWrite sym]
lhs_alloc_writes -> [MemWrite sym] -> [MemWrite sym] -> [MemWrite sym]
merge_func [MemWrite sym]
lhs_alloc_writes [])
  (([MemWrite sym] -> [MemWrite sym])
-> IntMap [MemWrite sym] -> IntMap [MemWrite sym]
forall a b. (a -> b) -> IntMap a -> IntMap b
IntMap.map (([MemWrite sym] -> [MemWrite sym])
 -> IntMap [MemWrite sym] -> IntMap [MemWrite sym])
-> ([MemWrite sym] -> [MemWrite sym])
-> IntMap [MemWrite sym]
-> IntMap [MemWrite sym]
forall a b. (a -> b) -> a -> b
$ \[MemWrite sym]
rhs_alloc_writes -> [MemWrite sym] -> [MemWrite sym] -> [MemWrite sym]
merge_func [] [MemWrite sym]
rhs_alloc_writes)

memChanges :: Monoid m => (MemChanges sym -> m) -> Mem sym -> m
memChanges :: forall m sym. Monoid m => (MemChanges sym -> m) -> Mem sym -> m
memChanges MemChanges sym -> m
f Mem sym
m = MemState sym -> m
go (Mem sym
mMem sym
-> Getting (MemState sym) (Mem sym) (MemState sym) -> MemState sym
forall s a. s -> Getting a s a -> a
^.Getting (MemState sym) (Mem sym) (MemState sym)
forall sym (f :: Type -> Type).
Functor f =>
(MemState sym -> f (MemState sym)) -> Mem sym -> f (Mem sym)
memState)
  where go :: MemState sym -> m
go (EmptyMem Int
_ Int
_ MemChanges sym
l)      = MemChanges sym -> m
f MemChanges sym
l
        go (StackFrame Int
_ Int
_ Text
_ MemChanges sym
l MemState sym
s)  = MemChanges sym -> m
f MemChanges sym
l m -> m -> m
forall a. Semigroup a => a -> a -> a
<> MemState sym -> m
go MemState sym
s
        go (BranchFrame Int
_ Int
_ MemChanges sym
l MemState sym
s) = MemChanges sym -> m
f MemChanges sym
l m -> m -> m
forall a. Semigroup a => a -> a -> a
<> MemState sym -> m
go MemState sym
s

memAllocs :: Mem sym -> MemAllocs sym
memAllocs :: forall sym. Mem sym -> MemAllocs sym
memAllocs = (MemChanges sym -> MemAllocs sym) -> Mem sym -> MemAllocs sym
forall m sym. Monoid m => (MemChanges sym -> m) -> Mem sym -> m
memChanges MemChanges sym -> MemAllocs sym
forall a b. (a, b) -> a
fst

memWrites :: Mem sym -> MemWrites sym
memWrites :: forall sym. Mem sym -> MemWrites sym
memWrites = (MemChanges sym -> MemWrites sym) -> Mem sym -> MemWrites sym
forall m sym. Monoid m => (MemChanges sym -> m) -> Mem sym -> m
memChanges MemChanges sym -> MemWrites sym
forall a b. (a, b) -> b
snd

memWritesChunkAt ::
  IsExprBuilder sym =>
  LLVMPtr sym w ->
  MemWritesChunk sym ->
  [MemWrite sym]
memWritesChunkAt :: forall sym (w :: Natural).
IsExprBuilder sym =>
LLVMPtr sym w -> MemWritesChunk sym -> [MemWrite sym]
memWritesChunkAt LLVMPtr sym w
ptr = \case
  MemWritesChunkIndexed IntMap [MemWrite sym]
indexed_writes
    | Just Natural
blk <- SymNat sym -> Maybe Natural
forall sym. IsExpr (SymExpr sym) => SymNat sym -> Maybe Natural
asNat (LLVMPtr sym w -> SymNat sym
forall sym (w :: Natural). LLVMPtr sym w -> SymNat sym
llvmPointerBlock LLVMPtr sym w
ptr) ->
      [MemWrite sym] -> Int -> IntMap [MemWrite sym] -> [MemWrite sym]
forall a. a -> Int -> IntMap a -> a
IntMap.findWithDefault [] (Natural -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
blk) IntMap [MemWrite sym]
indexed_writes
    | Bool
otherwise -> ([MemWrite sym] -> [MemWrite sym] -> [MemWrite sym])
-> [MemWrite sym] -> IntMap [MemWrite sym] -> [MemWrite sym]
forall a b. (a -> b -> b) -> b -> IntMap a -> b
IntMap.foldr [MemWrite sym] -> [MemWrite sym] -> [MemWrite sym]
forall a. [a] -> [a] -> [a]
(++) [] IntMap [MemWrite sym]
indexed_writes
  MemWritesChunkFlat [MemWrite sym]
flat_writes -> [MemWrite sym]
flat_writes

memWritesAtConstant :: Natural -> MemWrites sym -> [MemWrite sym]
memWritesAtConstant :: forall sym. Natural -> MemWrites sym -> [MemWrite sym]
memWritesAtConstant Natural
blk (MemWrites [MemWritesChunk sym]
writes) = (MemWritesChunk sym -> [MemWrite sym])
-> [MemWritesChunk sym] -> [MemWrite sym]
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: Type -> Type) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap
  (\case
    MemWritesChunkIndexed IntMap [MemWrite sym]
indexed_writes ->
      [MemWrite sym] -> Int -> IntMap [MemWrite sym] -> [MemWrite sym]
forall a. a -> Int -> IntMap a -> a
IntMap.findWithDefault [] (Natural -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
blk) IntMap [MemWrite sym]
indexed_writes
    MemWritesChunkFlat [MemWrite sym]
flat_writes -> [MemWrite sym]
flat_writes)
  [MemWritesChunk sym]
writes

memStateAllocCount :: MemState sym -> Int
memStateAllocCount :: forall sym. MemState sym -> Int
memStateAllocCount MemState sym
s = case MemState sym
s of
  EmptyMem Int
ac Int
_ MemChanges sym
_ -> Int
ac
  StackFrame Int
ac Int
_ Text
_ MemChanges sym
_ MemState sym
_ -> Int
ac
  BranchFrame Int
ac Int
_ MemChanges sym
_ MemState sym
_ -> Int
ac

memStateWriteCount :: MemState sym -> Int
memStateWriteCount :: forall sym. MemState sym -> Int
memStateWriteCount MemState sym
s = case MemState sym
s of
  EmptyMem Int
_ Int
wc MemChanges sym
_ -> Int
wc
  StackFrame Int
_ Int
wc Text
_ MemChanges sym
_ MemState sym
_ -> Int
wc
  BranchFrame Int
_ Int
wc MemChanges sym
_ MemState sym
_ -> Int
wc

memAllocCount :: Mem sym -> Int
memAllocCount :: forall sym. Mem sym -> Int
memAllocCount Mem sym
m = MemState sym -> Int
forall sym. MemState sym -> Int
memStateAllocCount (Mem sym
m Mem sym
-> Getting (MemState sym) (Mem sym) (MemState sym) -> MemState sym
forall s a. s -> Getting a s a -> a
^. Getting (MemState sym) (Mem sym) (MemState sym)
forall sym (f :: Type -> Type).
Functor f =>
(MemState sym -> f (MemState sym)) -> Mem sym -> f (Mem sym)
memState)

memWriteCount :: Mem sym -> Int
memWriteCount :: forall sym. Mem sym -> Int
memWriteCount Mem sym
m = MemState sym -> Int
forall sym. MemState sym -> Int
memStateWriteCount (Mem sym
m Mem sym
-> Getting (MemState sym) (Mem sym) (MemState sym) -> MemState sym
forall s a. s -> Getting a s a -> a
^. Getting (MemState sym) (Mem sym) (MemState sym)
forall sym (f :: Type -> Type).
Functor f =>
(MemState sym -> f (MemState sym)) -> Mem sym -> f (Mem sym)
memState)

memAddAlloc :: (MemAllocs sym -> MemAllocs sym) -> Mem sym -> Mem sym
memAddAlloc :: forall sym. (MemAllocs sym -> MemAllocs sym) -> Mem sym -> Mem sym
memAddAlloc MemAllocs sym -> MemAllocs sym
f = (MemState sym -> Identity (MemState sym))
-> Mem sym -> Identity (Mem sym)
forall sym (f :: Type -> Type).
Functor f =>
(MemState sym -> f (MemState sym)) -> Mem sym -> f (Mem sym)
memState ((MemState sym -> Identity (MemState sym))
 -> Mem sym -> Identity (Mem sym))
-> (MemState sym -> MemState sym) -> Mem sym -> Mem sym
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ \case
  EmptyMem Int
ac Int
wc (MemAllocs sym
a, MemWrites sym
w) -> Int -> Int -> (MemAllocs sym, MemWrites sym) -> MemState sym
forall sym. Int -> Int -> MemChanges sym -> MemState sym
EmptyMem (Int
acInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Int
wc (MemAllocs sym -> MemAllocs sym
f MemAllocs sym
a, MemWrites sym
w)
  StackFrame Int
ac Int
wc Text
nm (MemAllocs sym
a, MemWrites sym
w) MemState sym
s -> Int
-> Int
-> Text
-> (MemAllocs sym, MemWrites sym)
-> MemState sym
-> MemState sym
forall sym.
Int
-> Int -> Text -> MemChanges sym -> MemState sym -> MemState sym
StackFrame (Int
acInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Int
wc Text
nm (MemAllocs sym -> MemAllocs sym
f MemAllocs sym
a, MemWrites sym
w) MemState sym
s
  BranchFrame Int
ac Int
wc (MemAllocs sym
a, MemWrites sym
w) MemState sym
s -> Int
-> Int
-> (MemAllocs sym, MemWrites sym)
-> MemState sym
-> MemState sym
forall sym.
Int -> Int -> MemChanges sym -> MemState sym -> MemState sym
BranchFrame (Int
acInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Int
wc (MemAllocs sym -> MemAllocs sym
f MemAllocs sym
a, MemWrites sym
w) MemState sym
s

memAddWrite ::
  (IsExprBuilder sym, 1 <= w) =>
  LLVMPtr sym w ->
  WriteSource sym w ->
  Mem sym ->
  Mem sym
memAddWrite :: forall sym (w :: Natural).
(IsExprBuilder sym, 1 <= w) =>
LLVMPtr sym w -> WriteSource sym w -> Mem sym -> Mem sym
memAddWrite LLVMPtr sym w
ptr WriteSource sym w
src = do
  let single_write :: MemWrites sym
single_write = LLVMPtr sym w -> WriteSource sym w -> MemWrites sym
forall sym (w :: Natural).
(IsExprBuilder sym, 1 <= w) =>
LLVMPtr sym w -> WriteSource sym w -> MemWrites sym
memWritesSingleton LLVMPtr sym w
ptr WriteSource sym w
src
  (MemState sym -> Identity (MemState sym))
-> Mem sym -> Identity (Mem sym)
forall sym (f :: Type -> Type).
Functor f =>
(MemState sym -> f (MemState sym)) -> Mem sym -> f (Mem sym)
memState ((MemState sym -> Identity (MemState sym))
 -> Mem sym -> Identity (Mem sym))
-> (MemState sym -> MemState sym) -> Mem sym -> Mem sym
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ \case
    EmptyMem Int
ac Int
wc (MemAllocs sym
a, MemWrites sym
w) ->
      Int -> Int -> (MemAllocs sym, MemWrites sym) -> MemState sym
forall sym. Int -> Int -> MemChanges sym -> MemState sym
EmptyMem Int
ac (Int
wcInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (MemAllocs sym
a, MemWrites sym
single_write MemWrites sym -> MemWrites sym -> MemWrites sym
forall a. Semigroup a => a -> a -> a
<> MemWrites sym
w)
    StackFrame Int
ac Int
wc Text
nm (MemAllocs sym
a, MemWrites sym
w) MemState sym
s ->
      Int
-> Int
-> Text
-> (MemAllocs sym, MemWrites sym)
-> MemState sym
-> MemState sym
forall sym.
Int
-> Int -> Text -> MemChanges sym -> MemState sym -> MemState sym
StackFrame Int
ac (Int
wcInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Text
nm (MemAllocs sym
a, MemWrites sym
single_write MemWrites sym -> MemWrites sym -> MemWrites sym
forall a. Semigroup a => a -> a -> a
<> MemWrites sym
w) MemState sym
s
    BranchFrame Int
ac Int
wc (MemAllocs sym
a, MemWrites sym
w) MemState sym
s ->
      Int
-> Int
-> (MemAllocs sym, MemWrites sym)
-> MemState sym
-> MemState sym
forall sym.
Int -> Int -> MemChanges sym -> MemState sym -> MemState sym
BranchFrame Int
ac (Int
wcInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (MemAllocs sym
a, MemWrites sym
single_write MemWrites sym -> MemWrites sym -> MemWrites sym
forall a. Semigroup a => a -> a -> a
<> MemWrites sym
w) MemState sym
s

memStateAddChanges :: MemChanges sym -> MemState sym -> MemState sym
memStateAddChanges :: forall sym. MemChanges sym -> MemState sym -> MemState sym
memStateAddChanges (MemAllocs sym
a, MemWrites sym
w) = \case
  EmptyMem Int
ac Int
wc (MemAllocs sym
a0, MemWrites sym
w0) ->
    Int -> Int -> (MemAllocs sym, MemWrites sym) -> MemState sym
forall sym. Int -> Int -> MemChanges sym -> MemState sym
EmptyMem (MemAllocs sym -> Int
forall sym. MemAllocs sym -> Int
sizeMemAllocs MemAllocs sym
a Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
ac) (MemWrites sym -> Int
forall sym. MemWrites sym -> Int
memWritesSize MemWrites sym
w Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
wc) (MemAllocs sym
a MemAllocs sym -> MemAllocs sym -> MemAllocs sym
forall a. Semigroup a => a -> a -> a
<> MemAllocs sym
a0, MemWrites sym
w MemWrites sym -> MemWrites sym -> MemWrites sym
forall a. Semigroup a => a -> a -> a
<> MemWrites sym
w0)
  StackFrame Int
ac Int
wc Text
nm (MemAllocs sym
a0, MemWrites sym
w0) MemState sym
s ->
    Int
-> Int
-> Text
-> (MemAllocs sym, MemWrites sym)
-> MemState sym
-> MemState sym
forall sym.
Int
-> Int -> Text -> MemChanges sym -> MemState sym -> MemState sym
StackFrame (MemAllocs sym -> Int
forall sym. MemAllocs sym -> Int
sizeMemAllocs MemAllocs sym
a Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
ac) (MemWrites sym -> Int
forall sym. MemWrites sym -> Int
memWritesSize MemWrites sym
w Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
wc) Text
nm (MemAllocs sym
a MemAllocs sym -> MemAllocs sym -> MemAllocs sym
forall a. Semigroup a => a -> a -> a
<> MemAllocs sym
a0, MemWrites sym
w MemWrites sym -> MemWrites sym -> MemWrites sym
forall a. Semigroup a => a -> a -> a
<> MemWrites sym
w0) MemState sym
s
  BranchFrame Int
ac Int
wc (MemAllocs sym
a0, MemWrites sym
w0) MemState sym
s ->
    Int
-> Int
-> (MemAllocs sym, MemWrites sym)
-> MemState sym
-> MemState sym
forall sym.
Int -> Int -> MemChanges sym -> MemState sym -> MemState sym
BranchFrame (MemAllocs sym -> Int
forall sym. MemAllocs sym -> Int
sizeMemAllocs MemAllocs sym
a Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
ac) (MemWrites sym -> Int
forall sym. MemWrites sym -> Int
memWritesSize MemWrites sym
w Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
wc) (MemAllocs sym
a MemAllocs sym -> MemAllocs sym -> MemAllocs sym
forall a. Semigroup a => a -> a -> a
<> MemAllocs sym
a0, MemWrites sym
w MemWrites sym -> MemWrites sym -> MemWrites sym
forall a. Semigroup a => a -> a -> a
<> MemWrites sym
w0) MemState sym
s


--------------------------------------------------------------------------------
-- Pointer validity

-- | @isAllocatedMut isMut sym w p sz m@ returns the condition required to
-- prove range @[p..p+sz)@ lies within a single allocation in @m@.
--
-- This function is parameterized by a predicate on the mutability, so
-- it can optionally be restricted to mutable regions only.
-- It is also parameterized by a required alignment; only allocations
-- with at least this level of alignment are considered.
--
-- NB this algorithm is set up to explicitly allow both zero size allocations
-- and zero-size chunks to be checked for validity.  When 'sz' is 0, every pointer
-- that is inside the range of the allocation OR ONE PAST THE END are considered
-- "allocated"; this is intended, as it captures C's behavior regarding valid
-- pointers.
isAllocatedMut ::
  forall sym w .
  (1 <= w, IsSymInterface sym) =>
  (Mutability -> Bool) ->
  sym -> NatRepr w     ->
  Alignment            ->
  LLVMPtr sym w        ->
  Maybe (SymBV sym w)  ->
  Mem sym              ->
  IO (Pred sym)
isAllocatedMut :: forall sym (w :: Natural).
(1 <= w, IsSymInterface sym) =>
(Mutability -> Bool)
-> sym
-> NatRepr w
-> Alignment
-> LLVMPtr sym w
-> Maybe (SymBV sym w)
-> Mem sym
-> IO (Pred sym)
isAllocatedMut Mutability -> Bool
mutOk sym
sym NatRepr w
w Alignment
minAlign (LLVMPtr sym w -> (SymNat sym, SymBV sym w)
forall sym (w :: Natural).
LLVMPtr sym w -> (SymNat sym, SymBV sym w)
llvmPointerView -> (SymNat sym
blk, SymBV sym w
off)) Maybe (SymBV sym w)
sz Mem sym
m =
  do (Pred sym
wasAllocated, Pred sym
notFreed) <- sym
-> (AllocInfo sym -> IO (Pred sym))
-> SymNat sym
-> MemAllocs sym
-> IO (Pred sym, Pred sym)
forall sym.
(IsExpr (SymExpr sym), IsExprBuilder sym) =>
sym
-> (AllocInfo sym -> IO (Pred sym))
-> SymNat sym
-> MemAllocs sym
-> IO (Pred sym, Pred sym)
isAllocatedGeneric sym
sym AllocInfo sym -> IO (Pred sym)
inAllocation SymNat sym
blk (Mem sym -> MemAllocs sym
forall sym. Mem sym -> MemAllocs sym
memAllocs Mem sym
m)
     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
wasAllocated Pred sym
notFreed
  where
    inAllocation :: AllocInfo sym -> IO (Pred sym)
    inAllocation :: AllocInfo sym -> IO (Pred sym)
inAllocation (AllocInfo AllocType
_ Maybe (SymBV sym w)
asz Mutability
mut Alignment
alignment [Char]
_)
      | Mutability -> Bool
mutOk Mutability
mut Bool -> Bool -> Bool
&& Alignment
alignment Alignment -> Alignment -> Bool
forall a. Ord a => a -> a -> Bool
>= Alignment
minAlign = Maybe (SymBV sym w) -> IO (Pred sym)
forall (w' :: Natural). Maybe (SymBV sym w') -> IO (Pred sym)
inBounds Maybe (SymBV sym w)
asz
      | Bool
otherwise = Pred sym -> IO (Pred sym)
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (sym -> Pred sym
forall sym. IsExprBuilder sym => sym -> Pred sym
falsePred sym
sym)

    -- @inBounds a allocatedSz@ produces the predicate that
    -- records whether the pointer @ptr@ of size @sz@ falls within the
    -- allocation of block @a@ of size @allocatedSz@.
    inBounds :: forall w'. Maybe (SymBV sym w') -> IO (Pred sym)
    inBounds :: forall (w' :: Natural). Maybe (SymBV sym w') -> IO (Pred sym)
inBounds Maybe (SymBV sym w')
Nothing =
      case Maybe (SymBV sym w)
sz of
        Maybe (SymBV sym w)
Nothing ->
          -- Unbounded access of an unbounded allocation must start at offset 0.
          sym -> SymBV sym w -> SymBV sym w -> 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)
bvEq sym
sym SymBV sym w
off (SymBV sym w -> IO (Pred sym)) -> IO (SymBV sym w) -> IO (Pred sym)
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< sym -> NatRepr w -> IO (SymBV sym w)
forall (w :: Natural) sym.
(1 <= w, IsExprBuilder sym) =>
sym -> NatRepr w -> IO (SymBV sym w)
bvZero sym
sym NatRepr w
w
        Just SymBV sym w
currSize ->
          -- Bounded access of an unbounded allocation requires that
          -- @offset + size <= 2^w@, or equivalently @offset <= 2^w -
          -- size@. Note that @bvNeg sym size@ computes @2^w - size@
          -- for any nonzero @size@.
          do Pred sym
zeroSize <- sym -> SymBV sym w -> SymBV sym w -> 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)
bvEq sym
sym SymBV sym w
currSize (SymBV sym w -> IO (Pred sym)) -> IO (SymBV sym w) -> IO (Pred sym)
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< sym -> NatRepr w -> IO (SymBV sym w)
forall (w :: Natural) sym.
(1 <= w, IsExprBuilder sym) =>
sym -> NatRepr w -> IO (SymBV sym w)
bvZero sym
sym NatRepr w
w
             Pred sym
noWrap <- sym -> SymBV sym w -> SymBV sym w -> 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)
bvUle sym
sym SymBV sym w
off (SymBV sym w -> IO (Pred sym)) -> IO (SymBV sym w) -> IO (Pred sym)
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< sym -> SymBV sym w -> IO (SymBV sym w)
forall (w :: Natural).
(1 <= w) =>
sym -> SymBV sym w -> IO (SymBV sym w)
forall sym (w :: Natural).
(IsExprBuilder sym, 1 <= w) =>
sym -> SymBV sym w -> IO (SymBV sym w)
bvNeg sym
sym SymBV sym w
currSize
             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
zeroSize Pred sym
noWrap

    inBounds (Just SymBV sym w'
allocSize)
      -- If the allocation is done at pointer width is equal to @w@, check
      -- if this allocation covers the required range
      | 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 NatRepr w
w (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'
allocSize)
      , Just SymBV sym w
currSize <- Maybe (SymBV sym w)
sz =
        do Pred sym
smallSize <- sym -> SymBV sym w -> SymBV sym w -> 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)
bvUle sym
sym SymBV sym w
currSize SymBV sym w
SymBV sym w'
allocSize    -- currSize <= allocSize
           SymBV sym w
maxOffset <- sym -> SymBV sym w -> SymBV sym w -> IO (SymBV sym w)
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 w
SymBV sym w'
allocSize SymBV sym w
currSize    -- maxOffset = allocSize - currSize
           Pred sym
inRange   <- sym -> SymBV sym w -> SymBV sym w -> 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)
bvUle sym
sym SymBV sym w
off SymBV sym w
maxOffset         -- offset(ptr) <= maxOffset
           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
smallSize Pred sym
inRange

    inBounds (Just SymBV sym w'
_allocSize)
      -- If the allocation is done at pointer width not equal to @w@,
      -- then this is not the allocation we're looking for. Similarly,
      -- if @sz@ is @Nothing@ (indicating we are accessing the entire
      -- address space) then any bounded allocation is too small.
      | Bool
otherwise = Pred sym -> IO (Pred sym)
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Pred sym -> IO (Pred sym)) -> Pred sym -> IO (Pred sym)
forall a b. (a -> b) -> a -> b
$ sym -> Pred sym
forall sym. IsExprBuilder sym => sym -> Pred sym
falsePred sym
sym

-- | @isAllocated sym w p sz m@ returns the condition required to prove
-- range @[p..p+sz)@ lies within a single allocation in @m@.
--
-- NB this algorithm is set up to explicitly allow both zero size allocations
-- and zero-size chunks to be checked for validity.  When 'sz' is 0, every pointer
-- that is inside the range of the allocation OR ONE PAST THE END are considered
-- "allocated"; this is intended, as it captures C's behavior regarding valid
-- pointers.
isAllocated ::
  forall sym w. (1 <= w, IsSymInterface sym) =>
  sym -> NatRepr w ->
  Alignment        ->
  LLVMPtr sym w    ->
  Maybe (SymBV sym w) ->
  Mem sym          ->
  IO (Pred sym)
isAllocated :: forall sym (w :: Natural).
(1 <= w, IsSymInterface sym) =>
sym
-> NatRepr w
-> Alignment
-> LLVMPtr sym w
-> Maybe (SymBV sym w)
-> Mem sym
-> IO (Pred sym)
isAllocated = (Mutability -> Bool)
-> sym
-> NatRepr w
-> Alignment
-> RegValue sym (LLVMPointerType w)
-> Maybe (SymExpr sym (BaseBVType w))
-> Mem sym
-> IO (SymExpr sym BaseBoolType)
forall sym (w :: Natural).
(1 <= w, IsSymInterface sym) =>
(Mutability -> Bool)
-> sym
-> NatRepr w
-> Alignment
-> LLVMPtr sym w
-> Maybe (SymBV sym w)
-> Mem sym
-> IO (Pred sym)
isAllocatedMut (Bool -> Mutability -> Bool
forall a b. a -> b -> a
const Bool
True)

-- | @isAllocatedMutable sym w p sz m@ returns the condition required
-- to prove range @[p..p+sz)@ lies within a single /mutable/
-- allocation in @m@.
isAllocatedMutable ::
  (1 <= w, IsSymInterface sym) =>
  sym -> NatRepr w -> Alignment -> LLVMPtr sym w -> Maybe (SymBV sym w) -> Mem sym -> IO (Pred sym)
isAllocatedMutable :: forall (w :: Natural) sym.
(1 <= w, IsSymInterface sym) =>
sym
-> NatRepr w
-> Alignment
-> LLVMPtr sym w
-> Maybe (SymBV sym w)
-> Mem sym
-> IO (Pred sym)
isAllocatedMutable = (Mutability -> Bool)
-> sym
-> NatRepr w
-> Alignment
-> RegValue sym (LLVMPointerType w)
-> Maybe (SymExpr sym (BaseBVType w))
-> Mem sym
-> IO (SymExpr sym BaseBoolType)
forall sym (w :: Natural).
(1 <= w, IsSymInterface sym) =>
(Mutability -> Bool)
-> sym
-> NatRepr w
-> Alignment
-> LLVMPtr sym w
-> Maybe (SymBV sym w)
-> Mem sym
-> IO (Pred sym)
isAllocatedMut (Mutability -> Mutability -> Bool
forall a. Eq a => a -> a -> Bool
== Mutability
Mutable)

-- | 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                 -} ->
  Mutability          {- ^ 'Mutable' means pointed-to region must be writable -} ->
  LLVMPtr sym w       {- ^ pointer                                            -} ->
  Maybe (SymBV sym w) {- ^ size (@Nothing@ means entire address space)        -} ->
  Mem 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)
-> Mem sym
-> IO (Pred sym)
isAllocatedAlignedPointer sym
sym NatRepr w
w Alignment
alignment Mutability
mutability LLVMPtr sym w
ptr Maybe (SymBV sym w)
size Mem sym
mem =
  do Pred sym
p1 <- (Mutability -> Bool)
-> sym
-> NatRepr w
-> Alignment
-> LLVMPtr sym w
-> Maybe (SymBV sym w)
-> Mem sym
-> IO (Pred sym)
forall sym (w :: Natural).
(1 <= w, IsSymInterface sym) =>
(Mutability -> Bool)
-> sym
-> NatRepr w
-> Alignment
-> LLVMPtr sym w
-> Maybe (SymBV sym w)
-> Mem sym
-> IO (Pred sym)
isAllocatedMut Mutability -> Bool
mutOk sym
sym NatRepr w
w Alignment
alignment LLVMPtr sym w
ptr Maybe (SymBV sym w)
size Mem sym
mem
     Pred sym
p2 <- sym -> NatRepr w -> LLVMPtr sym w -> Alignment -> IO (Pred sym)
forall sym (w :: Natural).
(1 <= w, IsSymInterface sym) =>
sym -> NatRepr w -> LLVMPtr sym w -> Alignment -> IO (Pred sym)
isAligned sym
sym NatRepr w
w LLVMPtr sym w
ptr Alignment
alignment
     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
p1 Pred sym
p2
  where
    mutOk :: Mutability -> Bool
mutOk Mutability
m =
      case Mutability
mutability of
        Mutability
Mutable -> Mutability
m Mutability -> Mutability -> Bool
forall a. Eq a => a -> a -> Bool
== Mutability
Mutable
        Mutability
Immutable -> Bool
True

-- | @isValidPointer sym w b m@ returns the condition required to prove that @p@
--   is a valid pointer in @m@. This means that @p@ is in the range of some
--   allocation OR ONE PAST THE END of an allocation. In other words @p@ is a
--   valid pointer if @b <= p <= b+sz@ for some allocation at base @b@ of size
--   @Just sz@, or if @b <= p@ for some allocation of size @Nothing@. Note that,
--   even though @b+sz@ is outside the allocation range of the allocation
--   (loading through it will fail) it is nonetheless a valid pointer value.
--   This strange special case is baked into the C standard to allow certain
--   common coding patterns to be defined.
isValidPointer :: (1 <= w, IsSymInterface sym)
        => sym -> NatRepr w -> LLVMPtr sym w -> Mem sym -> IO (Pred sym)
isValidPointer :: forall (w :: Natural) sym.
(1 <= w, IsSymInterface sym) =>
sym -> NatRepr w -> LLVMPtr sym w -> Mem sym -> IO (Pred sym)
isValidPointer sym
sym NatRepr w
w LLVMPtr sym w
p Mem sym
m = do
   SymExpr sym (BaseBVType w)
sz <- sym -> NatRepr w -> Addr -> IO (SymExpr sym (BaseBVType w))
forall (w :: Natural) sym.
(1 <= w, IsExprBuilder sym) =>
sym -> NatRepr w -> Addr -> IO (SymBV sym w)
constOffset sym
sym NatRepr w
w Addr
0
   sym
-> NatRepr w
-> Alignment
-> LLVMPtr sym w
-> Maybe (SymExpr sym (BaseBVType w))
-> Mem sym
-> IO (Pred sym)
forall sym (w :: Natural).
(1 <= w, IsSymInterface sym) =>
sym
-> NatRepr w
-> Alignment
-> LLVMPtr sym w
-> Maybe (SymBV sym w)
-> Mem sym
-> IO (Pred sym)
isAllocated sym
sym NatRepr w
w Alignment
noAlignment LLVMPtr sym w
p (SymExpr sym (BaseBVType w) -> Maybe (SymExpr sym (BaseBVType w))
forall a. a -> Maybe a
Just SymExpr sym (BaseBVType w)
sz) Mem sym
m
   -- NB We call isAllocated with a size of 0.

-- | Generate a predicate asserting that the given pointer satisfies
-- the specified alignment constraint.
isAligned ::
  forall sym w .
  (1 <= w, IsSymInterface sym) =>
  sym -> NatRepr w ->
  LLVMPtr sym w ->
  Alignment ->
  IO (Pred sym)
isAligned :: forall sym (w :: Natural).
(1 <= w, IsSymInterface sym) =>
sym -> NatRepr w -> LLVMPtr sym w -> Alignment -> IO (Pred sym)
isAligned sym
sym NatRepr w
_w LLVMPtr sym w
_p Alignment
a
  | Alignment
a Alignment -> Alignment -> Bool
forall a. Eq a => a -> a -> Bool
== Alignment
noAlignment = SymExpr sym BaseBoolType -> IO (SymExpr sym BaseBoolType)
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (sym -> SymExpr sym BaseBoolType
forall sym. IsExprBuilder sym => sym -> Pred sym
truePred sym
sym)
isAligned sym
sym NatRepr w
w (LLVMPointer SymNat sym
_blk SymBV sym w
offset) Alignment
a
  | Some NatRepr x
bits <- Natural -> Some NatRepr
mkNatRepr (Alignment -> Natural
alignmentToExponent Alignment
a)
  , Just LeqProof 1 x
LeqProof <- NatRepr x -> Maybe (LeqProof 1 x)
forall (n :: Natural). NatRepr n -> Maybe (LeqProof 1 n)
isPosNat NatRepr x
bits
  , Just LeqProof x w
LeqProof <- NatRepr x -> NatRepr w -> Maybe (LeqProof x w)
forall (m :: Natural) (n :: Natural).
NatRepr m -> NatRepr n -> Maybe (LeqProof m n)
testLeq NatRepr x
bits NatRepr w
w =
    do SymExpr sym (BaseBVType x)
lowbits <- sym
-> NatRepr 0
-> NatRepr x
-> SymBV sym w
-> IO (SymExpr sym (BaseBVType x))
forall (idx :: Natural) (n :: Natural) (w :: Natural).
(1 <= n, (idx + n) <= w) =>
sym -> NatRepr idx -> NatRepr n -> SymBV sym w -> IO (SymBV sym n)
forall sym (idx :: Natural) (n :: Natural) (w :: Natural).
(IsExprBuilder sym, 1 <= n, (idx + n) <= w) =>
sym -> NatRepr idx -> NatRepr n -> SymBV sym w -> IO (SymBV sym n)
bvSelect sym
sym (NatRepr 0
forall (n :: Natural). KnownNat n => NatRepr n
knownNat :: NatRepr 0) NatRepr x
bits SymBV sym w
offset
       sym
-> SymExpr sym (BaseBVType x)
-> SymExpr sym (BaseBVType x)
-> IO (SymExpr sym BaseBoolType)
forall (w :: Natural).
(1 <= w) =>
sym -> SymBV sym w -> SymBV sym w -> IO (SymExpr sym BaseBoolType)
forall sym (w :: Natural).
(IsExprBuilder sym, 1 <= w) =>
sym -> SymBV sym w -> SymBV sym w -> IO (Pred sym)
bvEq sym
sym SymExpr sym (BaseBVType x)
lowbits (SymExpr sym (BaseBVType x) -> IO (SymExpr sym BaseBoolType))
-> IO (SymExpr sym (BaseBVType x)) -> IO (SymExpr sym BaseBoolType)
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< sym -> NatRepr x -> IO (SymExpr sym (BaseBVType x))
forall (w :: Natural) sym.
(1 <= w, IsExprBuilder sym) =>
sym -> NatRepr w -> IO (SymBV sym w)
bvZero sym
sym NatRepr x
bits
isAligned sym
sym NatRepr w
_ LLVMPtr sym w
_ Alignment
_ =
  SymExpr sym BaseBoolType -> IO (SymExpr sym BaseBoolType)
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (sym -> SymExpr sym BaseBoolType
forall sym. IsExprBuilder sym => sym -> Pred sym
falsePred sym
sym)

-- | The LLVM memory model generally does not allow for different
-- memory regions to alias each other: Pointers with different
-- allocation block numbers will compare as definitely unequal.
-- However, it does allow two /immutable/ memory regions to alias each
-- other. To make this sound, equality comparisons between pointers to
-- different immutable memory regions must not evaluate to false.
-- Therefore pointer equality comparisons assert that the pointers are
-- not aliasable: they must not point to two different immutable
-- blocks.
notAliasable ::
  forall sym w .
  (IsSymInterface sym) =>
  sym ->
  LLVMPtr sym w ->
  LLVMPtr sym w ->
  Mem sym ->
  IO (Pred sym)
notAliasable :: forall sym (w :: Natural).
IsSymInterface sym =>
sym -> LLVMPtr sym w -> LLVMPtr sym w -> Mem sym -> IO (Pred sym)
notAliasable sym
sym (LLVMPtr sym w -> (SymNat sym, SymBV sym w)
forall sym (w :: Natural).
LLVMPtr sym w -> (SymNat sym, SymBV sym w)
llvmPointerView -> (SymNat sym
blk1, SymBV sym w
_)) (LLVMPtr sym w -> (SymNat sym, SymBV sym w)
forall sym (w :: Natural).
LLVMPtr sym w -> (SymNat sym, SymBV sym w)
llvmPointerView -> (SymNat sym
blk2, SymBV sym w
_)) Mem sym
mem =
  do Pred sym
p0 <- sym -> SymNat sym -> SymNat sym -> IO (Pred sym)
forall sym.
IsExprBuilder sym =>
sym -> SymNat sym -> SymNat sym -> IO (Pred sym)
natEq sym
sym SymNat sym
blk1 SymNat sym
blk2
     (Pred sym
wasAllocated1, Pred sym
notFreed1) <- sym
-> (AllocInfo sym -> IO (Pred sym))
-> SymNat sym
-> MemAllocs sym
-> IO (Pred sym, Pred sym)
forall sym.
(IsExpr (SymExpr sym), IsExprBuilder sym) =>
sym
-> (AllocInfo sym -> IO (Pred sym))
-> SymNat sym
-> MemAllocs sym
-> IO (Pred sym, Pred sym)
isAllocatedGeneric sym
sym AllocInfo sym -> IO (Pred sym)
isMutable SymNat sym
blk1 (Mem sym -> MemAllocs sym
forall sym. Mem sym -> MemAllocs sym
memAllocs Mem sym
mem)
     (Pred sym
wasAllocated2, Pred sym
notFreed2) <- sym
-> (AllocInfo sym -> IO (Pred sym))
-> SymNat sym
-> MemAllocs sym
-> IO (Pred sym, Pred sym)
forall sym.
(IsExpr (SymExpr sym), IsExprBuilder sym) =>
sym
-> (AllocInfo sym -> IO (Pred sym))
-> SymNat sym
-> MemAllocs sym
-> IO (Pred sym, Pred sym)
isAllocatedGeneric sym
sym AllocInfo sym -> IO (Pred sym)
isMutable SymNat sym
blk2 (Mem sym -> MemAllocs sym
forall sym. Mem sym -> MemAllocs sym
memAllocs Mem sym
mem)
     Pred sym
allocated1 <- 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
wasAllocated1 Pred sym
notFreed1
     Pred sym
allocated2 <- 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
wasAllocated2 Pred sym
notFreed2
     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
p0 (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
allocated1 Pred sym
allocated2
  where
    isMutable :: AllocInfo sym -> IO (Pred sym)
    isMutable :: AllocInfo sym -> IO (Pred sym)
isMutable (AllocInfo AllocType
_ Maybe (SymBV sym w)
_ Mutability
Mutable Alignment
_ [Char]
_) = Pred sym -> IO (Pred sym)
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (sym -> Pred sym
forall sym. IsExprBuilder sym => sym -> Pred sym
truePred sym
sym)
    isMutable (AllocInfo AllocType
_ Maybe (SymBV sym w)
_ Mutability
Immutable Alignment
_ [Char]
_) = Pred sym -> IO (Pred sym)
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (sym -> Pred sym
forall sym. IsExprBuilder sym => sym -> Pred sym
falsePred sym
sym)

--------------------------------------------------------------------------------
-- Other memory operations

-- | Write a value to memory.
--
-- The returned predicates assert (in this order):
--  * the pointer falls within an allocated, mutable memory region
--  * the pointer's alignment is correct
writeMem :: ( 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)
writeMem :: forall (w :: Natural) sym.
(1 <= w, IsSymInterface sym, HasLLVMAnn sym,
 ?memOpts::MemOptions) =>
sym
-> NatRepr w
-> Maybe [Char]
-> LLVMPtr sym w
-> StorageType
-> Alignment
-> LLVMVal sym
-> Mem sym
-> IO (Mem sym, Pred sym, Pred sym)
writeMem = (sym
 -> NatRepr w
 -> Alignment
 -> RegValue sym (LLVMPointerType w)
 -> Maybe (SymBV sym w)
 -> Mem sym
 -> IO (SymExpr sym BaseBoolType))
-> sym
-> NatRepr w
-> Maybe [Char]
-> RegValue sym (LLVMPointerType w)
-> StorageType
-> Alignment
-> LLVMVal sym
-> Mem sym
-> IO (Mem sym, SymExpr sym BaseBoolType, SymExpr sym BaseBoolType)
forall sym (w :: Natural).
(IsSymInterface sym, HasLLVMAnn sym, 1 <= w,
 ?memOpts::MemOptions) =>
(sym
 -> NatRepr w
 -> Alignment
 -> LLVMPtr sym w
 -> Maybe (SymBV sym w)
 -> Mem sym
 -> IO (Pred sym))
-> sym
-> NatRepr w
-> Maybe [Char]
-> LLVMPtr sym w
-> StorageType
-> Alignment
-> LLVMVal sym
-> Mem sym
-> IO (Mem sym, Pred sym, Pred sym)
writeMemWithAllocationCheck sym
-> NatRepr w
-> Alignment
-> RegValue sym (LLVMPointerType w)
-> Maybe (SymBV sym w)
-> 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)
isAllocatedMutable

-- | Write a value to any memory region, mutable or immutable.
--
-- The returned predicates assert (in this order):
--  * the pointer falls within an allocated memory region
--  * the pointer's alignment is correct
writeConstMem ::
  ( 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)
writeConstMem :: forall (w :: Natural) sym.
(1 <= w, IsSymInterface sym, HasLLVMAnn sym,
 ?memOpts::MemOptions) =>
sym
-> NatRepr w
-> Maybe [Char]
-> LLVMPtr sym w
-> StorageType
-> Alignment
-> LLVMVal sym
-> Mem sym
-> IO (Mem sym, Pred sym, Pred sym)
writeConstMem = (sym
 -> NatRepr w
 -> Alignment
 -> RegValue sym (LLVMPointerType w)
 -> Maybe (SymBV sym w)
 -> Mem sym
 -> IO (SymExpr sym BaseBoolType))
-> sym
-> NatRepr w
-> Maybe [Char]
-> RegValue sym (LLVMPointerType w)
-> StorageType
-> Alignment
-> LLVMVal sym
-> Mem sym
-> IO (Mem sym, SymExpr sym BaseBoolType, SymExpr sym BaseBoolType)
forall sym (w :: Natural).
(IsSymInterface sym, HasLLVMAnn sym, 1 <= w,
 ?memOpts::MemOptions) =>
(sym
 -> NatRepr w
 -> Alignment
 -> LLVMPtr sym w
 -> Maybe (SymBV sym w)
 -> Mem sym
 -> IO (Pred sym))
-> sym
-> NatRepr w
-> Maybe [Char]
-> LLVMPtr sym w
-> StorageType
-> Alignment
-> LLVMVal sym
-> Mem sym
-> IO (Mem sym, Pred sym, Pred sym)
writeMemWithAllocationCheck sym
-> NatRepr w
-> Alignment
-> RegValue sym (LLVMPointerType w)
-> Maybe (SymBV sym w)
-> Mem sym
-> IO (SymExpr sym BaseBoolType)
forall sym (w :: Natural).
(1 <= w, IsSymInterface sym) =>
sym
-> NatRepr w
-> Alignment
-> LLVMPtr sym w
-> Maybe (SymBV sym w)
-> Mem sym
-> IO (Pred sym)
isAllocated

-- | Write a value to memory.
--
-- The returned predicates assert (in this order):
--  * the pointer satisfies the checks specified by
--    the @is_allocated@ function
--  * the pointer's alignment is correct
writeMemWithAllocationCheck ::
  forall sym w .
  ( IsSymInterface sym
  , HasLLVMAnn sym
  , 1 <= w
  , ?memOpts :: MemOptions ) =>
  (sym -> NatRepr w -> Alignment -> LLVMPtr sym w -> Maybe (SymBV sym w) -> Mem sym -> IO (Pred sym)) ->
  sym ->
  NatRepr w ->
  Maybe String ->
  LLVMPtr sym w ->
  StorageType ->
  Alignment ->
  LLVMVal sym ->
  Mem sym ->
  IO (Mem sym, Pred sym, Pred sym)
writeMemWithAllocationCheck :: forall sym (w :: Natural).
(IsSymInterface sym, HasLLVMAnn sym, 1 <= w,
 ?memOpts::MemOptions) =>
(sym
 -> NatRepr w
 -> Alignment
 -> LLVMPtr sym w
 -> Maybe (SymBV sym w)
 -> Mem sym
 -> IO (Pred sym))
-> sym
-> NatRepr w
-> Maybe [Char]
-> LLVMPtr sym w
-> StorageType
-> Alignment
-> LLVMVal sym
-> Mem sym
-> IO (Mem sym, Pred sym, Pred sym)
writeMemWithAllocationCheck sym
-> NatRepr w
-> Alignment
-> LLVMPtr sym w
-> Maybe (SymBV sym w)
-> Mem sym
-> IO (Pred sym)
is_allocated sym
sym NatRepr w
w Maybe [Char]
gsym LLVMPtr sym w
ptr StorageType
tp Alignment
alignment LLVMVal sym
val Mem sym
mem = do
  let mop :: MemoryOp sym w
mop = StorageType
-> Maybe [Char] -> LLVMPtr sym w -> Mem sym -> MemoryOp sym w
forall sym (w :: Natural).
StorageType
-> Maybe [Char] -> LLVMPtr sym w -> Mem sym -> MemoryOp sym w
MemStoreOp StorageType
tp Maybe [Char]
gsym LLVMPtr sym w
ptr Mem sym
mem
  let sz :: Addr
sz = Addr -> StorageType -> Addr
typeEnd Addr
0 StorageType
tp
  SymBV sym w
sz_bv <- sym -> NatRepr w -> Addr -> IO (SymBV sym w)
forall (w :: Natural) sym.
(1 <= w, IsExprBuilder sym) =>
sym -> NatRepr w -> Addr -> IO (SymBV sym w)
constOffset sym
sym NatRepr w
w Addr
sz
  Pred sym
p1 <- sym
-> NatRepr w
-> Alignment
-> LLVMPtr sym w
-> Maybe (SymBV sym w)
-> Mem sym
-> IO (Pred sym)
is_allocated sym
sym NatRepr w
w Alignment
alignment LLVMPtr sym w
ptr (SymBV sym w -> Maybe (SymBV sym w)
forall a. a -> Maybe a
Just SymBV sym w
sz_bv) Mem sym
mem
  Pred sym
p2 <- sym -> NatRepr w -> LLVMPtr sym w -> Alignment -> IO (Pred sym)
forall sym (w :: Natural).
(1 <= w, IsSymInterface sym) =>
sym -> NatRepr w -> LLVMPtr sym w -> Alignment -> IO (Pred sym)
isAligned sym
sym NatRepr w
w LLVMPtr sym w
ptr Alignment
alignment
  Maybe
  (Pred sym,
   SymExpr
     sym (BaseArrayType (SingleCtx (BaseBVType w)) (BaseBVType 8)),
   SymBV sym w)
maybe_allocation_array <- sym
-> NatRepr w
-> LLVMPtr sym w
-> Mem sym
-> IO
     (Maybe
        (Pred sym,
         SymExpr
           sym (BaseArrayType (SingleCtx (BaseBVType w)) (BaseBVType 8)),
         SymBV sym w))
forall sym (w :: Natural).
(IsSymInterface sym, 1 <= w) =>
sym
-> NatRepr w
-> LLVMPtr sym w
-> Mem sym
-> IO
     (Maybe
        (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8),
         SymBV sym w))
asMemAllocationArrayStore sym
sym NatRepr w
w LLVMPtr sym w
ptr Mem sym
mem
  Mem sym
mem' <- case Maybe
  (Pred sym,
   SymExpr
     sym (BaseArrayType (SingleCtx (BaseBVType w)) (BaseBVType 8)),
   SymBV sym w)
maybe_allocation_array of
    -- if this write is inside an allocation backed by a SMT array store and
    -- the value is not a pointer, then decompose this write into disassembling
    -- the value to individual bytes, writing them in the SMT array, and
    -- writing the updated SMT array in the memory
    Just (Pred sym
ok, SymExpr
  sym (BaseArrayType (SingleCtx (BaseBVType w)) (BaseBVType 8))
arr, SymBV sym w
arr_sz) | Just Bool
True <- Pred sym -> Maybe Bool
forall (e :: BaseType -> Type).
IsExpr e =>
e BaseBoolType -> Maybe Bool
asConstantPred Pred sym
ok
                           , case LLVMVal sym
val of
                               LLVMValInt SymNat sym
block SymBV sym w
_ -> (SymNat sym -> Maybe Natural
forall sym. IsExpr (SymExpr sym) => SymNat sym -> Maybe Natural
asNat SymNat sym
block) Maybe Natural -> Maybe Natural -> Bool
forall a. Eq a => a -> a -> Bool
== (Natural -> Maybe Natural
forall a. a -> Maybe a
Just Natural
0)
                               LLVMVal sym
_ -> Bool
True -> do
      let -- Return @Just value@ if we have successfully loaded a value and
          -- should update the corresponding index in the array with that
          -- value. Return @Nothing@ otherwise.
          subFn :: ValueLoad Addr -> IO (Maybe (PartLLVMVal sym))
          subFn :: ValueLoad Addr -> IO (Maybe (PartLLVMVal sym))
subFn = \case
            LastStore ValueView
val_view -> (PartLLVMVal sym -> Maybe (PartLLVMVal sym))
-> IO (PartLLVMVal sym) -> IO (Maybe (PartLLVMVal sym))
forall a b. (a -> b) -> IO a -> IO b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap PartLLVMVal sym -> Maybe (PartLLVMVal sym)
forall a. a -> Maybe a
Just (IO (PartLLVMVal sym) -> IO (Maybe (PartLLVMVal sym)))
-> IO (PartLLVMVal sym) -> IO (Maybe (PartLLVMVal sym))
forall a b. (a -> b) -> a -> b
$ sym
-> EndianForm
-> MemoryOp sym w
-> PartLLVMVal sym
-> ValueView
-> IO (PartLLVMVal sym)
forall sym (w :: Natural).
(IsSymInterface sym, HasLLVMAnn sym, 1 <= w) =>
sym
-> EndianForm
-> MemErrContext sym w
-> PartLLVMVal sym
-> ValueView
-> IO (PartLLVMVal sym)
applyView
              sym
sym
              (Mem sym -> EndianForm
forall sym. Mem sym -> EndianForm
memEndianForm Mem sym
mem)
              MemoryOp sym w
mop
              (sym -> LLVMVal sym -> PartLLVMVal sym
forall sym.
IsExprBuilder sym =>
sym -> LLVMVal sym -> PartLLVMVal sym
Partial.totalLLVMVal sym
sym LLVMVal sym
val)
              ValueView
val_view
            InvalidMemory StorageType
tp'
              |  -- With stable-symbolic, loading struct padding is
                 -- permissible. This is the only case that can return
                 -- Nothing.
                 MemOptions -> Bool
laxLoadsAndStores ?memOpts::MemOptions
MemOptions
?memOpts
              ,  MemOptions -> IndeterminateLoadBehavior
indeterminateLoadBehavior ?memOpts::MemOptions
MemOptions
?memOpts IndeterminateLoadBehavior -> IndeterminateLoadBehavior -> Bool
forall a. Eq a => a -> a -> Bool
== IndeterminateLoadBehavior
StableSymbolic
              -> Maybe (PartLLVMVal sym) -> IO (Maybe (PartLLVMVal sym))
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Maybe (PartLLVMVal sym)
forall a. Maybe a
Nothing

              |  Bool
otherwise
              -> (PartLLVMVal sym -> Maybe (PartLLVMVal sym))
-> IO (PartLLVMVal sym) -> IO (Maybe (PartLLVMVal sym))
forall a b. (a -> b) -> IO a -> IO b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap PartLLVMVal sym -> Maybe (PartLLVMVal sym)
forall a. a -> Maybe a
Just (IO (PartLLVMVal sym) -> IO (Maybe (PartLLVMVal sym)))
-> IO (PartLLVMVal sym) -> IO (Maybe (PartLLVMVal sym))
forall a b. (a -> b) -> a -> b
$ sym -> MemoryOp sym w -> MemoryErrorReason -> IO (PartLLVMVal sym)
forall sym (w :: Natural).
(IsSymInterface sym, HasLLVMAnn sym, 1 <= w) =>
sym -> MemoryOp sym w -> MemoryErrorReason -> IO (PartLLVMVal sym)
Partial.partErr sym
sym MemoryOp sym w
mop (MemoryErrorReason -> IO (PartLLVMVal sym))
-> MemoryErrorReason -> IO (PartLLVMVal sym)
forall a b. (a -> b) -> a -> b
$ StorageType -> MemoryErrorReason
Invalid StorageType
tp'
            OldMemory Addr
off StorageType
_ -> [Char] -> [[Char]] -> IO (Maybe (PartLLVMVal sym))
forall a. HasCallStack => [Char] -> [[Char]] -> a
panic [Char]
"Generic.writeMemWithAllocationCheck"
              [ [Char]
"Unexpected offset in storage type"
              , [Char]
"*** Offset:  " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Addr -> [Char]
forall a. Show a => a -> [Char]
show Addr
off
              , [Char]
"*** StorageType:  " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ StorageType -> [Char]
forall a. Show a => a -> [Char]
show StorageType
tp
              ]

          -- Given a symbolic array and an index into the array, load a byte
          -- from the corresponding position in memory and store the byte into
          -- the array at that index.
          storeArrayByteFn ::
            SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8) ->
            Offset ->
            IO (SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8))
          storeArrayByteFn :: SymExpr
  sym (BaseArrayType (SingleCtx (BaseBVType w)) (BaseBVType 8))
-> Addr
-> IO
     (SymExpr
        sym (BaseArrayType (SingleCtx (BaseBVType w)) (BaseBVType 8)))
storeArrayByteFn SymExpr
  sym (BaseArrayType (SingleCtx (BaseBVType w)) (BaseBVType 8))
acc_arr Addr
off = do
            ValueCtor (Maybe (PartLLVMVal sym))
vc <- (ValueLoad Addr -> IO (Maybe (PartLLVMVal sym)))
-> ValueCtor (ValueLoad Addr)
-> IO (ValueCtor (Maybe (PartLLVMVal 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) -> ValueCtor a -> f (ValueCtor b)
traverse ValueLoad Addr -> IO (Maybe (PartLLVMVal sym))
subFn (Addr -> Addr -> Addr -> ValueView -> ValueCtor (ValueLoad Addr)
loadBitvector Addr
off Addr
1 Addr
0 (StorageType -> ValueView
ValueViewVar StorageType
tp))
            Maybe (PartLLVMVal sym)
mb_partial_byte <- (ValueCtor (PartLLVMVal sym) -> IO (PartLLVMVal sym))
-> Maybe (ValueCtor (PartLLVMVal sym))
-> IO (Maybe (PartLLVMVal 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) -> Maybe a -> f (Maybe b)
traverse (sym
-> EndianForm
-> MemoryOp sym w
-> ValueCtor (PartLLVMVal sym)
-> IO (PartLLVMVal sym)
forall sym (w :: Natural).
(IsSymInterface sym, HasLLVMAnn sym, 1 <= w) =>
sym
-> EndianForm
-> MemoryOp sym w
-> ValueCtor (PartLLVMVal sym)
-> IO (PartLLVMVal sym)
genValueCtor sym
sym (Mem sym -> EndianForm
forall sym. Mem sym -> EndianForm
memEndianForm Mem sym
mem) MemoryOp sym w
mop)
                                        (ValueCtor (Maybe (PartLLVMVal sym))
-> Maybe (ValueCtor (PartLLVMVal sym))
forall (t :: Type -> Type) (f :: Type -> Type) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: Type -> Type) a.
Applicative f =>
ValueCtor (f a) -> f (ValueCtor a)
sequenceA ValueCtor (Maybe (PartLLVMVal sym))
vc)

            case Maybe (PartLLVMVal sym)
mb_partial_byte of
              Maybe (PartLLVMVal sym)
Nothing ->
                -- If we cannot load the byte from memory, skip updating the
                -- array. Currently, the only way that this can arise is when
                -- a byte of struct padding is loaded with StableSymbolic
                -- enabled.
                SymExpr
  sym (BaseArrayType (SingleCtx (BaseBVType w)) (BaseBVType 8))
-> IO
     (SymExpr
        sym (BaseArrayType (SingleCtx (BaseBVType w)) (BaseBVType 8)))
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure SymExpr
  sym (BaseArrayType (SingleCtx (BaseBVType w)) (BaseBVType 8))
acc_arr
              Just PartLLVMVal sym
partial_byte ->
                case PartLLVMVal sym
partial_byte of
                  Partial.NoErr Pred sym
_ (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) -> do
                      SymBV sym w
idx <- sym -> SymBV sym w -> SymBV sym w -> IO (SymBV sym w)
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 (LLVMPtr sym w -> SymBV sym w
forall sym (w :: Natural). LLVMPtr sym w -> SymBV sym w
llvmPointerOffset LLVMPtr sym w
ptr)
                        (SymBV sym w -> IO (SymBV sym w))
-> IO (SymBV sym w) -> IO (SymBV sym w)
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m 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 (NatRepr w -> Addr -> BV w
forall (w :: Natural). NatRepr w -> Addr -> BV w
bytesToBV NatRepr w
w Addr
off)
                      sym
-> SymExpr
     sym (BaseArrayType (SingleCtx (BaseBVType w)) (BaseBVType 8))
-> Assignment (SymExpr sym) (SingleCtx (BaseBVType w))
-> SymExpr sym (BaseBVType 8)
-> IO
     (SymExpr
        sym (BaseArrayType (SingleCtx (BaseBVType w)) (BaseBVType 8)))
forall sym (idx :: Ctx BaseType) (tp :: BaseType) (b :: BaseType).
IsExprBuilder sym =>
sym
-> SymArray sym (idx ::> tp) b
-> Assignment (SymExpr sym) (idx ::> tp)
-> SymExpr sym b
-> IO (SymArray sym (idx ::> tp) b)
forall (idx :: Ctx BaseType) (tp :: BaseType) (b :: BaseType).
sym
-> SymArray sym (idx ::> tp) b
-> Assignment (SymExpr sym) (idx ::> tp)
-> SymExpr sym b
-> IO (SymArray sym (idx ::> tp) b)
arrayUpdate sym
sym SymExpr
  sym (BaseArrayType (SingleCtx (BaseBVType w)) (BaseBVType 8))
acc_arr (SymBV sym w -> Assignment (SymExpr sym) (SingleCtx (BaseBVType w))
forall {k} (f :: k -> Type) (tp :: k).
f tp -> Assignment f (EmptyCtx ::> tp)
Ctx.singleton SymBV sym w
idx) SymBV sym w
SymExpr sym (BaseBVType 8)
byte

                  Partial.NoErr Pred sym
_ (LLVMValZero StorageType
_) -> do
                      SymExpr sym (BaseBVType 8)
byte <- 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 k (f :: k -> Type) (ctx :: k). KnownRepr f ctx => f ctx
knownRepr
                      SymBV sym w
idx <- sym -> SymBV sym w -> SymBV sym w -> IO (SymBV sym w)
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 (LLVMPtr sym w -> SymBV sym w
forall sym (w :: Natural). LLVMPtr sym w -> SymBV sym w
llvmPointerOffset LLVMPtr sym w
ptr)
                        (SymBV sym w -> IO (SymBV sym w))
-> IO (SymBV sym w) -> IO (SymBV sym w)
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m 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 (NatRepr w -> Addr -> BV w
forall (w :: Natural). NatRepr w -> Addr -> BV w
bytesToBV NatRepr w
w Addr
off)
                      sym
-> SymExpr
     sym (BaseArrayType (SingleCtx (BaseBVType w)) (BaseBVType 8))
-> Assignment (SymExpr sym) (SingleCtx (BaseBVType w))
-> SymExpr sym (BaseBVType 8)
-> IO
     (SymExpr
        sym (BaseArrayType (SingleCtx (BaseBVType w)) (BaseBVType 8)))
forall sym (idx :: Ctx BaseType) (tp :: BaseType) (b :: BaseType).
IsExprBuilder sym =>
sym
-> SymArray sym (idx ::> tp) b
-> Assignment (SymExpr sym) (idx ::> tp)
-> SymExpr sym b
-> IO (SymArray sym (idx ::> tp) b)
forall (idx :: Ctx BaseType) (tp :: BaseType) (b :: BaseType).
sym
-> SymArray sym (idx ::> tp) b
-> Assignment (SymExpr sym) (idx ::> tp)
-> SymExpr sym b
-> IO (SymArray sym (idx ::> tp) b)
arrayUpdate sym
sym SymExpr
  sym (BaseArrayType (SingleCtx (BaseBVType w)) (BaseBVType 8))
acc_arr (SymBV sym w -> Assignment (SymExpr sym) (SingleCtx (BaseBVType w))
forall {k} (f :: k -> Type) (tp :: k).
f tp -> Assignment f (EmptyCtx ::> tp)
Ctx.singleton SymBV sym w
idx) SymExpr sym (BaseBVType 8)
byte

                  Partial.NoErr Pred sym
_ LLVMVal sym
v ->
                      [Char]
-> [[Char]]
-> IO
     (SymExpr
        sym (BaseArrayType (SingleCtx (BaseBVType w)) (BaseBVType 8)))
forall a. HasCallStack => [Char] -> [[Char]] -> a
panic [Char]
"writeMemWithAllocationCheck"
                             [ [Char]
"Expected byte value when updating SMT array, but got:"
                             , LLVMVal sym -> [Char]
forall a. Show a => a -> [Char]
show LLVMVal sym
v
                             ]
                  Partial.Err Pred sym
_ ->
                      [Char]
-> [[Char]]
-> IO
     (SymExpr
        sym (BaseArrayType (SingleCtx (BaseBVType w)) (BaseBVType 8)))
forall a. HasCallStack => [Char] -> [[Char]] -> a
panic [Char]
"writeMemWithAllocationCheck"
                             [ [Char]
"Expected succesful byte load when updating SMT array"
                             , [Char]
"but got an error instead"
                             ]

      SymExpr
  sym (BaseArrayType (SingleCtx (BaseBVType w)) (BaseBVType 8))
res_arr <- (SymExpr
   sym (BaseArrayType (SingleCtx (BaseBVType w)) (BaseBVType 8))
 -> Addr
 -> IO
      (SymExpr
         sym (BaseArrayType (SingleCtx (BaseBVType w)) (BaseBVType 8))))
-> SymExpr
     sym (BaseArrayType (SingleCtx (BaseBVType w)) (BaseBVType 8))
-> [Addr]
-> IO
     (SymExpr
        sym (BaseArrayType (SingleCtx (BaseBVType w)) (BaseBVType 8)))
forall (t :: Type -> Type) (m :: Type -> Type) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM SymExpr
  sym (BaseArrayType (SingleCtx (BaseBVType w)) (BaseBVType 8))
-> Addr
-> IO
     (SymExpr
        sym (BaseArrayType (SingleCtx (BaseBVType w)) (BaseBVType 8)))
storeArrayByteFn SymExpr
  sym (BaseArrayType (SingleCtx (BaseBVType w)) (BaseBVType 8))
arr [Addr
0 .. (Addr
sz Addr -> Addr -> Addr
forall a. Num a => a -> a -> a
- Addr
1)]
      sym
-> NatRepr w
-> LLVMPtr sym w
-> SymExpr
     sym (BaseArrayType (SingleCtx (BaseBVType w)) (BaseBVType 8))
-> SymBV sym w
-> Mem sym
-> IO (Mem sym)
forall (w :: Natural) sym.
(1 <= w, IsSymInterface sym) =>
sym
-> NatRepr w
-> LLVMPtr sym w
-> SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)
-> SymBV sym w
-> Mem sym
-> IO (Mem sym)
overwriteArrayMem sym
sym NatRepr w
w LLVMPtr sym w
ptr SymExpr
  sym (BaseArrayType (SingleCtx (BaseBVType w)) (BaseBVType 8))
res_arr SymBV sym w
arr_sz Mem sym
mem

    Maybe
  (Pred sym,
   SymExpr
     sym (BaseArrayType (SingleCtx (BaseBVType w)) (BaseBVType 8)),
   SymBV sym w)
_ -> Mem sym -> IO (Mem sym)
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Mem sym -> IO (Mem sym)) -> Mem sym -> IO (Mem sym)
forall a b. (a -> b) -> a -> b
$ LLVMPtr sym w -> WriteSource sym w -> Mem sym -> Mem sym
forall sym (w :: Natural).
(IsExprBuilder sym, 1 <= w) =>
LLVMPtr sym w -> WriteSource sym w -> Mem sym -> Mem sym
memAddWrite LLVMPtr sym w
ptr (LLVMVal sym -> StorageType -> Alignment -> WriteSource sym w
forall sym (w :: Natural).
LLVMVal sym -> StorageType -> Alignment -> WriteSource sym w
MemStore LLVMVal sym
val StorageType
tp Alignment
alignment) Mem sym
mem

  (Mem sym, Pred sym, Pred sym) -> IO (Mem sym, Pred sym, Pred sym)
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Mem sym
mem', Pred sym
p1, Pred sym
p2)

-- | Overwrite SMT array.
--
-- In this case, we have generated an updated SMT array with all of
-- the changes needed to reflect this memory write.  Instead of adding
-- each individual byte write to the write log, we add a single entry that
-- shadows the entire SMT array in memory. This means that the next lookup
-- of e.g., a 4 byte read will see the updated array and be able to read 4
-- bytes from this array instead of having to traverse the write history
-- to find four different `MemStore`s.
--
-- Note that the pointer we write to is the *base* pointer (i.e., with
-- offset zero), since we are shadowing the *entire* array.
overwriteArrayMem ::
  (1 <= w, IsSymInterface sym) =>
  sym ->
  NatRepr w ->
  LLVMPtr sym w ->
  SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8) ->
  SymBV sym w ->
  Mem sym ->
  IO (Mem sym)
overwriteArrayMem :: forall (w :: Natural) sym.
(1 <= w, IsSymInterface sym) =>
sym
-> NatRepr w
-> LLVMPtr sym w
-> SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)
-> SymBV sym w
-> Mem sym
-> IO (Mem sym)
overwriteArrayMem sym
sym NatRepr w
w LLVMPtr sym w
ptr SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)
arr SymBV sym w
sz Mem sym
mem = do
  LLVMPointer sym w
basePtr <- SymNat sym -> SymBV sym w -> LLVMPointer sym w
forall sym (w :: Natural).
SymNat sym -> SymBV sym w -> LLVMPointer sym w
LLVMPointer (LLVMPtr sym w -> SymNat sym
forall sym (w :: Natural). LLVMPtr sym w -> SymNat sym
llvmPointerBlock LLVMPtr sym w
ptr) (SymBV sym w -> LLVMPointer sym w)
-> IO (SymBV sym w) -> IO (LLVMPointer sym w)
forall (f :: Type -> Type) a b. Functor 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 (NatRepr w -> Integer -> BV w
forall (w :: Natural). NatRepr w -> Integer -> BV w
BV.mkBV NatRepr w
w Integer
0)
  Mem sym -> IO (Mem sym)
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Mem sym -> IO (Mem sym)) -> Mem sym -> IO (Mem sym)
forall a b. (a -> b) -> a -> b
$ LLVMPtr sym w -> WriteSource sym w -> Mem sym -> Mem sym
forall sym (w :: Natural).
(IsExprBuilder sym, 1 <= w) =>
LLVMPtr sym w -> WriteSource sym w -> Mem sym -> Mem sym
memAddWrite LLVMPtr sym w
LLVMPointer sym w
basePtr (SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)
-> Maybe (SymBV sym w) -> WriteSource sym w
forall sym (w :: Natural).
SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)
-> Maybe (SymBV sym w) -> WriteSource sym w
MemArrayStore SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)
arr (SymBV sym w -> Maybe (SymBV sym w)
forall a. a -> Maybe a
Just SymBV sym w
sz)) Mem sym
mem

-- | Perform a mem copy (a la @memcpy@ in C).
--
-- The returned predicates assert (in this order):
--  * the source pointer falls within an allocated memory region
--  * the dest pointer falls within an allocated, mutable memory region
copyMem ::
  (1 <= w, IsSymInterface sym) =>
  sym -> NatRepr w ->
  LLVMPtr sym w {- ^ Dest   -} ->
  LLVMPtr sym w {- ^ Source -} ->
  SymBV sym w   {- ^ Size   -} ->
  Mem sym -> IO (Mem sym, Pred sym, Pred sym)
copyMem :: 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)
copyMem sym
sym NatRepr w
w LLVMPtr sym w
dst LLVMPtr sym w
src SymBV sym w
sz Mem sym
m =
  do Pred sym
p1 <- sym
-> NatRepr w
-> Alignment
-> LLVMPtr sym w
-> Maybe (SymBV sym w)
-> Mem sym
-> IO (Pred sym)
forall sym (w :: Natural).
(1 <= w, IsSymInterface sym) =>
sym
-> NatRepr w
-> Alignment
-> LLVMPtr sym w
-> Maybe (SymBV sym w)
-> Mem sym
-> IO (Pred sym)
isAllocated sym
sym NatRepr w
w Alignment
noAlignment LLVMPtr sym w
src (SymBV sym w -> Maybe (SymBV sym w)
forall a. a -> Maybe a
Just SymBV sym w
sz) Mem sym
m
     Pred sym
p2 <- sym
-> NatRepr w
-> Alignment
-> LLVMPtr sym w
-> Maybe (SymBV sym w)
-> Mem sym
-> IO (Pred sym)
forall (w :: Natural) sym.
(1 <= w, IsSymInterface sym) =>
sym
-> NatRepr w
-> Alignment
-> LLVMPtr sym w
-> Maybe (SymBV sym w)
-> Mem sym
-> IO (Pred sym)
isAllocatedMutable sym
sym NatRepr w
w Alignment
noAlignment LLVMPtr sym w
dst (SymBV sym w -> Maybe (SymBV sym w)
forall a. a -> Maybe a
Just SymBV sym w
sz) Mem sym
m
     Maybe
  (Pred sym,
   SymExpr
     sym (BaseArrayType (SingleCtx (BaseBVType w)) (BaseBVType 8)),
   SymBV sym w)
dst_maybe_allocation_array <- sym
-> NatRepr w
-> LLVMPtr sym w
-> Mem sym
-> IO
     (Maybe
        (Pred sym,
         SymExpr
           sym (BaseArrayType (SingleCtx (BaseBVType w)) (BaseBVType 8)),
         SymBV sym w))
forall sym (w :: Natural).
(IsSymInterface sym, 1 <= w) =>
sym
-> NatRepr w
-> LLVMPtr sym w
-> Mem sym
-> IO
     (Maybe
        (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8),
         SymBV sym w))
asMemAllocationArrayStore sym
sym NatRepr w
w LLVMPtr sym w
dst Mem sym
m
     Maybe
  (Pred sym,
   SymExpr
     sym (BaseArrayType (SingleCtx (BaseBVType w)) (BaseBVType 8)),
   SymBV sym w)
src_maybe_allocation_array <- sym
-> NatRepr w
-> LLVMPtr sym w
-> Mem sym
-> IO
     (Maybe
        (Pred sym,
         SymExpr
           sym (BaseArrayType (SingleCtx (BaseBVType w)) (BaseBVType 8)),
         SymBV sym w))
forall sym (w :: Natural).
(IsSymInterface sym, 1 <= w) =>
sym
-> NatRepr w
-> LLVMPtr sym w
-> Mem sym
-> IO
     (Maybe
        (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8),
         SymBV sym w))
asMemAllocationArrayStore sym
sym NatRepr w
w LLVMPtr sym w
src Mem sym
m
     Mem sym
m' <- case (Maybe
  (Pred sym,
   SymExpr
     sym (BaseArrayType (SingleCtx (BaseBVType w)) (BaseBVType 8)),
   SymBV sym w)
dst_maybe_allocation_array, Maybe
  (Pred sym,
   SymExpr
     sym (BaseArrayType (SingleCtx (BaseBVType w)) (BaseBVType 8)),
   SymBV sym w)
src_maybe_allocation_array) of
       -- if both the dst and src of this copy operation are inside allocations
       -- backed by SMT array stores, then replace this copy operation with
       -- using SMT array copy, and writing the result SMT array in the memory
       (Just (Pred sym
dst_ok, SymExpr
  sym (BaseArrayType (SingleCtx (BaseBVType w)) (BaseBVType 8))
dst_arr, SymBV sym w
dst_arr_sz), Just (Pred sym
src_ok, SymExpr
  sym (BaseArrayType (SingleCtx (BaseBVType w)) (BaseBVType 8))
src_arr, SymBV sym w
_src_arr_sz))
         | Just Bool
True <- Pred sym -> Maybe Bool
forall (e :: BaseType -> Type).
IsExpr e =>
e BaseBoolType -> Maybe Bool
asConstantPred Pred sym
dst_ok
         , Just Bool
True <- Pred sym -> Maybe Bool
forall (e :: BaseType -> Type).
IsExpr e =>
e BaseBoolType -> Maybe Bool
asConstantPred Pred sym
src_ok ->
           do SymExpr
  sym (BaseArrayType (SingleCtx (BaseBVType w)) (BaseBVType 8))
res_arr <- sym
-> SymExpr
     sym (BaseArrayType (SingleCtx (BaseBVType w)) (BaseBVType 8))
-> SymBV sym w
-> SymExpr
     sym (BaseArrayType (SingleCtx (BaseBVType w)) (BaseBVType 8))
-> SymBV sym w
-> SymBV sym w
-> IO
     (SymExpr
        sym (BaseArrayType (SingleCtx (BaseBVType w)) (BaseBVType 8)))
forall (w :: Natural) (a :: BaseType).
(1 <= w) =>
sym
-> SymArray sym (SingleCtx (BaseBVType w)) a
-> SymBV sym w
-> SymArray sym (SingleCtx (BaseBVType w)) a
-> SymBV sym w
-> SymBV sym w
-> IO (SymArray sym (SingleCtx (BaseBVType w)) a)
forall sym (w :: Natural) (a :: BaseType).
(IsExprBuilder sym, 1 <= w) =>
sym
-> SymArray sym (SingleCtx (BaseBVType w)) a
-> SymBV sym w
-> SymArray sym (SingleCtx (BaseBVType w)) a
-> SymBV sym w
-> SymBV sym w
-> IO (SymArray sym (SingleCtx (BaseBVType w)) a)
arrayCopy sym
sym SymExpr
  sym (BaseArrayType (SingleCtx (BaseBVType w)) (BaseBVType 8))
dst_arr (LLVMPtr sym w -> SymBV sym w
forall sym (w :: Natural). LLVMPtr sym w -> SymBV sym w
llvmPointerOffset LLVMPtr sym w
dst) SymExpr
  sym (BaseArrayType (SingleCtx (BaseBVType w)) (BaseBVType 8))
src_arr (LLVMPtr sym w -> SymBV sym w
forall sym (w :: Natural). LLVMPtr sym w -> SymBV sym w
llvmPointerOffset LLVMPtr sym w
src) SymBV sym w
sz
              sym
-> NatRepr w
-> LLVMPtr sym w
-> SymExpr
     sym (BaseArrayType (SingleCtx (BaseBVType w)) (BaseBVType 8))
-> SymBV sym w
-> Mem sym
-> IO (Mem sym)
forall (w :: Natural) sym.
(1 <= w, IsSymInterface sym) =>
sym
-> NatRepr w
-> LLVMPtr sym w
-> SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)
-> SymBV sym w
-> Mem sym
-> IO (Mem sym)
overwriteArrayMem sym
sym NatRepr w
w LLVMPtr sym w
dst SymExpr
  sym (BaseArrayType (SingleCtx (BaseBVType w)) (BaseBVType 8))
res_arr SymBV sym w
dst_arr_sz Mem sym
m

       (Maybe
   (Pred sym,
    SymExpr
      sym (BaseArrayType (SingleCtx (BaseBVType w)) (BaseBVType 8)),
    SymBV sym w),
 Maybe
   (Pred sym,
    SymExpr
      sym (BaseArrayType (SingleCtx (BaseBVType w)) (BaseBVType 8)),
    SymBV sym w))
_ -> Mem sym -> IO (Mem sym)
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Mem sym -> IO (Mem sym)) -> Mem sym -> IO (Mem sym)
forall a b. (a -> b) -> a -> b
$ LLVMPtr sym w -> WriteSource sym w -> Mem sym -> Mem sym
forall sym (w :: Natural).
(IsExprBuilder sym, 1 <= w) =>
LLVMPtr sym w -> WriteSource sym w -> Mem sym -> Mem sym
memAddWrite LLVMPtr sym w
dst (LLVMPtr sym w -> SymBV sym w -> WriteSource sym w
forall sym (w :: Natural).
LLVMPtr sym w -> SymBV sym w -> WriteSource sym w
MemCopy LLVMPtr sym w
src SymBV sym w
sz) Mem sym
m

     (Mem sym, Pred sym, Pred sym) -> IO (Mem sym, Pred sym, Pred sym)
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Mem sym
m', Pred sym
p1, Pred sym
p2)

-- | Perform a mem set, filling a number of bytes with a given 8-bit
-- value. The returned 'Pred' asserts that the pointer falls within an
-- allocated, mutable memory region.
setMem ::
  (1 <= w, IsSymInterface sym) =>
  sym -> NatRepr w ->
  LLVMPtr sym w {- ^ Pointer -} ->
  SymBV sym 8 {- ^ Byte value -} ->
  SymBV sym w {- ^ Number of bytes to set -} ->
  Mem sym -> IO (Mem sym, Pred sym)

setMem :: 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)
setMem sym
sym NatRepr w
w LLVMPtr sym w
ptr SymBV sym 8
val SymBV sym w
sz Mem sym
m =
  do Pred sym
p <- sym
-> NatRepr w
-> Alignment
-> LLVMPtr sym w
-> Maybe (SymBV sym w)
-> Mem sym
-> IO (Pred sym)
forall (w :: Natural) sym.
(1 <= w, IsSymInterface sym) =>
sym
-> NatRepr w
-> Alignment
-> LLVMPtr sym w
-> Maybe (SymBV sym w)
-> Mem sym
-> IO (Pred sym)
isAllocatedMutable sym
sym NatRepr w
w Alignment
noAlignment LLVMPtr sym w
ptr (SymBV sym w -> Maybe (SymBV sym w)
forall a. a -> Maybe a
Just SymBV sym w
sz) Mem sym
m
     Maybe
  (Pred sym,
   SymExpr
     sym (BaseArrayType (SingleCtx (BaseBVType w)) (BaseBVType 8)),
   SymBV sym w)
maybe_allocation_array <- sym
-> NatRepr w
-> LLVMPtr sym w
-> Mem sym
-> IO
     (Maybe
        (Pred sym,
         SymExpr
           sym (BaseArrayType (SingleCtx (BaseBVType w)) (BaseBVType 8)),
         SymBV sym w))
forall sym (w :: Natural).
(IsSymInterface sym, 1 <= w) =>
sym
-> NatRepr w
-> LLVMPtr sym w
-> Mem sym
-> IO
     (Maybe
        (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8),
         SymBV sym w))
asMemAllocationArrayStore sym
sym NatRepr w
w LLVMPtr sym w
ptr Mem sym
m
     Mem sym
m' <- case Maybe
  (Pred sym,
   SymExpr
     sym (BaseArrayType (SingleCtx (BaseBVType w)) (BaseBVType 8)),
   SymBV sym w)
maybe_allocation_array of
       -- if this set operation is inside an allocation backed by a SMT array
       -- store, then replace this set operation with using SMT array set, and
       -- writing the result SMT array in the memory
       Just (Pred sym
ok, SymExpr
  sym (BaseArrayType (SingleCtx (BaseBVType w)) (BaseBVType 8))
arr, SymBV sym w
arr_sz) | Just Bool
True <- Pred sym -> Maybe Bool
forall (e :: BaseType -> Type).
IsExpr e =>
e BaseBoolType -> Maybe Bool
asConstantPred Pred sym
ok ->
         do SymExpr
  sym (BaseArrayType (SingleCtx (BaseBVType w)) (BaseBVType 8))
res_arr <- sym
-> SymExpr
     sym (BaseArrayType (SingleCtx (BaseBVType w)) (BaseBVType 8))
-> SymBV sym w
-> SymBV sym 8
-> SymBV sym w
-> IO
     (SymExpr
        sym (BaseArrayType (SingleCtx (BaseBVType w)) (BaseBVType 8)))
forall (w :: Natural) (a :: BaseType).
(1 <= w) =>
sym
-> SymArray sym (SingleCtx (BaseBVType w)) a
-> SymBV sym w
-> SymExpr sym a
-> SymBV sym w
-> IO (SymArray sym (SingleCtx (BaseBVType w)) a)
forall sym (w :: Natural) (a :: BaseType).
(IsExprBuilder sym, 1 <= w) =>
sym
-> SymArray sym (SingleCtx (BaseBVType w)) a
-> SymBV sym w
-> SymExpr sym a
-> SymBV sym w
-> IO (SymArray sym (SingleCtx (BaseBVType w)) a)
arraySet sym
sym SymExpr
  sym (BaseArrayType (SingleCtx (BaseBVType w)) (BaseBVType 8))
arr (LLVMPtr sym w -> SymBV sym w
forall sym (w :: Natural). LLVMPtr sym w -> SymBV sym w
llvmPointerOffset LLVMPtr sym w
ptr) SymBV sym 8
val SymBV sym w
sz
            sym
-> NatRepr w
-> LLVMPtr sym w
-> SymExpr
     sym (BaseArrayType (SingleCtx (BaseBVType w)) (BaseBVType 8))
-> SymBV sym w
-> Mem sym
-> IO (Mem sym)
forall (w :: Natural) sym.
(1 <= w, IsSymInterface sym) =>
sym
-> NatRepr w
-> LLVMPtr sym w
-> SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)
-> SymBV sym w
-> Mem sym
-> IO (Mem sym)
overwriteArrayMem sym
sym NatRepr w
w LLVMPtr sym w
ptr SymExpr
  sym (BaseArrayType (SingleCtx (BaseBVType w)) (BaseBVType 8))
res_arr SymBV sym w
arr_sz Mem sym
m

       Maybe
  (Pred sym,
   SymExpr
     sym (BaseArrayType (SingleCtx (BaseBVType w)) (BaseBVType 8)),
   SymBV sym w)
_ -> Mem sym -> IO (Mem sym)
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Mem sym -> IO (Mem sym)) -> Mem sym -> IO (Mem sym)
forall a b. (a -> b) -> a -> b
$ LLVMPtr sym w -> WriteSource sym w -> Mem sym -> Mem sym
forall sym (w :: Natural).
(IsExprBuilder sym, 1 <= w) =>
LLVMPtr sym w -> WriteSource sym w -> Mem sym -> Mem sym
memAddWrite LLVMPtr sym w
ptr (SymBV sym 8 -> SymBV sym w -> WriteSource sym w
forall sym (w :: Natural).
SymBV sym 8 -> SymBV sym w -> WriteSource sym w
MemSet SymBV sym 8
val SymBV sym w
sz) Mem sym
m

     (Mem sym, Pred sym) -> IO (Mem sym, Pred sym)
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Mem sym
m', Pred sym
p)

writeArrayMemWithAllocationCheck ::
  (IsSymInterface sym, 1 <= w) =>
  (sym -> NatRepr w -> Alignment -> LLVMPtr sym w -> Maybe (SymBV sym w) -> Mem sym -> IO (Pred sym)) ->
  sym -> NatRepr w ->
  LLVMPtr sym w {- ^ Pointer -} ->
  Alignment ->
  SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8) {- ^ Array value -} ->
  Maybe (SymBV sym w) {- ^ Array size; if @Nothing@, the size is unrestricted -} ->
  Mem sym -> IO (Mem sym, Pred sym, Pred sym)
writeArrayMemWithAllocationCheck :: forall sym (w :: Natural).
(IsSymInterface sym, 1 <= w) =>
(sym
 -> NatRepr w
 -> Alignment
 -> LLVMPtr sym w
 -> Maybe (SymBV sym w)
 -> Mem sym
 -> IO (Pred sym))
-> 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)
writeArrayMemWithAllocationCheck sym
-> NatRepr w
-> Alignment
-> LLVMPtr sym w
-> Maybe (SymBV sym w)
-> Mem sym
-> IO (Pred sym)
is_allocated sym
sym NatRepr w
w LLVMPtr sym w
ptr Alignment
alignment SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)
arr Maybe (SymBV sym w)
sz Mem sym
m =
  do Pred sym
p1 <- sym
-> NatRepr w
-> Alignment
-> LLVMPtr sym w
-> Maybe (SymBV sym w)
-> Mem sym
-> IO (Pred sym)
is_allocated sym
sym NatRepr w
w Alignment
alignment LLVMPtr sym w
ptr Maybe (SymBV sym w)
sz Mem sym
m
     Pred sym
p2 <- sym -> NatRepr w -> LLVMPtr sym w -> Alignment -> IO (Pred sym)
forall sym (w :: Natural).
(1 <= w, IsSymInterface sym) =>
sym -> NatRepr w -> LLVMPtr sym w -> Alignment -> IO (Pred sym)
isAligned sym
sym NatRepr w
w LLVMPtr sym w
ptr Alignment
alignment
     let default_m :: Mem sym
default_m = LLVMPtr sym w -> WriteSource sym w -> Mem sym -> Mem sym
forall sym (w :: Natural).
(IsExprBuilder sym, 1 <= w) =>
LLVMPtr sym w -> WriteSource sym w -> Mem sym -> Mem sym
memAddWrite LLVMPtr sym w
ptr (SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)
-> Maybe (SymBV sym w) -> WriteSource sym w
forall sym (w :: Natural).
SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)
-> Maybe (SymBV sym w) -> WriteSource sym w
MemArrayStore SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)
arr Maybe (SymBV sym w)
sz) Mem sym
m
     Maybe
  (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8),
   SymBV sym w)
maybe_allocation_array <- sym
-> NatRepr w
-> LLVMPtr sym w
-> Mem sym
-> IO
     (Maybe
        (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8),
         SymBV sym w))
forall sym (w :: Natural).
(IsSymInterface sym, 1 <= w) =>
sym
-> NatRepr w
-> LLVMPtr sym w
-> Mem sym
-> IO
     (Maybe
        (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8),
         SymBV sym w))
asMemAllocationArrayStore sym
sym NatRepr w
w LLVMPtr sym w
ptr Mem sym
m
     Mem sym
m' <- case Maybe
  (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8),
   SymBV sym w)
maybe_allocation_array of
       -- if this write is inside an allocation backed by a SMT array store,
       -- then replace this copy operation with using SMT array copy, and
       -- writing the result SMT array in the memory
       Just (Pred sym
ok, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)
alloc_arr, SymBV sym w
alloc_sz)
         | Just Bool
True <- Pred sym -> Maybe Bool
forall (e :: BaseType -> Type).
IsExpr e =>
e BaseBoolType -> Maybe Bool
asConstantPred Pred sym
ok, Just SymBV sym w
arr_sz <- Maybe (SymBV sym w)
sz ->
         do SymBV sym w
sz_diff <- sym -> SymBV sym w -> SymBV sym w -> IO (SymBV sym w)
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 w
alloc_sz SymBV sym w
arr_sz
            case SymBV sym w -> Maybe (BV w)
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 SymBV sym w
sz_diff of
              Just (BV.BV Integer
0) -> Mem sym -> IO (Mem sym)
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Mem sym
default_m
              Maybe (BV w)
_ ->
                do SymBV sym w
zero_off <- 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 -> IO (SymBV sym w)) -> BV w -> IO (SymBV sym w)
forall a b. (a -> b) -> a -> b
$ NatRepr w -> Integer -> BV w
forall (w :: Natural). NatRepr w -> Integer -> BV w
BV.mkBV NatRepr w
w Integer
0
                   SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)
res_arr <- sym
-> SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)
-> SymBV sym w
-> SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)
-> SymBV sym w
-> SymBV sym w
-> IO (SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8))
forall (w :: Natural) (a :: BaseType).
(1 <= w) =>
sym
-> SymArray sym (SingleCtx (BaseBVType w)) a
-> SymBV sym w
-> SymArray sym (SingleCtx (BaseBVType w)) a
-> SymBV sym w
-> SymBV sym w
-> IO (SymArray sym (SingleCtx (BaseBVType w)) a)
forall sym (w :: Natural) (a :: BaseType).
(IsExprBuilder sym, 1 <= w) =>
sym
-> SymArray sym (SingleCtx (BaseBVType w)) a
-> SymBV sym w
-> SymArray sym (SingleCtx (BaseBVType w)) a
-> SymBV sym w
-> SymBV sym w
-> IO (SymArray sym (SingleCtx (BaseBVType w)) a)
arrayCopy sym
sym SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)
alloc_arr (LLVMPtr sym w -> SymBV sym w
forall sym (w :: Natural). LLVMPtr sym w -> SymBV sym w
llvmPointerOffset LLVMPtr sym w
ptr) SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)
arr SymBV sym w
zero_off SymBV sym w
arr_sz
                   sym
-> NatRepr w
-> LLVMPtr sym w
-> SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)
-> SymBV sym w
-> Mem sym
-> IO (Mem sym)
forall (w :: Natural) sym.
(1 <= w, IsSymInterface sym) =>
sym
-> NatRepr w
-> LLVMPtr sym w
-> SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)
-> SymBV sym w
-> Mem sym
-> IO (Mem sym)
overwriteArrayMem sym
sym NatRepr w
w LLVMPtr sym w
ptr SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)
res_arr SymBV sym w
alloc_sz Mem sym
m

       Maybe
  (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8),
   SymBV sym w)
_ -> Mem sym -> IO (Mem sym)
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Mem sym
default_m

     (Mem sym, Pred sym, Pred sym) -> IO (Mem sym, Pred sym, Pred sym)
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (SymNat sym -> Mem sym -> Mem sym
forall sym. IsExprBuilder sym => SymNat sym -> Mem sym -> Mem sym
memInsertArrayBlock (LLVMPtr sym w -> SymNat sym
forall sym (w :: Natural). LLVMPtr sym w -> SymNat sym
llvmPointerBlock LLVMPtr sym w
ptr) Mem sym
m', Pred sym
p1, Pred sym
p2)

-- | Write an array to memory.
--
-- The returned predicates assert (in this order):
--  * the pointer falls within an allocated, mutable memory region
--  * the pointer has the proper alignment
writeArrayMem ::
  (IsSymInterface sym, 1 <= w) =>
  sym -> NatRepr w ->
  LLVMPtr sym w {- ^ Pointer -} ->
  Alignment ->
  SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8) {- ^ Array value -} ->
  Maybe (SymBV sym w) {- ^ Array size; if @Nothing@, the size is unrestricted -} ->
  Mem sym -> IO (Mem sym, Pred sym, Pred sym)
writeArrayMem :: 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)
writeArrayMem = (sym
 -> NatRepr w
 -> Alignment
 -> RegValue sym (LLVMPointerType w)
 -> Maybe (SymExpr sym (BaseBVType w))
 -> Mem sym
 -> IO (SymExpr sym BaseBoolType))
-> sym
-> NatRepr w
-> RegValue sym (LLVMPointerType w)
-> Alignment
-> SymExpr
     sym (BaseArrayType (SingleCtx (BaseBVType w)) (BaseBVType 8))
-> Maybe (SymExpr sym (BaseBVType w))
-> Mem sym
-> IO (Mem sym, SymExpr sym BaseBoolType, SymExpr sym BaseBoolType)
forall sym (w :: Natural).
(IsSymInterface sym, 1 <= w) =>
(sym
 -> NatRepr w
 -> Alignment
 -> LLVMPtr sym w
 -> Maybe (SymBV sym w)
 -> Mem sym
 -> IO (Pred sym))
-> 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)
writeArrayMemWithAllocationCheck sym
-> NatRepr w
-> Alignment
-> RegValue sym (LLVMPointerType w)
-> Maybe (SymExpr sym (BaseBVType w))
-> 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)
isAllocatedMutable

-- | Write an array to memory.
--
-- The returned predicates assert (in this order):
--  * the pointer falls within an allocated memory region
--  * the pointer has the proper alignment
writeArrayConstMem ::
  (IsSymInterface sym, 1 <= w) =>
  sym -> NatRepr w ->
  LLVMPtr sym w {- ^ Pointer -} ->
  Alignment ->
  SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8) {- ^ Array value -} ->
  Maybe (SymBV sym w) {- ^ Array size -} ->
  Mem sym -> IO (Mem sym, Pred sym, Pred sym)
writeArrayConstMem :: 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)
writeArrayConstMem = (sym
 -> NatRepr w
 -> Alignment
 -> RegValue sym (LLVMPointerType w)
 -> Maybe (SymExpr sym (BaseBVType w))
 -> Mem sym
 -> IO (SymExpr sym BaseBoolType))
-> sym
-> NatRepr w
-> RegValue sym (LLVMPointerType w)
-> Alignment
-> SymExpr
     sym (BaseArrayType (SingleCtx (BaseBVType w)) (BaseBVType 8))
-> Maybe (SymExpr sym (BaseBVType w))
-> Mem sym
-> IO (Mem sym, SymExpr sym BaseBoolType, SymExpr sym BaseBoolType)
forall sym (w :: Natural).
(IsSymInterface sym, 1 <= w) =>
(sym
 -> NatRepr w
 -> Alignment
 -> LLVMPtr sym w
 -> Maybe (SymBV sym w)
 -> Mem sym
 -> IO (Pred sym))
-> 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)
writeArrayMemWithAllocationCheck sym
-> NatRepr w
-> Alignment
-> RegValue sym (LLVMPointerType w)
-> Maybe (SymExpr sym (BaseBVType w))
-> Mem sym
-> IO (SymExpr sym BaseBoolType)
forall sym (w :: Natural).
(1 <= w, IsSymInterface sym) =>
sym
-> NatRepr w
-> Alignment
-> LLVMPtr sym w
-> Maybe (SymBV sym w)
-> Mem sym
-> IO (Pred sym)
isAllocated

-- | Explicitly invalidate a region of memory.
invalidateMem ::
  (1 <= w, IsSymInterface sym) =>
  sym -> NatRepr w ->
  LLVMPtr sym w {- ^ Pointer -} ->
  Text          {- ^ Message -} ->
  SymBV sym w   {- ^ Number of bytes to set -} ->
  Mem sym -> IO (Mem sym, Pred sym)
invalidateMem :: 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)
invalidateMem sym
sym NatRepr w
w LLVMPtr sym w
ptr Text
msg SymBV sym w
sz Mem sym
m =
  do Pred sym
p <- sym
-> NatRepr w
-> Alignment
-> LLVMPtr sym w
-> Maybe (SymBV sym w)
-> Mem sym
-> IO (Pred sym)
forall (w :: Natural) sym.
(1 <= w, IsSymInterface sym) =>
sym
-> NatRepr w
-> Alignment
-> LLVMPtr sym w
-> Maybe (SymBV sym w)
-> Mem sym
-> IO (Pred sym)
isAllocatedMutable sym
sym NatRepr w
w Alignment
noAlignment LLVMPtr sym w
ptr (SymBV sym w -> Maybe (SymBV sym w)
forall a. a -> Maybe a
Just SymBV sym w
sz) Mem sym
m
     (Mem sym, Pred sym) -> IO (Mem sym, Pred sym)
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (LLVMPtr sym w -> WriteSource sym w -> Mem sym -> Mem sym
forall sym (w :: Natural).
(IsExprBuilder sym, 1 <= w) =>
LLVMPtr sym w -> WriteSource sym w -> Mem sym -> Mem sym
memAddWrite LLVMPtr sym w
ptr (Text -> SymBV sym w -> WriteSource sym w
forall sym (w :: Natural). Text -> SymBV sym w -> WriteSource sym w
MemInvalidate Text
msg SymBV sym w
sz) Mem sym
m, Pred sym
p)

-- | Allocate a new empty memory region.
allocMem :: (1 <= w) =>
            AllocType -- ^ Type of allocation
         -> Natural -- ^ Block id for allocation
         -> Maybe (SymBV sym w) -- ^ Size
         -> Alignment
         -> Mutability -- ^ Is block read-only
         -> String -- ^ Source location
         -> Mem sym
         -> Mem sym
allocMem :: forall (w :: Natural) sym.
(1 <= w) =>
AllocType
-> Natural
-> Maybe (SymBV sym w)
-> Alignment
-> Mutability
-> [Char]
-> Mem sym
-> Mem sym
allocMem AllocType
a Natural
b Maybe (SymBV sym w)
sz Alignment
alignment Mutability
mut [Char]
loc =
  (MemAllocs sym -> MemAllocs sym) -> Mem sym -> Mem sym
forall sym. (MemAllocs sym -> MemAllocs sym) -> Mem sym -> Mem sym
memAddAlloc (Natural -> AllocInfo sym -> MemAllocs sym -> MemAllocs sym
forall sym.
Natural -> AllocInfo sym -> MemAllocs sym -> MemAllocs sym
allocMemAllocs Natural
b (AllocType
-> Maybe (SymBV sym w)
-> Mutability
-> Alignment
-> [Char]
-> AllocInfo sym
forall sym (w :: Natural).
(1 <= w) =>
AllocType
-> Maybe (SymBV sym w)
-> Mutability
-> Alignment
-> [Char]
-> AllocInfo sym
AllocInfo AllocType
a Maybe (SymBV sym w)
sz Mutability
mut Alignment
alignment [Char]
loc))

-- | Allocate and initialize a new memory region.
allocAndWriteMem ::
  (1 <= w, IsExprBuilder sym) =>
  sym -> NatRepr w ->
  AllocType   {- ^ Type of allocation -}      ->
  Natural     {- ^ Block id for allocation -} ->
  StorageType                                 ->
  Alignment                                   ->
  Mutability  {- ^ Is block read-only -}      ->
  String      {- ^ Source location -}         ->
  LLVMVal sym {- ^ Value to write -}          ->
  Mem sym -> IO (Mem sym)
allocAndWriteMem :: forall (w :: Natural) sym.
(1 <= w, IsExprBuilder sym) =>
sym
-> NatRepr w
-> AllocType
-> Natural
-> StorageType
-> Alignment
-> Mutability
-> [Char]
-> LLVMVal sym
-> Mem sym
-> IO (Mem sym)
allocAndWriteMem sym
sym NatRepr w
w AllocType
a Natural
b StorageType
tp Alignment
alignment Mutability
mut [Char]
loc LLVMVal sym
v Mem sym
m =
  do SymExpr sym (BaseBVType w)
sz <- sym -> NatRepr w -> BV w -> IO (SymExpr sym (BaseBVType 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 (NatRepr w -> Addr -> BV w
forall (w :: Natural). NatRepr w -> Addr -> BV w
bytesToBV NatRepr w
w (Addr -> StorageType -> Addr
typeEnd Addr
0 StorageType
tp))
     SymNat sym
base <- sym -> Natural -> IO (SymNat sym)
forall sym. IsExprBuilder sym => sym -> Natural -> IO (SymNat sym)
natLit sym
sym Natural
b
     SymExpr sym (BaseBVType w)
off <- sym -> NatRepr w -> IO (SymExpr sym (BaseBVType w))
forall (w :: Natural) sym.
(1 <= w, IsExprBuilder sym) =>
sym -> NatRepr w -> IO (SymBV sym w)
bvZero sym
sym NatRepr w
w
     let p :: LLVMPointer sym w
p = SymNat sym -> SymExpr sym (BaseBVType w) -> LLVMPointer sym w
forall sym (w :: Natural).
SymNat sym -> SymBV sym w -> LLVMPointer sym w
LLVMPointer SymNat sym
base SymExpr sym (BaseBVType w)
off
     Mem sym -> IO (Mem sym)
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Mem sym
m Mem sym -> (Mem sym -> Mem sym) -> Mem sym
forall a b. a -> (a -> b) -> b
& AllocType
-> Natural
-> Maybe (SymExpr sym (BaseBVType w))
-> Alignment
-> Mutability
-> [Char]
-> Mem sym
-> Mem sym
forall (w :: Natural) sym.
(1 <= w) =>
AllocType
-> Natural
-> Maybe (SymBV sym w)
-> Alignment
-> Mutability
-> [Char]
-> Mem sym
-> Mem sym
allocMem AllocType
a Natural
b (SymExpr sym (BaseBVType w) -> Maybe (SymExpr sym (BaseBVType w))
forall a. a -> Maybe a
Just SymExpr sym (BaseBVType w)
sz) Alignment
alignment Mutability
mut [Char]
loc
               Mem sym -> (Mem sym -> Mem sym) -> Mem sym
forall a b. a -> (a -> b) -> b
& LLVMPtr sym w -> WriteSource sym w -> Mem sym -> Mem sym
forall sym (w :: Natural).
(IsExprBuilder sym, 1 <= w) =>
LLVMPtr sym w -> WriteSource sym w -> Mem sym -> Mem sym
memAddWrite LLVMPtr sym w
LLVMPointer sym w
p (LLVMVal sym -> StorageType -> Alignment -> WriteSource sym w
forall sym (w :: Natural).
LLVMVal sym -> StorageType -> Alignment -> WriteSource sym w
MemStore LLVMVal sym
v StorageType
tp Alignment
alignment))

pushStackFrameMem :: Text -> Mem sym -> Mem sym
pushStackFrameMem :: forall sym. Text -> Mem sym -> Mem sym
pushStackFrameMem Text
nm = (MemState sym -> Identity (MemState sym))
-> Mem sym -> Identity (Mem sym)
forall sym (f :: Type -> Type).
Functor f =>
(MemState sym -> f (MemState sym)) -> Mem sym -> f (Mem sym)
memState ((MemState sym -> Identity (MemState sym))
 -> Mem sym -> Identity (Mem sym))
-> (MemState sym -> MemState sym) -> Mem sym -> Mem sym
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ \MemState sym
s ->
  Int
-> Int -> Text -> MemChanges sym -> MemState sym -> MemState sym
forall sym.
Int
-> Int -> Text -> MemChanges sym -> MemState sym -> MemState sym
StackFrame (MemState sym -> Int
forall sym. MemState sym -> Int
memStateAllocCount MemState sym
s) (MemState sym -> Int
forall sym. MemState sym -> Int
memStateWriteCount MemState sym
s) Text
nm MemChanges sym
forall sym. MemChanges sym
emptyChanges MemState sym
s

popStackFrameMem :: forall sym. Mem sym -> Mem sym
popStackFrameMem :: forall sym. Mem sym -> Mem sym
popStackFrameMem Mem sym
m = Mem sym
m Mem sym -> (Mem sym -> Mem sym) -> Mem sym
forall a b. a -> (a -> b) -> b
& (MemState sym -> Identity (MemState sym))
-> Mem sym -> Identity (Mem sym)
forall sym (f :: Type -> Type).
Functor f =>
(MemState sym -> f (MemState sym)) -> Mem sym -> f (Mem sym)
memState ((MemState sym -> Identity (MemState sym))
 -> Mem sym -> Identity (Mem sym))
-> (MemState sym -> MemState sym) -> Mem sym -> Mem sym
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ MemState sym -> MemState sym
popf
  where popf :: MemState sym -> MemState sym
        popf :: MemState sym -> MemState sym
popf (StackFrame Int
_ Int
_ Text
_ (MemAllocs sym
a,MemWrites sym
w) MemState sym
s) =
          MemState sym
s MemState sym -> (MemState sym -> MemState sym) -> MemState sym
forall a b. a -> (a -> b) -> b
& (MemAllocs sym, MemWrites sym) -> MemState sym -> MemState sym
forall sym. MemChanges sym -> MemState sym -> MemState sym
memStateAddChanges (MemAllocs sym, MemWrites sym)
c
          where c :: (MemAllocs sym, MemWrites sym)
c = (MemAllocs sym -> MemAllocs sym
forall sym. MemAllocs sym -> MemAllocs sym
popMemAllocs MemAllocs sym
a, MemWrites sym
w)

        -- WARNING: The following code executes a stack pop underneath a branch
        -- frame.  This is necessary to get merges to work correctly
        -- when they propagate all the way to function returns.
        -- However, it is not clear that the following code is
        -- precisely correct because it may leave in place writes to
        -- memory locations that have just been popped off the stack.
        -- This does not appear to be causing problems for our
        -- examples, but may be a source of subtle errors.
        popf (BranchFrame Int
_ Int
wc (MemAllocs sym
a,MemWrites sym
w) MemState sym
s) =
          Int
-> Int
-> (MemAllocs sym, MemWrites sym)
-> MemState sym
-> MemState sym
forall sym.
Int -> Int -> MemChanges sym -> MemState sym -> MemState sym
BranchFrame (MemAllocs sym -> Int
forall sym. MemAllocs sym -> Int
sizeMemAllocs ((MemAllocs sym, MemWrites sym) -> MemAllocs sym
forall a b. (a, b) -> a
fst (MemAllocs sym, MemWrites sym)
c)) Int
wc (MemAllocs sym, MemWrites sym)
c (MemState sym -> MemState sym) -> MemState sym -> MemState sym
forall a b. (a -> b) -> a -> b
$ MemState sym -> MemState sym
popf MemState sym
s
          where c :: (MemAllocs sym, MemWrites sym)
c = (MemAllocs sym -> MemAllocs sym
forall sym. MemAllocs sym -> MemAllocs sym
popMemAllocs MemAllocs sym
a, MemWrites sym
w)

        popf EmptyMem{} = [Char] -> MemState sym
forall a. HasCallStack => [Char] -> a
error [Char]
"popStackFrameMem given unexpected memory"


-- | Free a heap-allocated block of memory.
--
-- The returned predicates assert (in this order):
--  * the pointer points to the base of a block
--  * said block was heap-allocated, and mutable
--  * said block was not previously freed
--
-- Because the LLVM memory model allows immutable blocks to alias each other,
-- freeing an immutable block could lead to unsoundness.
freeMem :: forall sym w .
  (1 <= w, IsSymInterface sym) =>
  sym ->
  NatRepr w ->
  LLVMPtr sym w {- ^ Base of allocation to free -} ->
  Mem sym ->
  String {- ^ Source location -} ->
  IO (Mem sym, Pred sym, Pred sym, Pred sym)
freeMem :: forall sym (w :: Natural).
(1 <= w, IsSymInterface sym) =>
sym
-> NatRepr w
-> LLVMPtr sym w
-> Mem sym
-> [Char]
-> IO (Mem sym, Pred sym, Pred sym, Pred sym)
freeMem sym
sym NatRepr w
w (LLVMPointer SymNat sym
blk SymBV sym w
off) Mem sym
m [Char]
loc =
  do Pred sym
p1 <- sym -> SymBV sym w -> SymBV sym w -> 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)
bvEq sym
sym SymBV sym w
off (SymBV sym w -> IO (Pred sym)) -> IO (SymBV sym w) -> IO (Pred sym)
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< sym -> NatRepr w -> IO (SymBV sym w)
forall (w :: Natural) sym.
(1 <= w, IsExprBuilder sym) =>
sym -> NatRepr w -> IO (SymBV sym w)
bvZero sym
sym NatRepr w
w
     (Pred sym
wasAllocated, Pred sym
notFreed) <- sym
-> (AllocInfo sym -> IO (Pred sym))
-> SymNat sym
-> MemAllocs sym
-> IO (Pred sym, Pred sym)
forall sym.
(IsExpr (SymExpr sym), IsExprBuilder sym) =>
sym
-> (AllocInfo sym -> IO (Pred sym))
-> SymNat sym
-> MemAllocs sym
-> IO (Pred sym, Pred sym)
isAllocatedGeneric sym
sym AllocInfo sym -> IO (Pred sym)
isHeapMutable SymNat sym
blk (Mem sym -> MemAllocs sym
forall sym. Mem sym -> MemAllocs sym
memAllocs Mem sym
m)
     (Mem sym, Pred sym, Pred sym, Pred sym)
-> IO (Mem sym, Pred sym, Pred sym, Pred sym)
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ((MemAllocs sym -> MemAllocs sym) -> Mem sym -> Mem sym
forall sym. (MemAllocs sym -> MemAllocs sym) -> Mem sym -> Mem sym
memAddAlloc (SymNat sym -> [Char] -> MemAllocs sym -> MemAllocs sym
forall sym. SymNat sym -> [Char] -> MemAllocs sym -> MemAllocs sym
freeMemAllocs SymNat sym
blk [Char]
loc) Mem sym
m, Pred sym
p1, Pred sym
wasAllocated, Pred sym
notFreed)
  where
    isHeapMutable :: AllocInfo sym -> IO (Pred sym)
    isHeapMutable :: AllocInfo sym -> IO (Pred sym)
isHeapMutable (AllocInfo AllocType
HeapAlloc Maybe (SymBV sym w)
_ Mutability
Mutable Alignment
_ [Char]
_) = Pred sym -> IO (Pred sym)
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (sym -> Pred sym
forall sym. IsExprBuilder sym => sym -> Pred sym
truePred sym
sym)
    isHeapMutable AllocInfo sym
_ = Pred sym -> IO (Pred sym)
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (sym -> Pred sym
forall sym. IsExprBuilder sym => sym -> Pred sym
falsePred sym
sym)

branchMem :: Mem sym -> Mem sym
branchMem :: forall sym. Mem sym -> Mem sym
branchMem = (MemState sym -> Identity (MemState sym))
-> Mem sym -> Identity (Mem sym)
forall sym (f :: Type -> Type).
Functor f =>
(MemState sym -> f (MemState sym)) -> Mem sym -> f (Mem sym)
memState ((MemState sym -> Identity (MemState sym))
 -> Mem sym -> Identity (Mem sym))
-> (MemState sym -> MemState sym) -> Mem sym -> Mem sym
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ \MemState sym
s ->
  Int -> Int -> MemChanges sym -> MemState sym -> MemState sym
forall sym.
Int -> Int -> MemChanges sym -> MemState sym -> MemState sym
BranchFrame (MemState sym -> Int
forall sym. MemState sym -> Int
memStateAllocCount MemState sym
s) (MemState sym -> Int
forall sym. MemState sym -> Int
memStateWriteCount MemState sym
s) MemChanges sym
forall sym. MemChanges sym
emptyChanges MemState sym
s

branchAbortMem :: Mem sym -> Mem sym
branchAbortMem :: forall sym. Mem sym -> Mem sym
branchAbortMem = (MemState sym -> Identity (MemState sym))
-> Mem sym -> Identity (Mem sym)
forall sym (f :: Type -> Type).
Functor f =>
(MemState sym -> f (MemState sym)) -> Mem sym -> f (Mem sym)
memState ((MemState sym -> Identity (MemState sym))
 -> Mem sym -> Identity (Mem sym))
-> (MemState sym -> MemState sym) -> Mem sym -> Mem sym
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ MemState sym -> MemState sym
forall {sym}. MemState sym -> MemState sym
popf
  where popf :: MemState sym -> MemState sym
popf (BranchFrame Int
_ Int
_ MemChanges sym
c MemState sym
s) = MemState sym
s MemState sym -> (MemState sym -> MemState sym) -> MemState sym
forall a b. a -> (a -> b) -> b
& MemChanges sym -> MemState sym -> MemState sym
forall sym. MemChanges sym -> MemState sym -> MemState sym
memStateAddChanges MemChanges sym
c
        popf MemState sym
_ = [Char] -> MemState sym
forall a. HasCallStack => [Char] -> a
error [Char]
"branchAbortMem given unexpected memory"

mergeMem :: IsExpr (SymExpr sym) => Pred sym -> Mem sym -> Mem sym -> Mem sym
mergeMem :: forall sym.
IsExpr (SymExpr sym) =>
Pred sym -> Mem sym -> Mem sym -> Mem sym
mergeMem Pred sym
c Mem sym
x Mem sym
y =
  case (Mem sym
xMem sym
-> Getting (MemState sym) (Mem sym) (MemState sym) -> MemState sym
forall s a. s -> Getting a s a -> a
^.Getting (MemState sym) (Mem sym) (MemState sym)
forall sym (f :: Type -> Type).
Functor f =>
(MemState sym -> f (MemState sym)) -> Mem sym -> f (Mem sym)
memState, Mem sym
yMem sym
-> Getting (MemState sym) (Mem sym) (MemState sym) -> MemState sym
forall s a. s -> Getting a s a -> a
^.Getting (MemState sym) (Mem sym) (MemState sym)
forall sym (f :: Type -> Type).
Functor f =>
(MemState sym -> f (MemState sym)) -> Mem sym -> f (Mem sym)
memState) of
    (BranchFrame Int
_ Int
_ MemChanges sym
a MemState sym
s, BranchFrame Int
_ Int
_ MemChanges sym
b MemState sym
_) ->
      let s' :: MemState sym
s' = MemState sym
s MemState sym -> (MemState sym -> MemState sym) -> MemState sym
forall a b. a -> (a -> b) -> b
& MemChanges sym -> MemState sym -> MemState sym
forall sym. MemChanges sym -> MemState sym -> MemState sym
memStateAddChanges (Pred sym -> MemChanges sym -> MemChanges sym -> MemChanges sym
forall sym.
IsExpr (SymExpr sym) =>
Pred sym -> MemChanges sym -> MemChanges sym -> MemChanges sym
muxChanges Pred sym
c MemChanges sym
a MemChanges sym
b)
      in Mem sym
x Mem sym -> (Mem sym -> Mem sym) -> Mem sym
forall a b. a -> (a -> b) -> b
& (MemState sym -> Identity (MemState sym))
-> Mem sym -> Identity (Mem sym)
forall sym (f :: Type -> Type).
Functor f =>
(MemState sym -> f (MemState sym)) -> Mem sym -> f (Mem sym)
memState ((MemState sym -> Identity (MemState sym))
 -> Mem sym -> Identity (Mem sym))
-> MemState sym -> Mem sym -> Mem sym
forall s t a b. ASetter s t a b -> b -> s -> t
.~ MemState sym
s'
    (MemState sym, MemState sym)
_ -> [Char] -> Mem sym
forall a. HasCallStack => [Char] -> a
error [Char]
"mergeMem given unexpected memories"

--------------------------------------------------------------------------------
-- Finding allocations

-- When we have a concrete allocation number, we can ask more specific questions
-- to the solver and get (overapproximate) concrete answers.

data SomeAlloc sym =
  forall w. (1 <= w) => SomeAlloc AllocType Natural (Maybe (SymBV sym w)) Mutability Alignment String

instance IsSymInterface sym => Eq (SomeAlloc sym) where
  SomeAlloc AllocType
x_atp Natural
x_base Maybe (SymBV sym w)
x_sz Mutability
x_mut Alignment
x_alignment [Char]
x_loc == :: SomeAlloc sym -> SomeAlloc sym -> Bool
== SomeAlloc AllocType
y_atp Natural
y_base Maybe (SymBV sym w)
y_sz Mutability
y_mut Alignment
y_alignment [Char]
y_loc = do
    let sz_eq :: Bool
sz_eq = case (Maybe (SymBV sym w)
x_sz, Maybe (SymBV sym w)
y_sz) of
          (Just SymBV sym w
x_bv, Just SymBV sym w
y_bv) -> Maybe ('BaseBVType w :~: BaseBVType w) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe ('BaseBVType w :~: BaseBVType w) -> Bool)
-> Maybe ('BaseBVType w :~: BaseBVType w) -> Bool
forall a b. (a -> b) -> a -> b
$ SymBV sym w
-> SymBV sym w -> Maybe ('BaseBVType w :~: BaseBVType w)
forall {k} (f :: k -> Type) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
forall (a :: BaseType) (b :: BaseType).
SymExpr sym a -> SymExpr sym b -> Maybe (a :~: b)
testEquality SymBV sym w
x_bv SymBV sym w
y_bv
          (Maybe (SymBV sym w)
Nothing, Maybe (SymBV sym w)
Nothing) -> Bool
True
          (Maybe (SymBV sym w), Maybe (SymBV sym w))
_ -> Bool
False
    AllocType
x_atp AllocType -> AllocType -> Bool
forall a. Eq a => a -> a -> Bool
== AllocType
y_atp Bool -> Bool -> Bool
&& Natural
x_base Natural -> Natural -> Bool
forall a. Eq a => a -> a -> Bool
== Natural
y_base Bool -> Bool -> Bool
&& Bool
sz_eq Bool -> Bool -> Bool
&& Mutability
x_mut Mutability -> Mutability -> Bool
forall a. Eq a => a -> a -> Bool
== Mutability
y_mut Bool -> Bool -> Bool
&& Alignment
x_alignment Alignment -> Alignment -> Bool
forall a. Eq a => a -> a -> Bool
== Alignment
y_alignment Bool -> Bool -> Bool
&& [Char]
x_loc [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
y_loc

ppSomeAlloc :: forall sym ann. IsExprBuilder sym => SomeAlloc sym -> Doc ann
ppSomeAlloc :: forall sym ann. IsExprBuilder sym => SomeAlloc sym -> Doc ann
ppSomeAlloc (SomeAlloc AllocType
atp Natural
base Maybe (SymBV sym w)
sz Mutability
mut Alignment
alignment [Char]
loc) =
  (Natural, AllocInfo sym) -> Doc ann
forall sym ann.
IsExpr (SymExpr sym) =>
(Natural, AllocInfo sym) -> Doc ann
ppAllocInfo (Natural
base, AllocType
-> Maybe (SymBV sym w)
-> Mutability
-> Alignment
-> [Char]
-> AllocInfo sym
forall sym (w :: Natural).
(1 <= w) =>
AllocType
-> Maybe (SymBV sym w)
-> Mutability
-> Alignment
-> [Char]
-> AllocInfo sym
AllocInfo AllocType
atp Maybe (SymBV sym w)
sz Mutability
mut Alignment
alignment [Char]
loc :: AllocInfo sym)

-- | Find an overapproximation of the set of allocations with this number.
possibleAllocs ::
  forall sym .
  (IsSymInterface sym) =>
  Natural              ->
  Mem sym              ->
  [SomeAlloc sym]
possibleAllocs :: forall sym.
IsSymInterface sym =>
Natural -> Mem sym -> [SomeAlloc sym]
possibleAllocs Natural
n Mem sym
mem =
  case Natural -> MemAllocs sym -> Maybe (AllocInfo sym)
forall sym.
IsExpr (SymExpr sym) =>
Natural -> MemAllocs sym -> Maybe (AllocInfo sym)
possibleAllocInfo Natural
n (Mem sym -> MemAllocs sym
forall sym. Mem sym -> MemAllocs sym
memAllocs Mem sym
mem) of
    Maybe (AllocInfo sym)
Nothing -> []
    Just (AllocInfo AllocType
atp Maybe (SymBV sym w)
sz Mutability
mut Alignment
alignment [Char]
loc) ->
      [AllocType
-> Natural
-> Maybe (SymBV sym w)
-> Mutability
-> Alignment
-> [Char]
-> SomeAlloc sym
forall sym (w :: Natural).
(1 <= w) =>
AllocType
-> Natural
-> Maybe (SymBV sym w)
-> Mutability
-> Alignment
-> [Char]
-> SomeAlloc sym
SomeAlloc AllocType
atp Natural
n Maybe (SymBV sym w)
sz Mutability
mut Alignment
alignment [Char]
loc]

-- | 'IO' plus memoization. The 'IORef' stores suspended computations with
-- 'Left' and evaluated results with 'Right'.
newtype MemoIO m a = MemoIO (IORef (Either (m a) a))

putMemoIO :: MonadIO m => m a -> m (MemoIO m a)
putMemoIO :: forall (m :: Type -> Type) a. MonadIO m => m a -> m (MemoIO m a)
putMemoIO m a
comp = IORef (Either (m a) a) -> MemoIO m a
forall (m :: Type -> Type) a. IORef (Either (m a) a) -> MemoIO m a
MemoIO (IORef (Either (m a) a) -> MemoIO m a)
-> m (IORef (Either (m a) a)) -> m (MemoIO m a)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (IORef (Either (m a) a)) -> m (IORef (Either (m a) a))
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (Either (m a) a -> IO (IORef (Either (m a) a))
forall a. a -> IO (IORef a)
newIORef (Either (m a) a -> IO (IORef (Either (m a) a)))
-> Either (m a) a -> IO (IORef (Either (m a) a))
forall a b. (a -> b) -> a -> b
$ m a -> Either (m a) a
forall a b. a -> Either a b
Left m a
comp)

getMemoIO :: MonadIO m => MemoIO m a -> m a
getMemoIO :: forall (m :: Type -> Type) a. MonadIO m => MemoIO m a -> m a
getMemoIO (MemoIO IORef (Either (m a) a)
ref) = IO (Either (m a) a) -> m (Either (m a) a)
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IORef (Either (m a) a) -> IO (Either (m a) a)
forall a. IORef a -> IO a
readIORef IORef (Either (m a) a)
ref) m (Either (m a) a) -> (Either (m a) a -> m a) -> m a
forall a b. m a -> (a -> m b) -> m b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  Left m a
comp -> do
    a
res <- m a
comp
    IO () -> m ()
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef (Either (m a) a) -> Either (m a) a -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Either (m a) a)
ref (Either (m a) a -> IO ()) -> Either (m a) a -> IO ()
forall a b. (a -> b) -> a -> b
$ a -> Either (m a) a
forall a b. b -> Either a b
Right a
res
    a -> m a
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return a
res
  Right a
res -> a -> m a
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return a
res


-- | Check if @LLVMPtr sym w@ points inside an allocation that is backed
--   by an SMT array store. If true, return a predicate that indicates
--   when the given array backs the given pointer, the SMT array,
--   and the size of the allocation.
--
--   NOTE: this operation is linear in the size of the list of previous
--   memory writes. This means that memory writes as well as memory reads
--   require a traversal of the list of previous writes. The performance
--   of this operation can be improved by using a map to index the writes
--   by allocation index.
asMemAllocationArrayStore ::
  forall sym w .
  (IsSymInterface sym, 1 <= w) =>
  sym ->
  NatRepr w ->
  LLVMPtr sym w {- ^ Pointer -} ->
  Mem sym ->
  IO (Maybe (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8), (SymBV sym w)))
asMemAllocationArrayStore :: forall sym (w :: Natural).
(IsSymInterface sym, 1 <= w) =>
sym
-> NatRepr w
-> LLVMPtr sym w
-> Mem sym
-> IO
     (Maybe
        (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8),
         SymBV sym w))
asMemAllocationArrayStore sym
sym NatRepr w
w LLVMPtr sym w
ptr Mem sym
mem
  | Just Natural
blk_no <- SymNat sym -> Maybe Natural
forall sym. IsExpr (SymExpr sym) => SymNat sym -> Maybe Natural
asNat (LLVMPtr sym w -> SymNat sym
forall sym (w :: Natural). LLVMPtr sym w -> SymNat sym
llvmPointerBlock LLVMPtr sym w
ptr)
  , SymNat sym -> Mem sym -> Bool
forall sym. IsExprBuilder sym => SymNat sym -> Mem sym -> Bool
memMemberArrayBlock (LLVMPtr sym w -> SymNat sym
forall sym (w :: Natural). LLVMPtr sym w -> SymNat sym
llvmPointerBlock LLVMPtr sym w
ptr) Mem sym
mem
  , [SomeAlloc AllocType
_ Natural
_ (Just SymBV sym w
sz) Mutability
_ Alignment
_ [Char]
_] <- [SomeAlloc sym] -> [SomeAlloc sym]
forall a. Eq a => [a] -> [a]
List.nub (Natural -> Mem sym -> [SomeAlloc sym]
forall sym.
IsSymInterface sym =>
Natural -> Mem sym -> [SomeAlloc sym]
possibleAllocs Natural
blk_no Mem sym
mem)
  , 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 NatRepr w
w (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
sz) =
     do MemoIO
  IO
  (Maybe
     (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)))
memo_nothing <- IO
  (Maybe
     (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)))
-> IO
     (MemoIO
        IO
        (Maybe
           (Pred sym,
            SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8))))
forall (m :: Type -> Type) a. MonadIO m => m a -> m (MemoIO m a)
putMemoIO (IO
   (Maybe
      (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)))
 -> IO
      (MemoIO
         IO
         (Maybe
            (Pred sym,
             SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)))))
-> IO
     (Maybe
        (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)))
-> IO
     (MemoIO
        IO
        (Maybe
           (Pred sym,
            SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8))))
forall a b. (a -> b) -> a -> b
$ Maybe
  (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8))
-> IO
     (Maybe
        (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)))
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe
  (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8))
forall a. Maybe a
Nothing
        --putStrLn $ "asMemAllocationArrayStore: base=" ++ show blk_no ++ " sz=" ++ show (printSymExpr sz)
        Maybe
  (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8))
result <- sym
-> NatRepr w
-> Natural
-> BV w
-> SymBV sym w
-> MemoIO
     IO
     (Maybe
        (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)))
-> [MemWrite sym]
-> IO
     (Maybe
        (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)))
forall sym (w :: Natural).
(IsSymInterface sym, 1 <= w) =>
sym
-> NatRepr w
-> Natural
-> BV w
-> SymBV sym w
-> MemoIO
     IO
     (Maybe
        (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)))
-> [MemWrite sym]
-> IO
     (Maybe
        (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)))
findArrayStore sym
sym NatRepr w
w Natural
blk_no (NatRepr w -> BV w
forall (w :: Natural). NatRepr w -> BV w
BV.zero NatRepr w
w) SymBV sym w
SymBV sym w
sz MemoIO
  IO
  (Maybe
     (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)))
memo_nothing ([MemWrite sym]
 -> IO
      (Maybe
         (Pred sym,
          SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8))))
-> [MemWrite sym]
-> IO
     (Maybe
        (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)))
forall a b. (a -> b) -> a -> b
$
          Natural -> MemWrites sym -> [MemWrite sym]
forall sym. Natural -> MemWrites sym -> [MemWrite sym]
memWritesAtConstant Natural
blk_no (MemWrites sym -> [MemWrite sym])
-> MemWrites sym -> [MemWrite sym]
forall a b. (a -> b) -> a -> b
$ Mem sym -> MemWrites sym
forall sym. Mem sym -> MemWrites sym
memWrites Mem sym
mem
        Maybe
  (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8),
   SymBV sym w)
-> IO
     (Maybe
        (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8),
         SymBV sym w))
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Maybe
   (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8),
    SymBV sym w)
 -> IO
      (Maybe
         (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8),
          SymBV sym w)))
-> Maybe
     (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8),
      SymBV sym w)
-> IO
     (Maybe
        (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8),
         SymBV sym w))
forall a b. (a -> b) -> a -> b
$ case Maybe
  (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8))
result of
          Just (Pred sym
ok, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)
arr) -> (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8),
 SymBV sym w)
-> Maybe
     (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8),
      SymBV sym w)
forall a. a -> Maybe a
Just (Pred sym
ok, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)
arr, SymBV sym w
SymBV sym w
sz)
          Maybe
  (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8))
Nothing -> Maybe
  (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8),
   SymBV sym w)
forall a. Maybe a
Nothing

  | Bool
otherwise = Maybe
  (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8),
   SymBV sym w)
-> IO
     (Maybe
        (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8),
         SymBV sym w))
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe
  (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8),
   SymBV sym w)
forall a. Maybe a
Nothing

asMemMatchingArrayStore ::
  (IsSymInterface sym, 1 <= w) =>
  sym ->
  NatRepr w ->
  LLVMPtr sym w ->
  SymBV sym w ->
  Mem sym ->
  IO (Maybe (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)))
asMemMatchingArrayStore :: forall sym (w :: Natural).
(IsSymInterface sym, 1 <= w) =>
sym
-> NatRepr w
-> LLVMPtr sym w
-> SymBV sym w
-> Mem sym
-> IO
     (Maybe
        (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)))
asMemMatchingArrayStore sym
sym NatRepr w
w LLVMPtr sym w
ptr SymBV sym w
sz Mem sym
mem
  | Just Natural
blk_no <- SymNat sym -> Maybe Natural
forall sym. IsExpr (SymExpr sym) => SymNat sym -> Maybe Natural
asNat (LLVMPtr sym w -> SymNat sym
forall sym (w :: Natural). LLVMPtr sym w -> SymNat sym
llvmPointerBlock LLVMPtr sym w
ptr)
  , SymNat sym -> Mem sym -> Bool
forall sym. IsExprBuilder sym => SymNat sym -> Mem sym -> Bool
memMemberArrayBlock (LLVMPtr sym w -> SymNat sym
forall sym (w :: Natural). LLVMPtr sym w -> SymNat sym
llvmPointerBlock LLVMPtr sym w
ptr) Mem sym
mem
  , Just BV w
off <- SymBV sym w -> Maybe (BV w)
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 w -> SymBV sym w
forall sym (w :: Natural). LLVMPtr sym w -> SymBV sym w
llvmPointerOffset LLVMPtr sym w
ptr) = do
    --putStrLn $ "asMemMatchingArrayStore: ptr=" ++ show (blk_no, off) ++ " sz=" ++ show (printSymExpr sz)
    MemoIO
  IO
  (Maybe
     (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)))
memo_nothing <- IO
  (Maybe
     (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)))
-> IO
     (MemoIO
        IO
        (Maybe
           (Pred sym,
            SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8))))
forall (m :: Type -> Type) a. MonadIO m => m a -> m (MemoIO m a)
putMemoIO (IO
   (Maybe
      (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)))
 -> IO
      (MemoIO
         IO
         (Maybe
            (Pred sym,
             SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)))))
-> IO
     (Maybe
        (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)))
-> IO
     (MemoIO
        IO
        (Maybe
           (Pred sym,
            SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8))))
forall a b. (a -> b) -> a -> b
$ Maybe
  (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8))
-> IO
     (Maybe
        (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)))
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe
  (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8))
forall a. Maybe a
Nothing
    sym
-> NatRepr w
-> Natural
-> BV w
-> SymBV sym w
-> MemoIO
     IO
     (Maybe
        (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)))
-> [MemWrite sym]
-> IO
     (Maybe
        (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)))
forall sym (w :: Natural).
(IsSymInterface sym, 1 <= w) =>
sym
-> NatRepr w
-> Natural
-> BV w
-> SymBV sym w
-> MemoIO
     IO
     (Maybe
        (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)))
-> [MemWrite sym]
-> IO
     (Maybe
        (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)))
findArrayStore sym
sym NatRepr w
w Natural
blk_no BV w
off SymBV sym w
sz MemoIO
  IO
  (Maybe
     (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)))
memo_nothing ([MemWrite sym]
 -> IO
      (Maybe
         (Pred sym,
          SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8))))
-> [MemWrite sym]
-> IO
     (Maybe
        (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)))
forall a b. (a -> b) -> a -> b
$ Natural -> MemWrites sym -> [MemWrite sym]
forall sym. Natural -> MemWrites sym -> [MemWrite sym]
memWritesAtConstant Natural
blk_no (MemWrites sym -> [MemWrite sym])
-> MemWrites sym -> [MemWrite sym]
forall a b. (a -> b) -> a -> b
$ Mem sym -> MemWrites sym
forall sym. Mem sym -> MemWrites sym
memWrites Mem sym
mem
  | Bool
otherwise = Maybe
  (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8))
-> IO
     (Maybe
        (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)))
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe
  (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8))
forall a. Maybe a
Nothing

findArrayStore ::
  (IsSymInterface sym, 1 <= w) =>
  sym ->
  NatRepr w ->
  Natural ->
  BV w ->
  SymBV sym w ->
  MemoIO IO (Maybe (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8))) ->
  [MemWrite sym] ->
  IO (Maybe (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)))
findArrayStore :: forall sym (w :: Natural).
(IsSymInterface sym, 1 <= w) =>
sym
-> NatRepr w
-> Natural
-> BV w
-> SymBV sym w
-> MemoIO
     IO
     (Maybe
        (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)))
-> [MemWrite sym]
-> IO
     (Maybe
        (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)))
findArrayStore sym
sym NatRepr w
w Natural
blk_no BV w
off SymBV sym w
sz MemoIO
  IO
  (Maybe
     (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)))
memo_cont = \case
  [] -> MemoIO
  IO
  (Maybe
     (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)))
-> IO
     (Maybe
        (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)))
forall (m :: Type -> Type) a. MonadIO m => MemoIO m a -> m a
getMemoIO MemoIO
  IO
  (Maybe
     (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)))
memo_cont
  MemWrite sym
head_mem_write : [MemWrite sym]
tail_mem_writes -> do
   --putStrLn $ "  findArrayStore: ptr=" ++ show (blk_no, off) ++ " sz=" ++ show (printSymExpr sz)
   --putStrLn $ "  findArrayStore: write=" ++ (case head_mem_write of MemWrite{} -> "write"; WriteMerge{} -> "merge")

   case MemWrite sym
head_mem_write of
    MemWrite LLVMPtr sym w
write_ptr WriteSource sym w
write_source
      | Just Natural
write_blk_no <- SymNat sym -> Maybe Natural
forall sym. IsExpr (SymExpr sym) => SymNat sym -> Maybe Natural
asNat (LLVMPtr sym w -> SymNat sym
forall sym (w :: Natural). LLVMPtr sym w -> SymNat sym
llvmPointerBlock LLVMPtr sym w
write_ptr)
      , Natural
blk_no Natural -> Natural -> Bool
forall a. Eq a => a -> a -> Bool
== Natural
write_blk_no
      , 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 NatRepr w
w (LLVMPtr sym w -> NatRepr w
forall sym (w :: Natural).
IsExprBuilder sym =>
LLVMPtr sym w -> NatRepr w
ptrWidth LLVMPtr sym w
write_ptr)
      , Just BV w
write_off <- SymBV sym w -> Maybe (BV w)
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 w -> SymBV sym w
forall sym (w :: Natural). LLVMPtr sym w -> SymBV sym w
llvmPointerOffset LLVMPtr sym w
LLVMPtr sym w
write_ptr)
      , BV w
off BV w -> BV w -> Bool
forall a. Eq a => a -> a -> Bool
== BV w
write_off
      , MemArrayStore SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)
arr (Just SymBV sym w
arr_store_sz) <- WriteSource sym w
write_source -> do
        Pred sym
ok <- sym -> SymBV sym w -> SymBV sym w -> 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)
bvEq sym
sym SymBV sym w
sz SymBV sym w
SymBV sym w
arr_store_sz
        Maybe
  (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8))
-> IO
     (Maybe
        (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)))
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ((Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8))
-> Maybe
     (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8))
forall a. a -> Maybe a
Just (Pred sym
ok, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)
SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)
arr))

      | Just Natural
write_blk_no <- SymNat sym -> Maybe Natural
forall sym. IsExpr (SymExpr sym) => SymNat sym -> Maybe Natural
asNat (LLVMPtr sym w -> SymNat sym
forall sym (w :: Natural). LLVMPtr sym w -> SymNat sym
llvmPointerBlock LLVMPtr sym w
write_ptr)
      , Natural
blk_no Natural -> Natural -> Bool
forall a. Eq a => a -> a -> Bool
== Natural
write_blk_no
      , 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 NatRepr w
w (LLVMPtr sym w -> NatRepr w
forall sym (w :: Natural).
IsExprBuilder sym =>
LLVMPtr sym w -> NatRepr w
ptrWidth LLVMPtr sym w
write_ptr)
      , Just BV w
write_off <- SymBV sym w -> Maybe (BV w)
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 w -> SymBV sym w
forall sym (w :: Natural). LLVMPtr sym w -> SymBV sym w
llvmPointerOffset LLVMPtr sym w
LLVMPtr sym w
write_ptr)
      , Just BV w
sz_bv <- SymBV sym w -> Maybe (BV w)
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 SymBV sym w
sz
      , MemCopy LLVMPtr sym w
src_ptr SymBV sym w
mem_copy_sz <- WriteSource sym w
write_source
      , Just BV w
mem_copy_sz_bv <- SymBV sym w -> Maybe (BV w)
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 SymBV sym w
SymBV sym w
mem_copy_sz
      , BV w -> BV w -> Bool
forall (w :: Natural). BV w -> BV w -> Bool
BV.ule BV w
write_off BV w
off
      , BV w -> BV w -> Bool
forall (w :: Natural). BV w -> BV w -> Bool
BV.ule (NatRepr w -> BV w -> BV w -> BV w
forall (w :: Natural). NatRepr w -> BV w -> BV w -> BV w
BV.add NatRepr w
w BV w
off BV w
sz_bv) (NatRepr w -> BV w -> BV w -> BV w
forall (w :: Natural). NatRepr w -> BV w -> BV w -> BV w
BV.add NatRepr w
w BV w
write_off BV w
mem_copy_sz_bv)
      , Just Natural
src_blk_no <- SymNat sym -> Maybe Natural
forall sym. IsExpr (SymExpr sym) => SymNat sym -> Maybe Natural
asNat (LLVMPtr sym w -> SymNat sym
forall sym (w :: Natural). LLVMPtr sym w -> SymNat sym
llvmPointerBlock LLVMPtr sym w
LLVMPtr sym w
src_ptr)
      , Just BV w
src_off <- SymBV sym w -> Maybe (BV w)
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 w -> SymBV sym w
forall sym (w :: Natural). LLVMPtr sym w -> SymBV sym w
llvmPointerOffset LLVMPtr sym w
LLVMPtr sym w
src_ptr) ->
        sym
-> NatRepr w
-> Natural
-> BV w
-> SymBV sym w
-> MemoIO
     IO
     (Maybe
        (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)))
-> [MemWrite sym]
-> IO
     (Maybe
        (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)))
forall sym (w :: Natural).
(IsSymInterface sym, 1 <= w) =>
sym
-> NatRepr w
-> Natural
-> BV w
-> SymBV sym w
-> MemoIO
     IO
     (Maybe
        (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)))
-> [MemWrite sym]
-> IO
     (Maybe
        (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)))
findArrayStore sym
sym NatRepr w
w Natural
src_blk_no (NatRepr w -> BV w -> BV w -> BV w
forall (w :: Natural). NatRepr w -> BV w -> BV w -> BV w
BV.add NatRepr w
w BV w
src_off (BV w -> BV w) -> BV w -> BV w
forall a b. (a -> b) -> a -> b
$ NatRepr w -> BV w -> BV w -> BV w
forall (w :: Natural). NatRepr w -> BV w -> BV w -> BV w
BV.sub NatRepr w
w BV w
off BV w
write_off) SymBV sym w
sz MemoIO
  IO
  (Maybe
     (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)))
memo_cont [MemWrite sym]
tail_mem_writes

      | Just Natural
write_blk_no <- SymNat sym -> Maybe Natural
forall sym. IsExpr (SymExpr sym) => SymNat sym -> Maybe Natural
asNat (LLVMPtr sym w -> SymNat sym
forall sym (w :: Natural). LLVMPtr sym w -> SymNat sym
llvmPointerBlock LLVMPtr sym w
write_ptr)
      , Natural
blk_no Natural -> Natural -> Bool
forall a. Eq a => a -> a -> Bool
== Natural
write_blk_no
      , 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 NatRepr w
w (LLVMPtr sym w -> NatRepr w
forall sym (w :: Natural).
IsExprBuilder sym =>
LLVMPtr sym w -> NatRepr w
ptrWidth LLVMPtr sym w
write_ptr)
      , Just BV w
write_off <- SymBV sym w -> Maybe (BV w)
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 w -> SymBV sym w
forall sym (w :: Natural). LLVMPtr sym w -> SymBV sym w
llvmPointerOffset LLVMPtr sym w
LLVMPtr sym w
write_ptr)
      , Just BV w
sz_bv <- SymBV sym w -> Maybe (BV w)
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 SymBV sym w
sz
      , MemSet SymBV sym 8
val SymBV sym w
mem_set_sz <- WriteSource sym w
write_source
      , Just BV w
mem_set_sz_bv <- SymBV sym w -> Maybe (BV w)
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 SymBV sym w
SymBV sym w
mem_set_sz
      , BV w -> BV w -> Bool
forall (w :: Natural). BV w -> BV w -> Bool
BV.ule BV w
write_off BV w
off
      , BV w -> BV w -> Bool
forall (w :: Natural). BV w -> BV w -> Bool
BV.ule (NatRepr w -> BV w -> BV w -> BV w
forall (w :: Natural). NatRepr w -> BV w -> BV w -> BV w
BV.add NatRepr w
w BV w
off BV w
sz_bv) (NatRepr w -> BV w -> BV w -> BV w
forall (w :: Natural). NatRepr w -> BV w -> BV w -> BV w
BV.add NatRepr w
w BV w
write_off BV w
mem_set_sz_bv) -> do
        SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)
arr <- sym
-> Assignment BaseTypeRepr (SingleCtx (BaseBVType w))
-> SymBV sym 8
-> IO (SymArray sym (SingleCtx (BaseBVType w)) (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 w)
-> Assignment BaseTypeRepr (SingleCtx (BaseBVType w))
forall {k} (f :: k -> Type) (tp :: k).
f tp -> Assignment f (EmptyCtx ::> tp)
Ctx.singleton (BaseTypeRepr (BaseBVType w)
 -> Assignment BaseTypeRepr (SingleCtx (BaseBVType w)))
-> BaseTypeRepr (BaseBVType w)
-> Assignment BaseTypeRepr (SingleCtx (BaseBVType w))
forall a b. (a -> b) -> a -> b
$ NatRepr w -> BaseTypeRepr (BaseBVType w)
forall (w :: Natural).
(1 <= w) =>
NatRepr w -> BaseTypeRepr ('BaseBVType w)
BaseBVRepr NatRepr w
w) SymBV sym 8
val
        Maybe
  (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8))
-> IO
     (Maybe
        (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)))
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Maybe
   (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8))
 -> IO
      (Maybe
         (Pred sym,
          SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8))))
-> Maybe
     (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8))
-> IO
     (Maybe
        (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)))
forall a b. (a -> b) -> a -> b
$ (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8))
-> Maybe
     (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8))
forall a. a -> Maybe a
Just (sym -> Pred sym
forall sym. IsExprBuilder sym => sym -> Pred sym
truePred sym
sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)
arr)

      | Just Natural
write_blk_no <- SymNat sym -> Maybe Natural
forall sym. IsExpr (SymExpr sym) => SymNat sym -> Maybe Natural
asNat (LLVMPtr sym w -> SymNat sym
forall sym (w :: Natural). LLVMPtr sym w -> SymNat sym
llvmPointerBlock LLVMPtr sym w
write_ptr)
      , Natural
blk_no Natural -> Natural -> Bool
forall a. Eq a => a -> a -> Bool
== Natural
write_blk_no
      , 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 NatRepr w
w (LLVMPtr sym w -> NatRepr w
forall sym (w :: Natural).
IsExprBuilder sym =>
LLVMPtr sym w -> NatRepr w
ptrWidth LLVMPtr sym w
write_ptr)
      , Just BV w
write_off <- SymBV sym w -> Maybe (BV w)
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 w -> SymBV sym w
forall sym (w :: Natural). LLVMPtr sym w -> SymBV sym w
llvmPointerOffset LLVMPtr sym w
LLVMPtr sym w
write_ptr) -> do
        Maybe (SymBV sym w)
maybe_write_sz <- MaybeT IO (SymBV sym w) -> IO (Maybe (SymBV sym w))
forall (m :: Type -> Type) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT IO (SymBV sym w) -> IO (Maybe (SymBV sym w)))
-> MaybeT IO (SymBV sym w) -> IO (Maybe (SymBV sym w))
forall a b. (a -> b) -> a -> b
$ sym -> NatRepr w -> WriteSource sym w -> MaybeT IO (SymBV sym w)
forall sym (w :: Natural).
(IsExprBuilder sym, 1 <= w) =>
sym -> NatRepr w -> WriteSource sym w -> MaybeT IO (SymBV sym w)
writeSourceSize sym
sym NatRepr w
w WriteSource sym w
WriteSource sym w
write_source
        case Maybe (SymBV sym w)
maybe_write_sz of
          Just SymBV sym w
write_sz
            | Just BV w
sz_bv <- SymBV sym w -> Maybe (BV w)
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 SymBV sym w
sz
            , Just BV w
write_sz_bv <- SymBV sym w -> Maybe (BV w)
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 SymBV sym w
write_sz
            , BV w
end <- NatRepr w -> BV w -> BV w -> BV w
forall (w :: Natural). NatRepr w -> BV w -> BV w -> BV w
BV.add NatRepr w
w BV w
off BV w
sz_bv
            , BV w
write_end <- NatRepr w -> BV w -> BV w -> BV w
forall (w :: Natural). NatRepr w -> BV w -> BV w -> BV w
BV.add NatRepr w
w BV w
write_off BV w
write_sz_bv
            , BV w -> BV w -> Bool
forall (w :: Natural). BV w -> BV w -> Bool
BV.ule BV w
end BV w
write_off Bool -> Bool -> Bool
|| BV w -> BV w -> Bool
forall (w :: Natural). BV w -> BV w -> Bool
BV.ule BV w
write_end BV w
off ->
              sym
-> NatRepr w
-> Natural
-> BV w
-> SymBV sym w
-> MemoIO
     IO
     (Maybe
        (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)))
-> [MemWrite sym]
-> IO
     (Maybe
        (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)))
forall sym (w :: Natural).
(IsSymInterface sym, 1 <= w) =>
sym
-> NatRepr w
-> Natural
-> BV w
-> SymBV sym w
-> MemoIO
     IO
     (Maybe
        (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)))
-> [MemWrite sym]
-> IO
     (Maybe
        (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)))
findArrayStore sym
sym NatRepr w
w Natural
blk_no BV w
off SymBV sym w
sz MemoIO
  IO
  (Maybe
     (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)))
memo_cont [MemWrite sym]
tail_mem_writes
          Maybe (SymBV sym w)
_ -> Maybe
  (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8))
-> IO
     (Maybe
        (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)))
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe
  (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8))
forall a. Maybe a
Nothing

      | Just Natural
write_blk_no <- SymNat sym -> Maybe Natural
forall sym. IsExpr (SymExpr sym) => SymNat sym -> Maybe Natural
asNat (LLVMPtr sym w -> SymNat sym
forall sym (w :: Natural). LLVMPtr sym w -> SymNat sym
llvmPointerBlock LLVMPtr sym w
write_ptr)
      , Natural
blk_no Natural -> Natural -> Bool
forall a. Eq a => a -> a -> Bool
/= Natural
write_blk_no ->
        sym
-> NatRepr w
-> Natural
-> BV w
-> SymBV sym w
-> MemoIO
     IO
     (Maybe
        (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)))
-> [MemWrite sym]
-> IO
     (Maybe
        (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)))
forall sym (w :: Natural).
(IsSymInterface sym, 1 <= w) =>
sym
-> NatRepr w
-> Natural
-> BV w
-> SymBV sym w
-> MemoIO
     IO
     (Maybe
        (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)))
-> [MemWrite sym]
-> IO
     (Maybe
        (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)))
findArrayStore sym
sym NatRepr w
w Natural
blk_no BV w
off SymBV sym w
sz MemoIO
  IO
  (Maybe
     (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)))
memo_cont [MemWrite sym]
tail_mem_writes

      | Bool
otherwise -> Maybe
  (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8))
-> IO
     (Maybe
        (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)))
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe
  (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8))
forall a. Maybe a
Nothing

    WriteMerge Pred sym
cond MemWrites sym
lhs_mem_writes MemWrites sym
rhs_mem_writes -> do
      -- Only traverse the tail if necessary, and be careful
      -- only to traverse it once
      MemoIO
  IO
  (Maybe
     (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)))
memo_tail <- IO
  (Maybe
     (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)))
-> IO
     (MemoIO
        IO
        (Maybe
           (Pred sym,
            SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8))))
forall (m :: Type -> Type) a. MonadIO m => m a -> m (MemoIO m a)
putMemoIO (IO
   (Maybe
      (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)))
 -> IO
      (MemoIO
         IO
         (Maybe
            (Pred sym,
             SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)))))
-> IO
     (Maybe
        (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)))
-> IO
     (MemoIO
        IO
        (Maybe
           (Pred sym,
            SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8))))
forall a b. (a -> b) -> a -> b
$ sym
-> NatRepr w
-> Natural
-> BV w
-> SymBV sym w
-> MemoIO
     IO
     (Maybe
        (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)))
-> [MemWrite sym]
-> IO
     (Maybe
        (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)))
forall sym (w :: Natural).
(IsSymInterface sym, 1 <= w) =>
sym
-> NatRepr w
-> Natural
-> BV w
-> SymBV sym w
-> MemoIO
     IO
     (Maybe
        (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)))
-> [MemWrite sym]
-> IO
     (Maybe
        (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)))
findArrayStore sym
sym NatRepr w
w Natural
blk_no BV w
off SymBV sym w
sz MemoIO
  IO
  (Maybe
     (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)))
memo_cont [MemWrite sym]
tail_mem_writes

      Maybe
  (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8))
lhs_result <- sym
-> NatRepr w
-> Natural
-> BV w
-> SymBV sym w
-> MemoIO
     IO
     (Maybe
        (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)))
-> [MemWrite sym]
-> IO
     (Maybe
        (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)))
forall sym (w :: Natural).
(IsSymInterface sym, 1 <= w) =>
sym
-> NatRepr w
-> Natural
-> BV w
-> SymBV sym w
-> MemoIO
     IO
     (Maybe
        (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)))
-> [MemWrite sym]
-> IO
     (Maybe
        (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)))
findArrayStore sym
sym NatRepr w
w Natural
blk_no BV w
off SymBV sym w
sz MemoIO
  IO
  (Maybe
     (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)))
memo_tail (Natural -> MemWrites sym -> [MemWrite sym]
forall sym. Natural -> MemWrites sym -> [MemWrite sym]
memWritesAtConstant Natural
blk_no MemWrites sym
lhs_mem_writes)
      Maybe
  (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8))
rhs_result <- sym
-> NatRepr w
-> Natural
-> BV w
-> SymBV sym w
-> MemoIO
     IO
     (Maybe
        (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)))
-> [MemWrite sym]
-> IO
     (Maybe
        (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)))
forall sym (w :: Natural).
(IsSymInterface sym, 1 <= w) =>
sym
-> NatRepr w
-> Natural
-> BV w
-> SymBV sym w
-> MemoIO
     IO
     (Maybe
        (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)))
-> [MemWrite sym]
-> IO
     (Maybe
        (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)))
findArrayStore sym
sym NatRepr w
w Natural
blk_no BV w
off SymBV sym w
sz MemoIO
  IO
  (Maybe
     (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)))
memo_tail (Natural -> MemWrites sym -> [MemWrite sym]
forall sym. Natural -> MemWrites sym -> [MemWrite sym]
memWritesAtConstant Natural
blk_no MemWrites sym
rhs_mem_writes)

      case (Maybe
  (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8))
lhs_result, Maybe
  (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8))
rhs_result) of
        (Just (Pred sym
lhs_ok, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)
lhs_arr), Just (Pred sym
rhs_ok, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)
rhs_arr)) ->
           do Pred sym
ok <- sym -> Pred sym -> Pred sym -> Pred sym -> IO (Pred sym)
forall sym.
IsExprBuilder sym =>
sym -> Pred sym -> Pred sym -> Pred sym -> IO (Pred sym)
itePred sym
sym Pred sym
cond Pred sym
lhs_ok Pred sym
rhs_ok
              SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)
arr <- sym
-> Pred sym
-> SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)
-> SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)
-> IO (SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8))
forall sym (idx :: Ctx BaseType) (b :: BaseType).
IsExprBuilder sym =>
sym
-> Pred sym
-> SymArray sym idx b
-> SymArray sym idx b
-> IO (SymArray sym idx b)
forall (idx :: Ctx BaseType) (b :: BaseType).
sym
-> Pred sym
-> SymArray sym idx b
-> SymArray sym idx b
-> IO (SymArray sym idx b)
arrayIte sym
sym Pred sym
cond SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)
lhs_arr SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)
rhs_arr
              Maybe
  (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8))
-> IO
     (Maybe
        (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)))
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ((Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8))
-> Maybe
     (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8))
forall a. a -> Maybe a
Just (Pred sym
ok,SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)
arr))

        (Just (Pred sym
lhs_ok, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)
lhs_arr), Maybe
  (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8))
Nothing) ->
           do Pred sym
ok <- 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
cond Pred sym
lhs_ok
              Maybe
  (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8))
-> IO
     (Maybe
        (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)))
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ((Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8))
-> Maybe
     (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8))
forall a. a -> Maybe a
Just (Pred sym
ok, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)
lhs_arr))

        (Maybe
  (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8))
Nothing, Just (Pred sym
rhs_ok, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)
rhs_arr)) ->
           do Pred sym
cond' <- sym -> Pred sym -> IO (Pred sym)
forall sym. IsExprBuilder sym => sym -> Pred sym -> IO (Pred sym)
notPred sym
sym Pred sym
cond
              Pred sym
ok <- 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
cond' Pred sym
rhs_ok
              Maybe
  (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8))
-> IO
     (Maybe
        (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)))
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ((Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8))
-> Maybe
     (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8))
forall a. a -> Maybe a
Just (Pred sym
ok, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)
rhs_arr))

        (Maybe
  (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8))
Nothing, Maybe
  (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8))
Nothing) -> Maybe
  (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8))
-> IO
     (Maybe
        (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)))
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Maybe
  (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8))
forall a. Maybe a
Nothing


{- Note [Memory Model Design]

At a high level, the memory model is represented as a list of memory writes
(with embedded muxes).  Reads from the memory model are accomplished by
1. Traversing backwards in the write log until the most recent write to each byte
   needed to satisfy the read has been covered by a write
2. Re-assembling the read value from fragments of those writes

This story is slightly complicated by optimizations and the fact that memory
regions can be represented in two different ways:
- "plain" allocations that are represented as symbolic bytes managed explicitly by the memory model, and
- Symbolic array storage backed by SMT arrays

The former allow for significant optimizations that lead to smaller formulas for
the underlying SMT solver.  The latter support symbolic reads efficiently.  The
former also supports symbolic reads, at the cost of extremely expensive and
large muxes.

* Memory Writes

The entry point for writing values to memory is 'writeMem' (which is just a
wrapper around 'writeMemWithAllocationCheck').  Writing a value to memory is
relatively simple, with only two major cases to consider.

The first case is an optimization over the SMT array backed memory model.  In
this case, the write can be statically determined to be contained entirely
within the bounds of an SMT array.  For efficiency, the memory model employs an
optimization that generates an updated SMT array (via applications of the SMT
`update` operator) and adds a special entry in the write log that shadows the
entire address range covered by that array in the write history (effectively
overwriting the entire backing array).  The goal of this optimization is to
reduce the number of muxes generated in subsequent reads.

In the general case, writing to the memory model adds a write record to the
write log.

* Memory Reads

The entry point for reading is the 'readMem' function.  Reading is more
complicated than writing, as reads can span multiple writes (and also multiple
different allocation types).

The memory reading code has an optimization to match the 'writeMem' case: if a
read is fully-covered by an SMT array, a fast path is taken that generates small
concrete array select terms.

In the fallback case, 'readMem' (via 'readMem'') traverses the write log to
assemble a Part(ial)LLVMVal from multiple writes.  The code is somewhat CPSed
via the 'readPrev' functions in that code.  If the traversal of the write log
finds a write that provides some, but not all, of the bytes covering a read, it
saves those bytes and invokes 'readPrev' to step back through the write log.
See Note [Value Reconstruction] for a description of how bytes from multiple
writes are re-assembled.  Note that the write log is a mix of 'MemWrite's and
'WriteMerge's; the explicit merge markers turn the log into a tree, where the
join points create muxes in the read value.

Note that the partiality in 'Part(ial)LLVMVal's does not refer to fragments of
values.  Instead, it refers to the fact that values may be only defined when
some predicate is true.

* Special Operations

The memory model has special support for memcpy and memset operations, which are
able to support symbolic lengths.  These operations are represented as
distinguished operations in the write log and are incorporated into the results
of reads as appropriate.

-}


{- Note [Value Reconstruction]

When a value is read, it may span multiple writes in memory (as C/C++/machine
code can do all manner of partial writes into the middle of objects).  The
various reading operations thus produce values of type 'ValueCtor' to represent
the reconstruction of values from fragments.  The 'ValueCtor' is essentially a
script in a restricted DSL that reconstructs values.  The "script" is
interpreted by 'genValueCtor'.

The reconstruction scripts are produced by the 'valueLoad', 'symbolicValueLoad',
and 'rangeLoad' functions.  Note that 'rangeLoad' is used for allocations backed
by SMT arrays, and thus always supports symbolic loads. These functions handle
the complexities of handling padding and data type interpretations.  The fast
paths in the read functions are able to call these directly (i.e., when offsets
and sizes are concrete).

-}