{-| This analyzes a Macaw function to compute information about what
information must be available for the code to execute.  It is a key analysis
task needed before deleting unused code.
-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Data.Macaw.Analysis.RegisterUse
  ( -- * Exports for function recovery
    registerUse
  , BlockInvariantMap
  , RegisterUseError(..)
  , RegisterUseErrorReason(..)
  , ppRegisterUseErrorReason
  , RegisterUseErrorTag(..)
    -- ** Input information
  , RegisterUseContext(..)
  , ArchFunType
  , CallRegs(..)
  , PostTermStmtInvariants
  , PostValueMap
  , pvmFind
  , MemSlice(..)
    -- * Architecture specific summarization
  , ArchTermStmtUsageFn
  , RegisterUseM
  , BlockStartConstraints(..)
  , locDomain
  , postCallConstraints
  , BlockUsageSummary(..)
  , RegDependencyMap
  , setRegDep
  , StartInferContext
  , InferState
  , BlockInferValue(..)
  , valueDeps
    -- *** FunPredMap
  , FunPredMap
  , funBlockPreds
    -- ** Inferred information.
  , BlockInvariants
  , biStartConstraints
  , biMemAccessList
  , biPhiLocs
  , biPredPostValues
  , biLocMap
  , biCallFunType
  , biAssignMap
  , LocList(..)
  , StackAnalysis.LocMap(..)
  , StackAnalysis.locMapToList
  , StackAnalysis.BoundLoc(..)
  , MemAccessInfo(..)
  , InitInferValue(..)
    -- *** Mem Access info
  , StmtIndex
    -- *** Use information
  , biAssignIdUsed
  , biWriteUsed
  ) where

import           Control.Lens
import           Control.Monad (unless, when, zipWithM_)
import           Control.Monad.Except (MonadError(..), Except)
import           Control.Monad.Reader (MonadReader(..), ReaderT(..), asks)
import           Control.Monad.State.Strict (MonadState(..), State, StateT, execStateT, evalState, gets, modify)
import qualified Data.Bits as Bits
import qualified Data.ByteString.Char8 as BSC
import qualified Data.ByteString as BS
import           Data.Foldable
import           Data.Kind
import           Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import           Data.Maybe
import           Data.Parameterized
import           Data.Parameterized.Map (MapF)
import qualified Data.Parameterized.Map as MapF
import           Data.Set (Set)
import qualified Data.Set as Set
import           Data.Word (Word64)
import           GHC.Stack
import           Prettyprinter
import           Text.Printf (printf)

import           Data.Macaw.AbsDomain.StackAnalysis as StackAnalysis
import           Data.Macaw.CFG
import           Data.Macaw.CFG.DemandSet
  ( DemandContext
  , archFnHasSideEffects
  )
import           Data.Macaw.Discovery.State
import qualified Data.Macaw.Types as M
import           Data.Macaw.Types hiding (Type)
import           Data.Macaw.Utils.Changed
import           Data.Macaw.AbsDomain.CallParams

import           Data.STRef

import           Data.Parameterized.TH.GADT

-------------------------------------------------------------------------------
-- funBlockPreds

-- | A map from each starting block address @l@ to the addresses of
-- blocks that may jump to @l@.
type FunPredMap w = Map (MemSegmentOff w) [MemSegmentOff w]

-- | Return the FunPredMap for the discovered block function.
funBlockPreds :: DiscoveryFunInfo arch ids -> FunPredMap (ArchAddrWidth arch)
funBlockPreds :: forall arch ids.
DiscoveryFunInfo arch ids -> FunPredMap (ArchAddrWidth arch)
funBlockPreds DiscoveryFunInfo arch ids
info = ([MemSegmentOff (RegAddrWidth (ArchReg arch))]
 -> [MemSegmentOff (RegAddrWidth (ArchReg arch))]
 -> [MemSegmentOff (RegAddrWidth (ArchReg arch))])
-> [(MemSegmentOff (RegAddrWidth (ArchReg arch)),
     [MemSegmentOff (RegAddrWidth (ArchReg arch))])]
-> Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     [MemSegmentOff (RegAddrWidth (ArchReg arch))]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith [MemSegmentOff (RegAddrWidth (ArchReg arch))]
-> [MemSegmentOff (RegAddrWidth (ArchReg arch))]
-> [MemSegmentOff (RegAddrWidth (ArchReg arch))]
forall a. [a] -> [a] -> [a]
(++)
  [ (MemSegmentOff (RegAddrWidth (ArchReg arch))
next, [MemSegmentOff (RegAddrWidth (ArchReg arch))
addr])
  | ParsedBlock arch ids
b <- Map
  (MemSegmentOff (RegAddrWidth (ArchReg arch)))
  (ParsedBlock arch ids)
-> [ParsedBlock arch ids]
forall k a. Map k a -> [a]
Map.elems (DiscoveryFunInfo arch ids
infoDiscoveryFunInfo arch ids
-> Getting
     (Map
        (MemSegmentOff (RegAddrWidth (ArchReg arch)))
        (ParsedBlock arch ids))
     (DiscoveryFunInfo arch ids)
     (Map
        (MemSegmentOff (RegAddrWidth (ArchReg arch)))
        (ParsedBlock arch ids))
-> Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (ParsedBlock arch ids)
forall s a. s -> Getting a s a -> a
^.Getting
  (Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (ParsedBlock arch ids))
  (DiscoveryFunInfo arch ids)
  (Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (ParsedBlock arch ids))
forall arch ids (f :: Type -> Type).
Functor f =>
(Map (ArchSegmentOff arch) (ParsedBlock arch ids)
 -> f (Map (ArchSegmentOff arch) (ParsedBlock arch ids)))
-> DiscoveryFunInfo arch ids -> f (DiscoveryFunInfo arch ids)
parsedBlocks)
    -- Get address of region
  , let addr :: MemSegmentOff (RegAddrWidth (ArchReg arch))
addr = ParsedBlock arch ids -> MemSegmentOff (RegAddrWidth (ArchReg arch))
forall arch ids. ParsedBlock arch ids -> ArchSegmentOff arch
pblockAddr ParsedBlock arch ids
b
    -- get the block successors
  , MemSegmentOff (RegAddrWidth (ArchReg arch))
next <- ParsedTermStmt arch ids
-> [MemSegmentOff (RegAddrWidth (ArchReg arch))]
forall arch ids. ParsedTermStmt arch ids -> [ArchSegmentOff arch]
parsedTermSucc (ParsedBlock arch ids -> ParsedTermStmt arch ids
forall arch ids. ParsedBlock arch ids -> ParsedTermStmt arch ids
pblockTermStmt ParsedBlock arch ids
b)
  ]

-------------------------------------------------------------------------------
-- RegisterUseError

-- | Errors from register use
--
-- Tag parameter used for addition information in tag
data RegisterUseErrorTag e where
  -- | Could not resolve height of call stack at given block
  CallStackHeightError :: RegisterUseErrorTag ()
  -- | The value read at given block and statement index could not
  -- be resolved.
  UnresolvedStackRead :: RegisterUseErrorTag ()
  -- | We do not have support for stack reads.
  UnsupportedCondStackRead :: RegisterUseErrorTag ()
  -- | Call with indirect target
  IndirectCallTarget :: RegisterUseErrorTag ()
  -- | Call target address was not a valid memory location.
  InvalidCallTargetAddress :: RegisterUseErrorTag Word64
  -- | Call target was not a known function.
  CallTargetNotFunctionEntryPoint :: RegisterUseErrorTag Word64
  -- | Could not determine arguments to call.
  UnknownCallTargetArguments :: RegisterUseErrorTag BS.ByteString
  -- | We could not resolve the arguments to a known var-args function.
  ResolutonFailureCallToKnownVarArgsFunction :: RegisterUseErrorTag String
  -- | We do not yet support the calling convention needed for this function.
  UnsupportedCallTargetCallingConvention :: RegisterUseErrorTag BS.ByteString

instance Show (RegisterUseErrorTag e) where
  show :: RegisterUseErrorTag e -> String
show RegisterUseErrorTag e
CallStackHeightError = String
"Symbolic call stack height"
  show RegisterUseErrorTag e
UnresolvedStackRead = String
"Unresolved stack read"
  show RegisterUseErrorTag e
UnsupportedCondStackRead = String
"Conditional stack read"
  show RegisterUseErrorTag e
IndirectCallTarget = String
"Indirect call target"
  show RegisterUseErrorTag e
InvalidCallTargetAddress = String
"Invalid call target address"
  show RegisterUseErrorTag e
CallTargetNotFunctionEntryPoint = String
"Call target not function entry point"
  show RegisterUseErrorTag e
UnknownCallTargetArguments = String
"Unresolved call target arguments"
  show RegisterUseErrorTag e
ResolutonFailureCallToKnownVarArgsFunction = String
"Could not resolve varargs args"
  show RegisterUseErrorTag e
UnsupportedCallTargetCallingConvention = String
"Unsupported calling convention"

$(pure [])

instance TestEquality RegisterUseErrorTag where
  testEquality :: forall a b.
RegisterUseErrorTag a -> RegisterUseErrorTag b -> Maybe (a :~: b)
testEquality = $(structuralTypeEquality [t|RegisterUseErrorTag|] [])

instance OrdF RegisterUseErrorTag where
  compareF :: forall x y.
RegisterUseErrorTag x -> RegisterUseErrorTag y -> OrderingF x y
compareF = $(structuralTypeOrd [t|RegisterUseErrorTag|] [])

data RegisterUseErrorReason = forall e . Reason !(RegisterUseErrorTag e) !e

-- | Errors from register use
data RegisterUseError arch
   = RegisterUseError {
     forall arch. RegisterUseError arch -> ArchSegmentOff arch
ruBlock :: !(ArchSegmentOff arch),
     forall arch. RegisterUseError arch -> Int
ruStmt :: !StmtIndex,
     forall arch. RegisterUseError arch -> RegisterUseErrorReason
ruReason :: !RegisterUseErrorReason
   }

ppRegisterUseErrorReason :: RegisterUseErrorReason -> String
ppRegisterUseErrorReason :: RegisterUseErrorReason -> String
ppRegisterUseErrorReason (Reason RegisterUseErrorTag e
tag e
v) =
  case RegisterUseErrorTag e
tag of
    RegisterUseErrorTag e
CallStackHeightError ->  String
"Could not resolve concrete stack height."
    RegisterUseErrorTag e
UnresolvedStackRead -> String
"Unresolved stack read."
    RegisterUseErrorTag e
UnsupportedCondStackRead -> String
"Unsupported conditional stack read."
    RegisterUseErrorTag e
IndirectCallTarget -> String
"Indirect call target."
    RegisterUseErrorTag e
InvalidCallTargetAddress -> String
"Invalid call target address."
    RegisterUseErrorTag e
CallTargetNotFunctionEntryPoint -> String
"Call target not function entry point."
    RegisterUseErrorTag e
UnknownCallTargetArguments -> String -> ShowS
forall r. PrintfType r => String -> r
printf String
"Unknown arguments to %s." (ByteString -> String
BSC.unpack e
ByteString
v)
    RegisterUseErrorTag e
ResolutonFailureCallToKnownVarArgsFunction -> String
"Could not resolve varargs args."
    RegisterUseErrorTag e
UnsupportedCallTargetCallingConvention -> String
"Unsupported calling convention."

-------------------------------------------------------------------------------
-- InitInferValue

-- | This denotes specific value equalities that invariant inferrences
-- associates with Macaw values.
data InitInferValue arch tp where
  -- | Denotes the value must be the given offset of the stack frame.
  InferredStackOffset :: !(MemInt (ArchAddrWidth arch))
                         -> InitInferValue arch (BVType (ArchAddrWidth arch))
  -- | Denotes the value must be the value passed into the function at
  -- the given register.
  FnStartRegister :: !(ArchReg arch tp)
                  -> InitInferValue arch tp
  -- | Denotes a value is equal to the value stored at the
  -- representative location when the block start.
  --
  -- Note. The location in this must a "representative" location.
  -- Representative locations are those locations chosen to represent
  -- equivalence classes of locations inferred equal by block inference.
  RegEqualLoc :: !(BoundLoc (ArchReg arch) tp)
              -> InitInferValue arch tp

instance ShowF (ArchReg arch) => Show (InitInferValue arch tp) where
  showsPrec :: Int -> InitInferValue arch tp -> ShowS
showsPrec Int
_ (InferredStackOffset MemInt (ArchAddrWidth arch)
o) =
    String -> ShowS
showString String
"(stack_offset " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MemInt (ArchAddrWidth arch) -> ShowS
forall a. Show a => a -> ShowS
shows MemInt (ArchAddrWidth arch)
o ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
")"
  showsPrec Int
_ (FnStartRegister ArchReg arch tp
r) =
    String -> ShowS
showString String
"(saved_reg " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ArchReg arch tp -> ShowS
forall {k} (f :: k -> Type) (tp :: k). ShowF f => f tp -> ShowS
showsF ArchReg arch tp
r ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
")"
  showsPrec Int
_ (RegEqualLoc BoundLoc (ArchReg arch) tp
l) =
    String -> ShowS
showString String
"(block_loc " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc Any -> ShowS
forall a. Show a => a -> ShowS
shows (BoundLoc (ArchReg arch) tp -> Doc Any
forall a ann. Pretty a => a -> Doc ann
forall ann. BoundLoc (ArchReg arch) tp -> Doc ann
pretty BoundLoc (ArchReg arch) tp
l) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
")"

instance ShowF (ArchReg arch) => ShowF (InitInferValue arch)

instance TestEquality (ArchReg arch) => TestEquality (InitInferValue arch) where
  testEquality :: forall (a :: Type) (b :: Type).
InitInferValue arch a -> InitInferValue arch b -> Maybe (a :~: b)
testEquality (InferredStackOffset MemInt (ArchAddrWidth arch)
x) (InferredStackOffset MemInt (ArchAddrWidth arch)
y) =
    if MemInt (ArchAddrWidth arch)
x MemInt (ArchAddrWidth arch) -> MemInt (ArchAddrWidth arch) -> Bool
forall a. Eq a => a -> a -> Bool
== MemInt (ArchAddrWidth arch)
y then (a :~: b) -> Maybe (a :~: b)
forall a. a -> Maybe a
Just a :~: a
a :~: b
forall {k} (a :: k). a :~: a
Refl else Maybe (a :~: b)
forall a. Maybe a
Nothing
  testEquality (FnStartRegister ArchReg arch a
x) (FnStartRegister ArchReg arch b
y) =
    ArchReg arch a -> ArchReg arch b -> Maybe (a :~: b)
forall {k} (f :: k -> Type) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
forall (a :: Type) (b :: Type).
ArchReg arch a -> ArchReg arch b -> Maybe (a :~: b)
testEquality ArchReg arch a
x ArchReg arch b
y
  testEquality (RegEqualLoc BoundLoc (ArchReg arch) a
x) (RegEqualLoc BoundLoc (ArchReg arch) b
y) =
    BoundLoc (ArchReg arch) a
-> BoundLoc (ArchReg arch) b -> Maybe (a :~: b)
forall {k} (f :: k -> Type) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
forall (a :: Type) (b :: Type).
BoundLoc (ArchReg arch) a
-> BoundLoc (ArchReg arch) b -> Maybe (a :~: b)
testEquality BoundLoc (ArchReg arch) a
x BoundLoc (ArchReg arch) b
y
  testEquality InitInferValue arch a
_ InitInferValue arch b
_ = Maybe (a :~: b)
forall a. Maybe a
Nothing

instance OrdF (ArchReg arch) => OrdF (InitInferValue arch) where
  compareF :: forall (x :: Type) (y :: Type).
InitInferValue arch x -> InitInferValue arch y -> OrderingF x y
compareF (InferredStackOffset MemInt (ArchAddrWidth arch)
x) (InferredStackOffset MemInt (ArchAddrWidth arch)
y) =
    Ordering -> OrderingF x x
forall {k} (x :: k). Ordering -> OrderingF x x
fromOrdering (MemInt (ArchAddrWidth arch)
-> MemInt (ArchAddrWidth arch) -> Ordering
forall a. Ord a => a -> a -> Ordering
compare MemInt (ArchAddrWidth arch)
x MemInt (ArchAddrWidth arch)
y)
  compareF (InferredStackOffset MemInt (ArchAddrWidth arch)
_)  InitInferValue arch y
_ = OrderingF x y
forall {k} (x :: k) (y :: k). OrderingF x y
LTF
  compareF InitInferValue arch x
_ (InferredStackOffset MemInt (ArchAddrWidth arch)
_)  = OrderingF x y
forall {k} (x :: k) (y :: k). OrderingF x y
GTF

  compareF (FnStartRegister ArchReg arch x
x) (FnStartRegister ArchReg arch y
y) = ArchReg arch x -> ArchReg arch y -> OrderingF x y
forall k (ktp :: k -> Type) (x :: k) (y :: k).
OrdF ktp =>
ktp x -> ktp y -> OrderingF x y
forall (x :: Type) (y :: Type).
ArchReg arch x -> ArchReg arch y -> OrderingF x y
compareF ArchReg arch x
x ArchReg arch y
y
  compareF (FnStartRegister ArchReg arch x
_) InitInferValue arch y
_ = OrderingF x y
forall {k} (x :: k) (y :: k). OrderingF x y
LTF
  compareF InitInferValue arch x
_ (FnStartRegister ArchReg arch y
_) = OrderingF x y
forall {k} (x :: k) (y :: k). OrderingF x y
GTF

  compareF (RegEqualLoc BoundLoc (ArchReg arch) x
x) (RegEqualLoc BoundLoc (ArchReg arch) y
y) = BoundLoc (ArchReg arch) x
-> BoundLoc (ArchReg arch) y -> OrderingF x y
forall k (ktp :: k -> Type) (x :: k) (y :: k).
OrdF ktp =>
ktp x -> ktp y -> OrderingF x y
forall (x :: Type) (y :: Type).
BoundLoc (ArchReg arch) x
-> BoundLoc (ArchReg arch) y -> OrderingF x y
compareF BoundLoc (ArchReg arch) x
x BoundLoc (ArchReg arch) y
y

------------------------------------------------------------------------
-- BlockStartConstraints

-- | This maps r registers and stack offsets at start of block to
-- inferred information about their value.
--
-- If a register or stack location does not appear here, it
-- is implicitly set to itself.
newtype BlockStartConstraints arch =
  BSC { forall arch.
BlockStartConstraints arch
-> LocMap (ArchReg arch) (InitInferValue arch)
bscLocMap :: LocMap (ArchReg arch) (InitInferValue arch) }

data TypedPair (key :: k -> Type)  (tp :: k) = TypedPair !(key tp) !(key tp)

instance TestEquality k => TestEquality (TypedPair k) where
  testEquality :: forall (a :: k) (b :: k).
TypedPair k a -> TypedPair k b -> Maybe (a :~: b)
testEquality (TypedPair k a
x1 k a
x2) (TypedPair k b
y1 k b
y2) = do
    a :~: b
Refl <- k a -> k b -> Maybe (a :~: b)
forall (a :: k) (b :: k). k a -> k b -> Maybe (a :~: b)
forall {k} (f :: k -> Type) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
testEquality k a
x1 k b
y1
    k a -> k b -> Maybe (a :~: b)
forall (a :: k) (b :: k). k a -> k b -> Maybe (a :~: b)
forall {k} (f :: k -> Type) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
testEquality k a
x2 k b
y2

instance OrdF k => OrdF (TypedPair k) where
  compareF :: forall (x :: k) (y :: k).
TypedPair k x -> TypedPair k y -> OrderingF x y
compareF (TypedPair k x
x1 k x
x2) (TypedPair k y
y1 k y
y2) =
    OrderingF x y -> ((x ~ y) => OrderingF x y) -> OrderingF x y
forall j k (a :: j) (b :: j) (c :: k) (d :: k).
OrderingF a b -> ((a ~ b) => OrderingF c d) -> OrderingF c d
joinOrderingF (k x -> k y -> OrderingF x y
forall (x :: k) (y :: k). k x -> k y -> OrderingF x y
forall k (ktp :: k -> Type) (x :: k) (y :: k).
OrdF ktp =>
ktp x -> ktp y -> OrderingF x y
compareF k x
x1 k y
y1) (k x -> k y -> OrderingF x y
forall (x :: k) (y :: k). k x -> k y -> OrderingF x y
forall k (ktp :: k -> Type) (x :: k) (y :: k).
OrdF ktp =>
ktp x -> ktp y -> OrderingF x y
compareF k x
x2 k y
y2)


-- | Return domain for location in constraints
locDomain :: (MemWidth (ArchAddrWidth arch), OrdF (ArchReg arch))
          => BlockStartConstraints arch
          -> BoundLoc (ArchReg arch) tp
          -> InitInferValue arch tp
locDomain :: forall arch (tp :: Type).
(MemWidth (ArchAddrWidth arch), OrdF (ArchReg arch)) =>
BlockStartConstraints arch
-> BoundLoc (ArchReg arch) tp -> InitInferValue arch tp
locDomain BlockStartConstraints arch
cns BoundLoc (ArchReg arch) tp
l = InitInferValue arch tp
-> Maybe (InitInferValue arch tp) -> InitInferValue arch tp
forall a. a -> Maybe a -> a
fromMaybe (BoundLoc (ArchReg arch) tp -> InitInferValue arch tp
forall arch (tp :: Type).
BoundLoc (ArchReg arch) tp -> InitInferValue arch tp
RegEqualLoc BoundLoc (ArchReg arch) tp
l) (BoundLoc (ArchReg arch) tp
-> LocMap (ArchReg arch) (InitInferValue arch)
-> Maybe (InitInferValue arch tp)
forall (r :: Type -> Type) (tp :: Type) (v :: Type -> Type).
(MemWidth (RegAddrWidth r), OrdF r) =>
BoundLoc r tp -> LocMap r v -> Maybe (v tp)
locLookup BoundLoc (ArchReg arch) tp
l (BlockStartConstraints arch
-> LocMap (ArchReg arch) (InitInferValue arch)
forall arch.
BlockStartConstraints arch
-> LocMap (ArchReg arch) (InitInferValue arch)
bscLocMap BlockStartConstraints arch
cns))

-- | Function for joining constraints on a specific location.
--
-- Used by @joinBlockStartConstraints@ below.
joinInitInferValue :: (MemWidth (ArchAddrWidth arch), OrdF (ArchReg arch))
                      => BlockStartConstraints arch
                         -- ^ New constraints being added to existing one.
                      -> STRef s (LocMap (ArchReg arch) (InitInferValue arch))
                         -- ^ Map from locations to values that will be used in resulr.
                      -> STRef s (MapF (TypedPair (InitInferValue arch)) (BoundLoc (ArchReg arch)))
                         -- ^ Cache that maps (old,new) constraints to
                         -- a location that satisfied those
                         -- constraints in old and new constraint set
                         -- respectively.
                      -> BoundLoc (ArchReg arch) tp
                      -> InitInferValue arch tp
                        -- ^ Old domain for location.
                      -> Changed s ()
joinInitInferValue :: forall arch s (tp :: Type).
(MemWidth (ArchAddrWidth arch), OrdF (ArchReg arch)) =>
BlockStartConstraints arch
-> STRef s (LocMap (ArchReg arch) (InitInferValue arch))
-> STRef
     s
     (MapF (TypedPair (InitInferValue arch)) (BoundLoc (ArchReg arch)))
-> BoundLoc (ArchReg arch) tp
-> InitInferValue arch tp
-> Changed s ()
joinInitInferValue BlockStartConstraints arch
newCns STRef s (LocMap (ArchReg arch) (InitInferValue arch))
cnsRef STRef
  s
  (MapF (TypedPair (InitInferValue arch)) (BoundLoc (ArchReg arch)))
cacheRef BoundLoc (ArchReg arch) tp
l InitInferValue arch tp
oldDomain = do
  case (InitInferValue arch tp
oldDomain, BlockStartConstraints arch
-> BoundLoc (ArchReg arch) tp -> InitInferValue arch tp
forall arch (tp :: Type).
(MemWidth (ArchAddrWidth arch), OrdF (ArchReg arch)) =>
BlockStartConstraints arch
-> BoundLoc (ArchReg arch) tp -> InitInferValue arch tp
locDomain BlockStartConstraints arch
newCns BoundLoc (ArchReg arch) tp
l) of
    (InferredStackOffset MemInt (ArchAddrWidth arch)
i, InferredStackOffset MemInt (ArchAddrWidth arch)
j)
      | MemInt (ArchAddrWidth arch)
i MemInt (ArchAddrWidth arch) -> MemInt (ArchAddrWidth arch) -> Bool
forall a. Eq a => a -> a -> Bool
== MemInt (ArchAddrWidth arch)
j ->
          ST s () -> Changed s ()
forall s a. ST s a -> Changed s a
changedST (ST s () -> Changed s ()) -> ST s () -> Changed s ()
forall a b. (a -> b) -> a -> b
$ STRef s (LocMap (ArchReg arch) (InitInferValue arch))
-> (LocMap (ArchReg arch) (InitInferValue arch)
    -> LocMap (ArchReg arch) (InitInferValue arch))
-> ST s ()
forall s a. STRef s a -> (a -> a) -> ST s ()
modifySTRef STRef s (LocMap (ArchReg arch) (InitInferValue arch))
cnsRef ((LocMap (ArchReg arch) (InitInferValue arch)
  -> LocMap (ArchReg arch) (InitInferValue arch))
 -> ST s ())
-> (LocMap (ArchReg arch) (InitInferValue arch)
    -> LocMap (ArchReg arch) (InitInferValue arch))
-> ST s ()
forall a b. (a -> b) -> a -> b
$ BoundLoc (ArchReg arch) tp
-> InitInferValue arch tp
-> LocMap (ArchReg arch) (InitInferValue arch)
-> LocMap (ArchReg arch) (InitInferValue arch)
forall (r :: Type -> Type) (tp :: Type) (v :: Type -> Type).
OrdF r =>
BoundLoc r tp -> v tp -> LocMap r v -> LocMap r v
nonOverlapLocInsert BoundLoc (ArchReg arch) tp
l InitInferValue arch tp
oldDomain
    (FnStartRegister ArchReg arch tp
rx,  FnStartRegister ArchReg arch tp
ry)
      | Just tp :~: tp
Refl <- ArchReg arch tp -> ArchReg arch tp -> Maybe (tp :~: tp)
forall {k} (f :: k -> Type) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
forall (a :: Type) (b :: Type).
ArchReg arch a -> ArchReg arch b -> Maybe (a :~: b)
testEquality ArchReg arch tp
rx ArchReg arch tp
ry ->
          ST s () -> Changed s ()
forall s a. ST s a -> Changed s a
changedST (ST s () -> Changed s ()) -> ST s () -> Changed s ()
forall a b. (a -> b) -> a -> b
$ STRef s (LocMap (ArchReg arch) (InitInferValue arch))
-> (LocMap (ArchReg arch) (InitInferValue arch)
    -> LocMap (ArchReg arch) (InitInferValue arch))
-> ST s ()
forall s a. STRef s a -> (a -> a) -> ST s ()
modifySTRef STRef s (LocMap (ArchReg arch) (InitInferValue arch))
cnsRef ((LocMap (ArchReg arch) (InitInferValue arch)
  -> LocMap (ArchReg arch) (InitInferValue arch))
 -> ST s ())
-> (LocMap (ArchReg arch) (InitInferValue arch)
    -> LocMap (ArchReg arch) (InitInferValue arch))
-> ST s ()
forall a b. (a -> b) -> a -> b
$ BoundLoc (ArchReg arch) tp
-> InitInferValue arch tp
-> LocMap (ArchReg arch) (InitInferValue arch)
-> LocMap (ArchReg arch) (InitInferValue arch)
forall (r :: Type -> Type) (tp :: Type) (v :: Type -> Type).
OrdF r =>
BoundLoc r tp -> v tp -> LocMap r v -> LocMap r v
nonOverlapLocInsert BoundLoc (ArchReg arch) tp
l InitInferValue arch tp
oldDomain
    (InitInferValue arch tp
_, InitInferValue arch tp
newDomain) -> do
      MapF (TypedPair (InitInferValue arch)) (BoundLoc (ArchReg arch))
c <- ST
  s
  (MapF (TypedPair (InitInferValue arch)) (BoundLoc (ArchReg arch)))
-> Changed
     s
     (MapF (TypedPair (InitInferValue arch)) (BoundLoc (ArchReg arch)))
forall s a. ST s a -> Changed s a
changedST (ST
   s
   (MapF (TypedPair (InitInferValue arch)) (BoundLoc (ArchReg arch)))
 -> Changed
      s
      (MapF (TypedPair (InitInferValue arch)) (BoundLoc (ArchReg arch))))
-> ST
     s
     (MapF (TypedPair (InitInferValue arch)) (BoundLoc (ArchReg arch)))
-> Changed
     s
     (MapF (TypedPair (InitInferValue arch)) (BoundLoc (ArchReg arch)))
forall a b. (a -> b) -> a -> b
$ STRef
  s
  (MapF (TypedPair (InitInferValue arch)) (BoundLoc (ArchReg arch)))
-> ST
     s
     (MapF (TypedPair (InitInferValue arch)) (BoundLoc (ArchReg arch)))
forall s a. STRef s a -> ST s a
readSTRef STRef
  s
  (MapF (TypedPair (InitInferValue arch)) (BoundLoc (ArchReg arch)))
cacheRef
      let p :: TypedPair (InitInferValue arch) tp
p = InitInferValue arch tp
-> InitInferValue arch tp -> TypedPair (InitInferValue arch) tp
forall k (key :: k -> Type) (tp :: k).
key tp -> key tp -> TypedPair key tp
TypedPair InitInferValue arch tp
oldDomain InitInferValue arch tp
newDomain
      case TypedPair (InitInferValue arch) tp
-> MapF (TypedPair (InitInferValue arch)) (BoundLoc (ArchReg arch))
-> Maybe (BoundLoc (ArchReg arch) tp)
forall {v} (k :: v -> Type) (tp :: v) (a :: v -> Type).
OrdF k =>
k tp -> MapF k a -> Maybe (a tp)
MapF.lookup TypedPair (InitInferValue arch) tp
p MapF (TypedPair (InitInferValue arch)) (BoundLoc (ArchReg arch))
c of
        Maybe (BoundLoc (ArchReg arch) tp)
Nothing -> do
          -- This is a new class representative.
          -- New class representives imply that there was a change as
          -- the location in the old domain must not have been a free
          -- class rep.
          Bool -> Changed s ()
forall s. Bool -> Changed s ()
markChanged Bool
True
          ST s () -> Changed s ()
forall s a. ST s a -> Changed s a
changedST (ST s () -> Changed s ()) -> ST s () -> Changed s ()
forall a b. (a -> b) -> a -> b
$ STRef
  s
  (MapF (TypedPair (InitInferValue arch)) (BoundLoc (ArchReg arch)))
-> (MapF
      (TypedPair (InitInferValue arch)) (BoundLoc (ArchReg arch))
    -> MapF
         (TypedPair (InitInferValue arch)) (BoundLoc (ArchReg arch)))
-> ST s ()
forall s a. STRef s a -> (a -> a) -> ST s ()
modifySTRef STRef
  s
  (MapF (TypedPair (InitInferValue arch)) (BoundLoc (ArchReg arch)))
cacheRef ((MapF (TypedPair (InitInferValue arch)) (BoundLoc (ArchReg arch))
  -> MapF
       (TypedPair (InitInferValue arch)) (BoundLoc (ArchReg arch)))
 -> ST s ())
-> (MapF
      (TypedPair (InitInferValue arch)) (BoundLoc (ArchReg arch))
    -> MapF
         (TypedPair (InitInferValue arch)) (BoundLoc (ArchReg arch)))
-> ST s ()
forall a b. (a -> b) -> a -> b
$ TypedPair (InitInferValue arch) tp
-> BoundLoc (ArchReg arch) tp
-> MapF (TypedPair (InitInferValue arch)) (BoundLoc (ArchReg arch))
-> MapF (TypedPair (InitInferValue arch)) (BoundLoc (ArchReg arch))
forall {v} (k :: v -> Type) (tp :: v) (a :: v -> Type).
OrdF k =>
k tp -> a tp -> MapF k a -> MapF k a
MapF.insert TypedPair (InitInferValue arch) tp
p BoundLoc (ArchReg arch) tp
l
        Just BoundLoc (ArchReg arch) tp
prevRep -> do
          -- Mark changed if the old domain was not just a pointer to prevRep.
          case InitInferValue arch tp
-> InitInferValue arch tp -> Maybe (tp :~: tp)
forall {k} (f :: k -> Type) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
forall (a :: Type) (b :: Type).
InitInferValue arch a -> InitInferValue arch b -> Maybe (a :~: b)
testEquality InitInferValue arch tp
oldDomain (BoundLoc (ArchReg arch) tp -> InitInferValue arch tp
forall arch (tp :: Type).
BoundLoc (ArchReg arch) tp -> InitInferValue arch tp
RegEqualLoc BoundLoc (ArchReg arch) tp
prevRep) of
            Just tp :~: tp
_ -> () -> Changed s ()
forall a. a -> Changed s a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ()
            Maybe (tp :~: tp)
Nothing -> Bool -> Changed s ()
forall s. Bool -> Changed s ()
markChanged Bool
True
          ST s () -> Changed s ()
forall s a. ST s a -> Changed s a
changedST (ST s () -> Changed s ()) -> ST s () -> Changed s ()
forall a b. (a -> b) -> a -> b
$ STRef s (LocMap (ArchReg arch) (InitInferValue arch))
-> (LocMap (ArchReg arch) (InitInferValue arch)
    -> LocMap (ArchReg arch) (InitInferValue arch))
-> ST s ()
forall s a. STRef s a -> (a -> a) -> ST s ()
modifySTRef STRef s (LocMap (ArchReg arch) (InitInferValue arch))
cnsRef ((LocMap (ArchReg arch) (InitInferValue arch)
  -> LocMap (ArchReg arch) (InitInferValue arch))
 -> ST s ())
-> (LocMap (ArchReg arch) (InitInferValue arch)
    -> LocMap (ArchReg arch) (InitInferValue arch))
-> ST s ()
forall a b. (a -> b) -> a -> b
$ BoundLoc (ArchReg arch) tp
-> InitInferValue arch tp
-> LocMap (ArchReg arch) (InitInferValue arch)
-> LocMap (ArchReg arch) (InitInferValue arch)
forall (r :: Type -> Type) (tp :: Type) (v :: Type -> Type).
OrdF r =>
BoundLoc r tp -> v tp -> LocMap r v -> LocMap r v
nonOverlapLocInsert BoundLoc (ArchReg arch) tp
l (BoundLoc (ArchReg arch) tp -> InitInferValue arch tp
forall arch (tp :: Type).
BoundLoc (ArchReg arch) tp -> InitInferValue arch tp
RegEqualLoc BoundLoc (ArchReg arch) tp
prevRep)

-- | @joinBlockStartConstraints old new@ returns @Nothing@ if @new@
-- implies constraints in @old@, and otherwise a set of constraints
-- @c@ that implies both @new@ and @old@.
joinBlockStartConstraints :: forall s arch
                          .  (MemWidth (ArchAddrWidth arch), OrdF (ArchReg arch))
                          => BlockStartConstraints arch
                          -> BlockStartConstraints arch
                          -> Changed s (BlockStartConstraints arch)
joinBlockStartConstraints :: forall s arch.
(MemWidth (ArchAddrWidth arch), OrdF (ArchReg arch)) =>
BlockStartConstraints arch
-> BlockStartConstraints arch
-> Changed s (BlockStartConstraints arch)
joinBlockStartConstraints (BSC LocMap (ArchReg arch) (InitInferValue arch)
oldCns) BlockStartConstraints arch
newCns = do
  -- Reference to new constraints
  STRef s (LocMap (ArchReg arch) (InitInferValue arch))
cnsRef <- ST s (STRef s (LocMap (ArchReg arch) (InitInferValue arch)))
-> Changed
     s (STRef s (LocMap (ArchReg arch) (InitInferValue arch)))
forall s a. ST s a -> Changed s a
changedST (ST s (STRef s (LocMap (ArchReg arch) (InitInferValue arch)))
 -> Changed
      s (STRef s (LocMap (ArchReg arch) (InitInferValue arch))))
-> ST s (STRef s (LocMap (ArchReg arch) (InitInferValue arch)))
-> Changed
     s (STRef s (LocMap (ArchReg arch) (InitInferValue arch)))
forall a b. (a -> b) -> a -> b
$ LocMap (ArchReg arch) (InitInferValue arch)
-> ST s (STRef s (LocMap (ArchReg arch) (InitInferValue arch)))
forall a s. a -> ST s (STRef s a)
newSTRef LocMap (ArchReg arch) (InitInferValue arch)
forall (r :: Type -> Type) (v :: Type -> Type). LocMap r v
locMapEmpty
  -- Cache for recording when we have seen class representatives
  STRef
  s
  (MapF (TypedPair (InitInferValue arch)) (BoundLoc (ArchReg arch)))
cacheRef <- ST
  s
  (STRef
     s
     (MapF (TypedPair (InitInferValue arch)) (BoundLoc (ArchReg arch))))
-> Changed
     s
     (STRef
        s
        (MapF (TypedPair (InitInferValue arch)) (BoundLoc (ArchReg arch))))
forall s a. ST s a -> Changed s a
changedST (ST
   s
   (STRef
      s
      (MapF (TypedPair (InitInferValue arch)) (BoundLoc (ArchReg arch))))
 -> Changed
      s
      (STRef
         s
         (MapF
            (TypedPair (InitInferValue arch)) (BoundLoc (ArchReg arch)))))
-> ST
     s
     (STRef
        s
        (MapF (TypedPair (InitInferValue arch)) (BoundLoc (ArchReg arch))))
-> Changed
     s
     (STRef
        s
        (MapF (TypedPair (InitInferValue arch)) (BoundLoc (ArchReg arch))))
forall a b. (a -> b) -> a -> b
$ MapF (TypedPair (InitInferValue arch)) (BoundLoc (ArchReg arch))
-> ST
     s
     (STRef
        s
        (MapF (TypedPair (InitInferValue arch)) (BoundLoc (ArchReg arch))))
forall a s. a -> ST s (STRef s a)
newSTRef MapF (TypedPair (InitInferValue arch)) (BoundLoc (ArchReg arch))
forall {v} (k :: v -> Type) (a :: v -> Type). MapF k a
MapF.empty

  let regFn :: ArchReg arch tp
            -> InitInferValue arch tp
            -> Changed s ()
      regFn :: forall (tp :: Type).
ArchReg arch tp -> InitInferValue arch tp -> Changed s ()
regFn ArchReg arch tp
r InitInferValue arch tp
d = BlockStartConstraints arch
-> STRef s (LocMap (ArchReg arch) (InitInferValue arch))
-> STRef
     s
     (MapF (TypedPair (InitInferValue arch)) (BoundLoc (ArchReg arch)))
-> BoundLoc (ArchReg arch) tp
-> InitInferValue arch tp
-> Changed s ()
forall arch s (tp :: Type).
(MemWidth (ArchAddrWidth arch), OrdF (ArchReg arch)) =>
BlockStartConstraints arch
-> STRef s (LocMap (ArchReg arch) (InitInferValue arch))
-> STRef
     s
     (MapF (TypedPair (InitInferValue arch)) (BoundLoc (ArchReg arch)))
-> BoundLoc (ArchReg arch) tp
-> InitInferValue arch tp
-> Changed s ()
joinInitInferValue BlockStartConstraints arch
newCns STRef s (LocMap (ArchReg arch) (InitInferValue arch))
cnsRef STRef
  s
  (MapF (TypedPair (InitInferValue arch)) (BoundLoc (ArchReg arch)))
cacheRef (ArchReg arch tp -> BoundLoc (ArchReg arch) tp
forall (r :: Type -> Type) (tp :: Type). r tp -> BoundLoc r tp
RegLoc ArchReg arch tp
r) InitInferValue arch tp
d
  (forall (tp :: Type).
 ArchReg arch tp -> InitInferValue arch tp -> Changed s ())
-> MapF (ArchReg arch) (InitInferValue arch) -> Changed s ()
forall {v} (m :: Type -> Type) (ktp :: v -> Type) (f :: v -> Type).
Applicative m =>
(forall (tp :: v). ktp tp -> f tp -> m ()) -> MapF ktp f -> m ()
MapF.traverseWithKey_ ArchReg arch tp -> InitInferValue arch tp -> Changed s ()
forall (tp :: Type).
ArchReg arch tp -> InitInferValue arch tp -> Changed s ()
regFn (LocMap (ArchReg arch) (InitInferValue arch)
-> MapF (ArchReg arch) (InitInferValue arch)
forall (r :: Type -> Type) (v :: Type -> Type).
LocMap r v -> MapF r v
locMapRegs LocMap (ArchReg arch) (InitInferValue arch)
oldCns)

  let stackFn :: MemInt (ArchAddrWidth arch)
              -> MemRepr tp
              -> InitInferValue arch tp
              -> Changed s ()
      stackFn :: forall (tp :: Type).
MemInt (ArchAddrWidth arch)
-> MemRepr tp -> InitInferValue arch tp -> Changed s ()
stackFn MemInt (ArchAddrWidth arch)
o MemRepr tp
r InitInferValue arch tp
d =
        BlockStartConstraints arch
-> STRef s (LocMap (ArchReg arch) (InitInferValue arch))
-> STRef
     s
     (MapF (TypedPair (InitInferValue arch)) (BoundLoc (ArchReg arch)))
-> BoundLoc (ArchReg arch) tp
-> InitInferValue arch tp
-> Changed s ()
forall arch s (tp :: Type).
(MemWidth (ArchAddrWidth arch), OrdF (ArchReg arch)) =>
BlockStartConstraints arch
-> STRef s (LocMap (ArchReg arch) (InitInferValue arch))
-> STRef
     s
     (MapF (TypedPair (InitInferValue arch)) (BoundLoc (ArchReg arch)))
-> BoundLoc (ArchReg arch) tp
-> InitInferValue arch tp
-> Changed s ()
joinInitInferValue BlockStartConstraints arch
newCns STRef s (LocMap (ArchReg arch) (InitInferValue arch))
cnsRef STRef
  s
  (MapF (TypedPair (InitInferValue arch)) (BoundLoc (ArchReg arch)))
cacheRef (MemInt (ArchAddrWidth arch)
-> MemRepr tp -> BoundLoc (ArchReg arch) tp
forall (r :: Type -> Type) (tp :: Type).
MemInt (RegAddrWidth r) -> MemRepr tp -> BoundLoc r tp
StackOffLoc MemInt (ArchAddrWidth arch)
o MemRepr tp
r) InitInferValue arch tp
d
  (forall (tp :: Type).
 MemInt (ArchAddrWidth arch)
 -> MemRepr tp -> InitInferValue arch tp -> Changed s ())
-> MemMap (MemInt (ArchAddrWidth arch)) (InitInferValue arch)
-> Changed s ()
forall (m :: Type -> Type) o (v :: Type -> Type).
Applicative m =>
(forall (tp :: Type). o -> MemRepr tp -> v tp -> m ())
-> MemMap o v -> m ()
memMapTraverseWithKey_ MemInt (ArchAddrWidth arch)
-> MemRepr tp -> InitInferValue arch tp -> Changed s ()
forall (tp :: Type).
MemInt (ArchAddrWidth arch)
-> MemRepr tp -> InitInferValue arch tp -> Changed s ()
stackFn (LocMap (ArchReg arch) (InitInferValue arch)
-> MemMap (MemInt (ArchAddrWidth arch)) (InitInferValue arch)
forall (r :: Type -> Type) (v :: Type -> Type).
LocMap r v -> MemMap (MemInt (RegAddrWidth r)) v
locMapStack LocMap (ArchReg arch) (InitInferValue arch)
oldCns)

  ST s (BlockStartConstraints arch)
-> Changed s (BlockStartConstraints arch)
forall s a. ST s a -> Changed s a
changedST (ST s (BlockStartConstraints arch)
 -> Changed s (BlockStartConstraints arch))
-> ST s (BlockStartConstraints arch)
-> Changed s (BlockStartConstraints arch)
forall a b. (a -> b) -> a -> b
$ LocMap (ArchReg arch) (InitInferValue arch)
-> BlockStartConstraints arch
forall arch.
LocMap (ArchReg arch) (InitInferValue arch)
-> BlockStartConstraints arch
BSC (LocMap (ArchReg arch) (InitInferValue arch)
 -> BlockStartConstraints arch)
-> ST s (LocMap (ArchReg arch) (InitInferValue arch))
-> ST s (BlockStartConstraints arch)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> STRef s (LocMap (ArchReg arch) (InitInferValue arch))
-> ST s (LocMap (ArchReg arch) (InitInferValue arch))
forall s a. STRef s a -> ST s a
readSTRef STRef s (LocMap (ArchReg arch) (InitInferValue arch))
cnsRef

-- | @unionBlockStartConstraints x y@ returns a set of constraints @r@
-- that entails both @x@ and @y@.
unionBlockStartConstraints :: (MemWidth (ArchAddrWidth arch), OrdF (ArchReg arch))
                           => BlockStartConstraints arch
                           -> BlockStartConstraints arch
                           -> BlockStartConstraints arch
unionBlockStartConstraints :: forall arch.
(MemWidth (ArchAddrWidth arch), OrdF (ArchReg arch)) =>
BlockStartConstraints arch
-> BlockStartConstraints arch -> BlockStartConstraints arch
unionBlockStartConstraints BlockStartConstraints arch
n BlockStartConstraints arch
o =
  BlockStartConstraints arch
-> Maybe (BlockStartConstraints arch) -> BlockStartConstraints arch
forall a. a -> Maybe a -> a
fromMaybe BlockStartConstraints arch
o ((forall s. Changed s (BlockStartConstraints arch))
-> Maybe (BlockStartConstraints arch)
forall a. (forall s. Changed s a) -> Maybe a
runChanged (BlockStartConstraints arch
-> BlockStartConstraints arch
-> Changed s (BlockStartConstraints arch)
forall s arch.
(MemWidth (ArchAddrWidth arch), OrdF (ArchReg arch)) =>
BlockStartConstraints arch
-> BlockStartConstraints arch
-> Changed s (BlockStartConstraints arch)
joinBlockStartConstraints BlockStartConstraints arch
o BlockStartConstraints arch
n))

-------------------------------------------------------------------------------
-- StmtIndex

-- | Index of a stmt in a block.
type StmtIndex = Int

-- | This is used to to control which parts of a value we need to read.
data MemSlice wtp rtp where

  NoMemSlice :: MemSlice tp tp
  -- | @MemSlize o w r@ indicates that we read a value of type @r@ @o@ bytes into the write of type @w@.

  MemSlice :: !Integer -- ^ Offset of read relative to write.
           -> !(MemRepr wtp) -- ^ Write repr
           -> !(MemRepr rtp) -- ^ Read repr
           -> MemSlice wtp rtp

deriving instance Show (MemSlice w r)

instance TestEquality (MemSlice wtp) where
  testEquality :: forall (a :: Type) (b :: Type).
MemSlice wtp a -> MemSlice wtp b -> Maybe (a :~: b)
testEquality MemSlice wtp a
NoMemSlice MemSlice wtp b
NoMemSlice = (a :~: b) -> Maybe (a :~: b)
forall a. a -> Maybe a
Just a :~: a
a :~: b
forall {k} (a :: k). a :~: a
Refl
  testEquality (MemSlice Integer
xo MemRepr wtp
xw MemRepr a
xr) (MemSlice Integer
yo MemRepr wtp
yw MemRepr b
yr)
    | Integer
xo Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
yo, Just wtp :~: wtp
Refl <- MemRepr wtp -> MemRepr wtp -> Maybe (wtp :~: wtp)
forall {k} (f :: k -> Type) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
forall (a :: Type) (b :: Type).
MemRepr a -> MemRepr b -> Maybe (a :~: b)
testEquality MemRepr wtp
xw MemRepr wtp
yw = MemRepr a -> MemRepr b -> Maybe (a :~: b)
forall {k} (f :: k -> Type) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
forall (a :: Type) (b :: Type).
MemRepr a -> MemRepr b -> Maybe (a :~: b)
testEquality MemRepr a
xr MemRepr b
yr
  testEquality MemSlice wtp a
_ MemSlice wtp b
_ = Maybe (a :~: b)
forall a. Maybe a
Nothing

joinOrdering :: Ordering -> OrderingF a b -> OrderingF a b
joinOrdering :: forall {k} (a :: k) (b :: k).
Ordering -> OrderingF a b -> OrderingF a b
joinOrdering Ordering
LT OrderingF a b
_ = OrderingF a b
forall {k} (x :: k) (y :: k). OrderingF x y
LTF
joinOrdering Ordering
EQ OrderingF a b
o = OrderingF a b
o
joinOrdering Ordering
GT OrderingF a b
_ = OrderingF a b
forall {k} (x :: k) (y :: k). OrderingF x y
GTF

instance OrdF (MemSlice wtp) where
  compareF :: forall (x :: Type) (y :: Type).
MemSlice wtp x -> MemSlice wtp y -> OrderingF x y
compareF MemSlice wtp x
NoMemSlice MemSlice wtp y
NoMemSlice = OrderingF x x
OrderingF x y
forall {k} (x :: k). OrderingF x x
EQF
  compareF MemSlice wtp x
NoMemSlice MemSlice{} = OrderingF x y
forall {k} (x :: k) (y :: k). OrderingF x y
LTF
  compareF MemSlice{} MemSlice wtp y
NoMemSlice = OrderingF x y
forall {k} (x :: k) (y :: k). OrderingF x y
GTF
  compareF (MemSlice Integer
xo MemRepr wtp
xw MemRepr x
xr) (MemSlice Integer
yo MemRepr wtp
yw MemRepr y
yr) =
    Ordering -> OrderingF x y -> OrderingF x y
forall {k} (a :: k) (b :: k).
Ordering -> OrderingF a b -> OrderingF a b
joinOrdering (Integer -> Integer -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Integer
xo Integer
yo) (OrderingF x y -> OrderingF x y) -> OrderingF x y -> OrderingF x y
forall a b. (a -> b) -> a -> b
$
    OrderingF wtp wtp
-> ((wtp ~ wtp) => OrderingF x y) -> OrderingF x y
forall j k (a :: j) (b :: j) (c :: k) (d :: k).
OrderingF a b -> ((a ~ b) => OrderingF c d) -> OrderingF c d
joinOrderingF (MemRepr wtp -> MemRepr wtp -> OrderingF wtp wtp
forall k (ktp :: k -> Type) (x :: k) (y :: k).
OrdF ktp =>
ktp x -> ktp y -> OrderingF x y
forall (x :: Type) (y :: Type).
MemRepr x -> MemRepr y -> OrderingF x y
compareF MemRepr wtp
xw MemRepr wtp
yw) (((wtp ~ wtp) => OrderingF x y) -> OrderingF x y)
-> ((wtp ~ wtp) => OrderingF x y) -> OrderingF x y
forall a b. (a -> b) -> a -> b
$
    MemRepr x -> MemRepr y -> OrderingF x y
forall k (ktp :: k -> Type) (x :: k) (y :: k).
OrdF ktp =>
ktp x -> ktp y -> OrderingF x y
forall (x :: Type) (y :: Type).
MemRepr x -> MemRepr y -> OrderingF x y
compareF MemRepr x
xr MemRepr y
yr

------------------------------------------------------------------------
-- BlockInferValue

-- | This is an expression that represents a more canonical representation
-- of a Macaw value inferred by the invariant inference routine.
--
-- This difference between `InitInferValue` and `BlockInferValue` is that
-- `InitInferValue` captures constraints important to capture between blocks
-- while `BlockInferValue` has a richer constraint language capturing
-- inferrences within a block.
data BlockInferValue arch ids tp where
  -- | Value register use domain
  IVDomain :: !(InitInferValue arch wtp)
           -> !(MemSlice wtp rtp)
           -> BlockInferValue arch ids rtp

  -- | The value of an assignment.
  IVAssignValue :: !(AssignId ids tp)
                -> BlockInferValue arch ids tp
  -- | A constant
  IVCValue :: !(CValue arch tp) -> BlockInferValue arch ids tp
  -- | Denotes the value written by a conditional write at the given
  -- index if the condition is true, or the value currently stored in
  -- memory if the condition is false.
  --
  -- The MemRepr is the type of the write, and used for comparison.
  IVCondWrite :: !StmtIndex -> !(MemRepr tp) -> BlockInferValue arch ids tp

deriving instance ShowF (ArchReg arch) => Show (BlockInferValue arch ids tp)

instance ShowF (ArchReg arch) => ShowF (BlockInferValue arch ids)

-- | Pattern for stack offset expressions
pattern FrameExpr :: ()
                  => (tp ~ BVType (ArchAddrWidth arch))
                  => MemInt (ArchAddrWidth arch)
                  -> BlockInferValue arch ids tp
pattern $mFrameExpr :: forall {r} {tp :: Type} {arch} {ids}.
BlockInferValue arch ids tp
-> ((tp ~ BVType (ArchAddrWidth arch)) =>
    MemInt (ArchAddrWidth arch) -> r)
-> ((# #) -> r)
-> r
$bFrameExpr :: forall (tp :: Type) arch ids.
(tp ~ BVType (ArchAddrWidth arch)) =>
MemInt (ArchAddrWidth arch) -> BlockInferValue arch ids tp
FrameExpr o = IVDomain (InferredStackOffset o) NoMemSlice

-- This returns @Just Refl@ if the two expressions denote the same
-- value under the assumptions about the start of the block, and the
-- assumption that non-stack writes do not affect the curent stack
-- frame.
instance TestEquality (ArchReg arch) => TestEquality (BlockInferValue arch ids) where
  testEquality :: forall (a :: Type) (b :: Type).
BlockInferValue arch ids a
-> BlockInferValue arch ids b -> Maybe (a :~: b)
testEquality (IVDomain InitInferValue arch wtp
x MemSlice wtp a
xs) (IVDomain InitInferValue arch wtp
y MemSlice wtp b
ys) = do
    wtp :~: wtp
Refl <- InitInferValue arch wtp
-> InitInferValue arch wtp -> Maybe (wtp :~: wtp)
forall {k} (f :: k -> Type) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
forall (a :: Type) (b :: Type).
InitInferValue arch a -> InitInferValue arch b -> Maybe (a :~: b)
testEquality InitInferValue arch wtp
x InitInferValue arch wtp
y
    MemSlice wtp a -> MemSlice wtp b -> Maybe (a :~: b)
forall {k} (f :: k -> Type) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
forall (a :: Type) (b :: Type).
MemSlice wtp a -> MemSlice wtp b -> Maybe (a :~: b)
testEquality MemSlice wtp a
xs MemSlice wtp b
MemSlice wtp b
ys
  testEquality (IVAssignValue AssignId ids a
x) (IVAssignValue AssignId ids b
y) = AssignId ids a -> AssignId ids b -> Maybe (a :~: b)
forall {k} (f :: k -> Type) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
forall (a :: Type) (b :: Type).
AssignId ids a -> AssignId ids b -> Maybe (a :~: b)
testEquality AssignId ids a
x AssignId ids b
y
  testEquality (IVCValue CValue arch a
x) (IVCValue CValue arch b
y) = CValue arch a -> CValue arch b -> Maybe (a :~: b)
forall {k} (f :: k -> Type) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
forall (a :: Type) (b :: Type).
CValue arch a -> CValue arch b -> Maybe (a :~: b)
testEquality CValue arch a
x CValue arch b
y
  testEquality (IVCondWrite Int
x MemRepr a
xtp) (IVCondWrite Int
y MemRepr b
ytp) =
    if Int
x Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
y
      then
        case MemRepr a -> MemRepr b -> Maybe (a :~: b)
forall {k} (f :: k -> Type) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
forall (a :: Type) (b :: Type).
MemRepr a -> MemRepr b -> Maybe (a :~: b)
testEquality MemRepr a
xtp MemRepr b
ytp of
          Just a :~: b
Refl -> (a :~: b) -> Maybe (a :~: b)
forall a. a -> Maybe a
Just a :~: a
a :~: b
forall {k} (a :: k). a :~: a
Refl
          Maybe (a :~: b)
Nothing -> String -> Maybe (a :~: b)
forall a. HasCallStack => String -> a
error String
"Equal conditional writes with inequal types."
      else Maybe (a :~: b)
forall a. Maybe a
Nothing
  testEquality BlockInferValue arch ids a
_ BlockInferValue arch ids b
_ = Maybe (a :~: b)
forall a. Maybe a
Nothing

-- Note. The @OrdF@ instance is a total order over @BlockInferValue@.
-- If it returns @EqF@ then it guarantees the two expressions denote
-- the same value under the assumptions about the start of the block,
-- and the assumption that non-stack writes do not affect the current
-- stack frame.
instance OrdF (ArchReg arch) => OrdF (BlockInferValue arch ids) where
  compareF :: forall (x :: Type) (y :: Type).
BlockInferValue arch ids x
-> BlockInferValue arch ids y -> OrderingF x y
compareF (IVDomain InitInferValue arch wtp
x MemSlice wtp x
xs) (IVDomain InitInferValue arch wtp
y MemSlice wtp y
ys) =
    OrderingF wtp wtp
-> ((wtp ~ wtp) => OrderingF x y) -> OrderingF x y
forall j k (a :: j) (b :: j) (c :: k) (d :: k).
OrderingF a b -> ((a ~ b) => OrderingF c d) -> OrderingF c d
joinOrderingF (InitInferValue arch wtp
-> InitInferValue arch wtp -> OrderingF wtp wtp
forall k (ktp :: k -> Type) (x :: k) (y :: k).
OrdF ktp =>
ktp x -> ktp y -> OrderingF x y
forall (x :: Type) (y :: Type).
InitInferValue arch x -> InitInferValue arch y -> OrderingF x y
compareF InitInferValue arch wtp
x InitInferValue arch wtp
y) (MemSlice wtp x -> MemSlice wtp y -> OrderingF x y
forall k (ktp :: k -> Type) (x :: k) (y :: k).
OrdF ktp =>
ktp x -> ktp y -> OrderingF x y
forall (x :: Type) (y :: Type).
MemSlice wtp x -> MemSlice wtp y -> OrderingF x y
compareF MemSlice wtp x
xs MemSlice wtp y
MemSlice wtp y
ys)
  compareF IVDomain{} BlockInferValue arch ids y
_ = OrderingF x y
forall {k} (x :: k) (y :: k). OrderingF x y
LTF
  compareF BlockInferValue arch ids x
_ IVDomain{} = OrderingF x y
forall {k} (x :: k) (y :: k). OrderingF x y
GTF

  compareF (IVAssignValue AssignId ids x
x) (IVAssignValue AssignId ids y
y) = AssignId ids x -> AssignId ids y -> OrderingF x y
forall k (ktp :: k -> Type) (x :: k) (y :: k).
OrdF ktp =>
ktp x -> ktp y -> OrderingF x y
forall (x :: Type) (y :: Type).
AssignId ids x -> AssignId ids y -> OrderingF x y
compareF AssignId ids x
x AssignId ids y
y
  compareF IVAssignValue{} BlockInferValue arch ids y
_ = OrderingF x y
forall {k} (x :: k) (y :: k). OrderingF x y
LTF
  compareF BlockInferValue arch ids x
_ IVAssignValue{} = OrderingF x y
forall {k} (x :: k) (y :: k). OrderingF x y
GTF

  compareF (IVCValue CValue arch x
x) (IVCValue CValue arch y
y) = CValue arch x -> CValue arch y -> OrderingF x y
forall k (ktp :: k -> Type) (x :: k) (y :: k).
OrdF ktp =>
ktp x -> ktp y -> OrderingF x y
forall (x :: Type) (y :: Type).
CValue arch x -> CValue arch y -> OrderingF x y
compareF CValue arch x
x CValue arch y
y
  compareF IVCValue{} BlockInferValue arch ids y
_ = OrderingF x y
forall {k} (x :: k) (y :: k). OrderingF x y
LTF
  compareF BlockInferValue arch ids x
_ IVCValue{} = OrderingF x y
forall {k} (x :: k) (y :: k). OrderingF x y
GTF

  compareF (IVCondWrite Int
x MemRepr x
xtp) (IVCondWrite Int
y MemRepr y
ytp) =
    case Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
x Int
y of
      Ordering
LT -> OrderingF x y
forall {k} (x :: k) (y :: k). OrderingF x y
LTF
      Ordering
EQ ->
        case MemRepr x -> MemRepr y -> Maybe (x :~: y)
forall {k} (f :: k -> Type) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
forall (a :: Type) (b :: Type).
MemRepr a -> MemRepr b -> Maybe (a :~: b)
testEquality MemRepr x
xtp MemRepr y
ytp of
          Just x :~: y
Refl -> OrderingF x x
OrderingF x y
forall {k} (x :: k). OrderingF x x
EQF
          Maybe (x :~: y)
Nothing -> String -> OrderingF x y
forall a. HasCallStack => String -> a
error String
"Equal conditional writes with inequal types."
      Ordering
GT -> OrderingF x y
forall {k} (x :: k) (y :: k). OrderingF x y
GTF

-- | Information about a stack location used in invariant inference.
data InferStackValue arch ids tp where
  -- | The stack location had this value in the initial stack.
  ISVInitValue :: !(InitInferValue arch tp)
               -> InferStackValue arch ids tp
  -- | The value was written to the stack by a @WriteMem@ instruction
  -- in the current block at the given index, and the value written
  -- had the given inferred value.
  ISVWrite :: !StmtIndex
           -> !(Value arch ids tp)
           -> InferStackValue arch ids tp
  -- | @ISVCondWrite idx c v pv@ denotes the value written to
  -- the stack by a @CondWriteMem@ instruction in the current block
  -- with the given instruction index @idx@, condition @c@, value @v@
  -- and existing stack value @pv@.
  --
  -- The arguments are the index, the Boolean, the value written, and
  -- the value overwritten.
  ISVCondWrite :: !StmtIndex
               -> !(Value arch ids BoolType)
               -> !(Value arch ids tp)
               -> !(InferStackValue arch ids tp)
               -> InferStackValue arch ids tp

------------------------------------------------------------------------
-- StartInfer

-- | Read-only information needed to infer successor start
-- constraints for a lbok.
data StartInferContext arch =
  SIC { forall arch. StartInferContext arch -> ArchSegmentOff arch
sicAddr :: !(ArchSegmentOff arch)
        -- ^ Address of block we are inferring state for.
      , forall arch.
StartInferContext arch -> MapF (ArchReg arch) (InitInferValue arch)
sicRegs :: !(MapF (ArchReg arch) (InitInferValue arch))
        -- ^ Map rep register to rheir initial domain information.
      }

deriving instance (ShowF (ArchReg arch), MemWidth (ArchAddrWidth arch))
      => Show (StartInferContext arch)


-- |  Evaluate a value in the context of the start infer state and
-- initial register assignment.
valueToStartExpr' :: OrdF (ArchReg arch)
                 => StartInferContext arch
                    -- ^ Initial value of registers
                 -> MapF (AssignId ids) (BlockInferValue arch ids)
                    -- ^ Map from assignments to value.
                 -> Value arch ids wtp
                    -- ^ Value to convert.
                 -> MemSlice wtp rtp
                 -> Maybe (BlockInferValue arch ids rtp)
valueToStartExpr' :: forall arch ids (wtp :: Type) (rtp :: Type).
OrdF (ArchReg arch) =>
StartInferContext arch
-> MapF (AssignId ids) (BlockInferValue arch ids)
-> Value arch ids wtp
-> MemSlice wtp rtp
-> Maybe (BlockInferValue arch ids rtp)
valueToStartExpr' StartInferContext arch
_ MapF (AssignId ids) (BlockInferValue arch ids)
_ (CValue CValue arch wtp
c) MemSlice wtp rtp
NoMemSlice = BlockInferValue arch ids rtp
-> Maybe (BlockInferValue arch ids rtp)
forall a. a -> Maybe a
Just (CValue arch rtp -> BlockInferValue arch ids rtp
forall arch (tp :: Type) ids.
CValue arch tp -> BlockInferValue arch ids tp
IVCValue CValue arch wtp
CValue arch rtp
c)
valueToStartExpr' StartInferContext arch
_ MapF (AssignId ids) (BlockInferValue arch ids)
_ (CValue CValue arch wtp
_) MemSlice{} = Maybe (BlockInferValue arch ids rtp)
forall a. Maybe a
Nothing
valueToStartExpr' StartInferContext arch
_ MapF (AssignId ids) (BlockInferValue arch ids)
am (AssignedValue (Assignment AssignId ids wtp
aid AssignRhs arch (Value arch ids) wtp
_)) MemSlice wtp rtp
NoMemSlice = BlockInferValue arch ids rtp
-> Maybe (BlockInferValue arch ids rtp)
forall a. a -> Maybe a
Just (BlockInferValue arch ids rtp
 -> Maybe (BlockInferValue arch ids rtp))
-> BlockInferValue arch ids rtp
-> Maybe (BlockInferValue arch ids rtp)
forall a b. (a -> b) -> a -> b
$
  BlockInferValue arch ids rtp
-> AssignId ids rtp
-> MapF (AssignId ids) (BlockInferValue arch ids)
-> BlockInferValue arch ids rtp
forall {v} (k :: v -> Type) (a :: v -> Type) (tp :: v).
OrdF k =>
a tp -> k tp -> MapF k a -> a tp
MapF.findWithDefault (AssignId ids rtp -> BlockInferValue arch ids rtp
forall ids (tp :: Type) arch.
AssignId ids tp -> BlockInferValue arch ids tp
IVAssignValue AssignId ids wtp
AssignId ids rtp
aid) AssignId ids wtp
AssignId ids rtp
aid MapF (AssignId ids) (BlockInferValue arch ids)
am
valueToStartExpr' StartInferContext arch
_ MapF (AssignId ids) (BlockInferValue arch ids)
_ (AssignedValue (Assignment AssignId ids wtp
_ AssignRhs arch (Value arch ids) wtp
_)) MemSlice{} = Maybe (BlockInferValue arch ids rtp)
forall a. Maybe a
Nothing
valueToStartExpr' StartInferContext arch
ctx MapF (AssignId ids) (BlockInferValue arch ids)
_ (Initial ArchReg arch wtp
r) MemSlice wtp rtp
ms = BlockInferValue arch ids rtp
-> Maybe (BlockInferValue arch ids rtp)
forall a. a -> Maybe a
Just (BlockInferValue arch ids rtp
 -> Maybe (BlockInferValue arch ids rtp))
-> BlockInferValue arch ids rtp
-> Maybe (BlockInferValue arch ids rtp)
forall a b. (a -> b) -> a -> b
$
  InitInferValue arch wtp
-> MemSlice wtp rtp -> BlockInferValue arch ids rtp
forall arch (wtp :: Type) (rtp :: Type) ids.
InitInferValue arch wtp
-> MemSlice wtp rtp -> BlockInferValue arch ids rtp
IVDomain (InitInferValue arch wtp
-> ArchReg arch wtp
-> MapF (ArchReg arch) (InitInferValue arch)
-> InitInferValue arch wtp
forall {v} (k :: v -> Type) (a :: v -> Type) (tp :: v).
OrdF k =>
a tp -> k tp -> MapF k a -> a tp
MapF.findWithDefault (BoundLoc (ArchReg arch) wtp -> InitInferValue arch wtp
forall arch (tp :: Type).
BoundLoc (ArchReg arch) tp -> InitInferValue arch tp
RegEqualLoc (ArchReg arch wtp -> BoundLoc (ArchReg arch) wtp
forall (r :: Type -> Type) (tp :: Type). r tp -> BoundLoc r tp
RegLoc ArchReg arch wtp
r)) ArchReg arch wtp
r (StartInferContext arch -> MapF (ArchReg arch) (InitInferValue arch)
forall arch.
StartInferContext arch -> MapF (ArchReg arch) (InitInferValue arch)
sicRegs StartInferContext arch
ctx)) MemSlice wtp rtp
ms


-- | Evaluate a value in the context of the start infer state and
-- initial register assignment.
valueToStartExpr :: OrdF (ArchReg arch)
                 => StartInferContext arch
                    -- ^ Initial value of registers
                 -> MapF (AssignId ids) (BlockInferValue arch ids)
                    -- ^ Map from assignments to value.
                 -> Value arch ids tp
                 -> BlockInferValue arch ids tp
valueToStartExpr :: forall arch ids (tp :: Type).
OrdF (ArchReg arch) =>
StartInferContext arch
-> MapF (AssignId ids) (BlockInferValue arch ids)
-> Value arch ids tp
-> BlockInferValue arch ids tp
valueToStartExpr StartInferContext arch
_ MapF (AssignId ids) (BlockInferValue arch ids)
_ (CValue CValue arch tp
c) = CValue arch tp -> BlockInferValue arch ids tp
forall arch (tp :: Type) ids.
CValue arch tp -> BlockInferValue arch ids tp
IVCValue CValue arch tp
c
valueToStartExpr StartInferContext arch
_ MapF (AssignId ids) (BlockInferValue arch ids)
am (AssignedValue (Assignment AssignId ids tp
aid AssignRhs arch (Value arch ids) tp
_)) =
  BlockInferValue arch ids tp
-> AssignId ids tp
-> MapF (AssignId ids) (BlockInferValue arch ids)
-> BlockInferValue arch ids tp
forall {v} (k :: v -> Type) (a :: v -> Type) (tp :: v).
OrdF k =>
a tp -> k tp -> MapF k a -> a tp
MapF.findWithDefault (AssignId ids tp -> BlockInferValue arch ids tp
forall ids (tp :: Type) arch.
AssignId ids tp -> BlockInferValue arch ids tp
IVAssignValue AssignId ids tp
aid) AssignId ids tp
aid MapF (AssignId ids) (BlockInferValue arch ids)
am
valueToStartExpr StartInferContext arch
ctx MapF (AssignId ids) (BlockInferValue arch ids)
_ (Initial ArchReg arch tp
r) =
  InitInferValue arch tp
-> MemSlice tp tp -> BlockInferValue arch ids tp
forall arch (wtp :: Type) (rtp :: Type) ids.
InitInferValue arch wtp
-> MemSlice wtp rtp -> BlockInferValue arch ids rtp
IVDomain (InitInferValue arch tp
-> ArchReg arch tp
-> MapF (ArchReg arch) (InitInferValue arch)
-> InitInferValue arch tp
forall {v} (k :: v -> Type) (a :: v -> Type) (tp :: v).
OrdF k =>
a tp -> k tp -> MapF k a -> a tp
MapF.findWithDefault (BoundLoc (ArchReg arch) tp -> InitInferValue arch tp
forall arch (tp :: Type).
BoundLoc (ArchReg arch) tp -> InitInferValue arch tp
RegEqualLoc (ArchReg arch tp -> BoundLoc (ArchReg arch) tp
forall (r :: Type -> Type) (tp :: Type). r tp -> BoundLoc r tp
RegLoc ArchReg arch tp
r)) ArchReg arch tp
r (StartInferContext arch -> MapF (ArchReg arch) (InitInferValue arch)
forall arch.
StartInferContext arch -> MapF (ArchReg arch) (InitInferValue arch)
sicRegs StartInferContext arch
ctx))
           MemSlice tp tp
forall (tp :: Type). MemSlice tp tp
NoMemSlice

inferStackValueToValue :: OrdF (ArchReg arch)
                       => StartInferContext arch
                       -- ^ Initial value of registers
                       -> MapF (AssignId ids) (BlockInferValue arch ids)
                       -- ^ Map from assignments to value.
                       -> InferStackValue arch ids tp
                       -> MemRepr tp
                       -> BlockInferValue arch ids tp
inferStackValueToValue :: forall arch ids (tp :: Type).
OrdF (ArchReg arch) =>
StartInferContext arch
-> MapF (AssignId ids) (BlockInferValue arch ids)
-> InferStackValue arch ids tp
-> MemRepr tp
-> BlockInferValue arch ids tp
inferStackValueToValue StartInferContext arch
_ MapF (AssignId ids) (BlockInferValue arch ids)
_ (ISVInitValue InitInferValue arch tp
d)   MemRepr tp
_    = InitInferValue arch tp
-> MemSlice tp tp -> BlockInferValue arch ids tp
forall arch (wtp :: Type) (rtp :: Type) ids.
InitInferValue arch wtp
-> MemSlice wtp rtp -> BlockInferValue arch ids rtp
IVDomain InitInferValue arch tp
d MemSlice tp tp
forall (tp :: Type). MemSlice tp tp
NoMemSlice
inferStackValueToValue StartInferContext arch
ctx MapF (AssignId ids) (BlockInferValue arch ids)
m (ISVWrite Int
_idx Value arch ids tp
v)  MemRepr tp
_  = StartInferContext arch
-> MapF (AssignId ids) (BlockInferValue arch ids)
-> Value arch ids tp
-> BlockInferValue arch ids tp
forall arch ids (tp :: Type).
OrdF (ArchReg arch) =>
StartInferContext arch
-> MapF (AssignId ids) (BlockInferValue arch ids)
-> Value arch ids tp
-> BlockInferValue arch ids tp
valueToStartExpr StartInferContext arch
ctx MapF (AssignId ids) (BlockInferValue arch ids)
m Value arch ids tp
v
inferStackValueToValue StartInferContext arch
_ MapF (AssignId ids) (BlockInferValue arch ids)
_ (ISVCondWrite Int
idx Value arch ids BoolType
_ Value arch ids tp
_ InferStackValue arch ids tp
_) MemRepr tp
repr = Int -> MemRepr tp -> BlockInferValue arch ids tp
forall (tp :: Type) arch ids.
Int -> MemRepr tp -> BlockInferValue arch ids tp
IVCondWrite Int
idx MemRepr tp
repr

-- | Information about a memory access within a block
data MemAccessInfo arch ids
   = -- | The access was not inferred to affect the current frame
     NotFrameAccess
     -- | The access read a frame offset that has not been written to
     -- by the current block.  The inferred value describes the value read.
   | forall tp
     . FrameReadInitAccess !(MemInt (ArchAddrWidth arch)) !(InitInferValue arch tp)
     -- | The access read a frame offset that has been written to by a
     -- previous write or cond-write in this block, and the
     -- instruction had the given index.
   | FrameReadWriteAccess !StmtIndex
      -- | The access was a memory read that overlapped, but did not
     -- exactly match a previous write.
   | FrameReadOverlapAccess
        !(MemInt (ArchAddrWidth arch))
     -- | The access was a write to the current frame.
   | FrameWriteAccess !(MemInt (ArchAddrWidth arch))
     -- | The access was a conditional write to the current frame at the
     -- given offset.  The current
   | forall tp
     . FrameCondWriteAccess !(MemInt (ArchAddrWidth arch))
                            !(MemRepr tp)
                            !(InferStackValue arch ids tp)
     -- | The access was a conditional write to the current frame at the
     -- given offset, and the default value would overlap with a previous
     -- write.
   | FrameCondWriteOverlapAccess !(MemInt (ArchAddrWidth arch))

-- | State tracked to infer block preconditions.
data InferState arch ids =
  SIS { -- | Current stack map.
        --
        -- Note. An uninitialized region at offset @o@ and type @repr@
        -- implicitly is associated with
        -- @ISVInitValue (RegEqualLoc (StackOffLoc o repr))@.
        forall arch ids.
InferState arch ids
-> MemMap (MemInt (ArchAddrWidth arch)) (InferStackValue arch ids)
sisStack :: !(MemMap (MemInt (ArchAddrWidth arch)) (InferStackValue arch ids))
        -- | Maps assignment identifiers to the associated value.
        --
        -- If an assignment id @aid@ is not in this map, then we assume it
        -- is equal to @SAVEqualAssign aid@
      , forall arch ids.
InferState arch ids
-> MapF (AssignId ids) (BlockInferValue arch ids)
sisAssignMap :: !(MapF (AssignId ids) (BlockInferValue arch ids))
        -- | Maps apps to the assignment identifier that created it.
      , forall arch ids.
InferState arch ids
-> MapF (App (BlockInferValue arch ids)) (AssignId ids)
sisAppCache :: !(MapF (App (BlockInferValue arch ids)) (AssignId ids))
        -- | Offset of current instruction relative to first
        -- instruction in block.
      , forall arch ids. InferState arch ids -> ArchAddrWord arch
sisCurrentInstructionOffset :: !(ArchAddrWord arch)
        -- | Information about memory accesses in reverse order of statement.
        --
        -- There should be one for each statement that is a @ReadMem@,
        -- @CondReadMem@, @WriteMem@ and @CondWriteMem@.
      , forall arch ids.
InferState arch ids -> [(Int, MemAccessInfo arch ids)]
sisMemAccessStack :: ![(StmtIndex, MemAccessInfo arch ids)]
      }

-- | Current state of stack.
sisStackLens :: Lens' (InferState arch ids)
                      (MemMap (MemInt (ArchAddrWidth arch)) (InferStackValue arch ids))
sisStackLens :: forall arch ids (f :: Type -> Type).
Functor f =>
(MemMap (MemInt (ArchAddrWidth arch)) (InferStackValue arch ids)
 -> f (MemMap
         (MemInt (ArchAddrWidth arch)) (InferStackValue arch ids)))
-> InferState arch ids -> f (InferState arch ids)
sisStackLens = (InferState arch ids
 -> MemMap
      (MemInt (RegAddrWidth (ArchReg arch))) (InferStackValue arch ids))
-> (InferState arch ids
    -> MemMap
         (MemInt (RegAddrWidth (ArchReg arch))) (InferStackValue arch ids)
    -> InferState arch ids)
-> Lens
     (InferState arch ids)
     (InferState arch ids)
     (MemMap
        (MemInt (RegAddrWidth (ArchReg arch))) (InferStackValue arch ids))
     (MemMap
        (MemInt (RegAddrWidth (ArchReg arch))) (InferStackValue arch ids))
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens InferState arch ids
-> MemMap
     (MemInt (RegAddrWidth (ArchReg arch))) (InferStackValue arch ids)
forall arch ids.
InferState arch ids
-> MemMap (MemInt (ArchAddrWidth arch)) (InferStackValue arch ids)
sisStack (\InferState arch ids
s MemMap
  (MemInt (RegAddrWidth (ArchReg arch))) (InferStackValue arch ids)
v -> InferState arch ids
s { sisStack = v })

-- | Maps assignment identifiers to the associated value.
--
-- If an assignment id is not in this map, then we assume it could not
-- be interpreted by the analysis.
sisAssignMapLens :: Lens' (InferState arch ids)
                          (MapF (AssignId ids) (BlockInferValue arch ids))
sisAssignMapLens :: forall arch ids (f :: Type -> Type).
Functor f =>
(MapF (AssignId ids) (BlockInferValue arch ids)
 -> f (MapF (AssignId ids) (BlockInferValue arch ids)))
-> InferState arch ids -> f (InferState arch ids)
sisAssignMapLens = (InferState arch ids
 -> MapF (AssignId ids) (BlockInferValue arch ids))
-> (InferState arch ids
    -> MapF (AssignId ids) (BlockInferValue arch ids)
    -> InferState arch ids)
-> Lens
     (InferState arch ids)
     (InferState arch ids)
     (MapF (AssignId ids) (BlockInferValue arch ids))
     (MapF (AssignId ids) (BlockInferValue arch ids))
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens InferState arch ids
-> MapF (AssignId ids) (BlockInferValue arch ids)
forall arch ids.
InferState arch ids
-> MapF (AssignId ids) (BlockInferValue arch ids)
sisAssignMap (\InferState arch ids
s MapF (AssignId ids) (BlockInferValue arch ids)
v -> InferState arch ids
s { sisAssignMap = v })

-- | Maps apps to the assignment identifier that created it.
sisAppCacheLens :: Lens' (InferState arch ids)
                         (MapF (App (BlockInferValue arch ids)) (AssignId ids))
sisAppCacheLens :: forall arch ids (f :: Type -> Type).
Functor f =>
(MapF (App (BlockInferValue arch ids)) (AssignId ids)
 -> f (MapF (App (BlockInferValue arch ids)) (AssignId ids)))
-> InferState arch ids -> f (InferState arch ids)
sisAppCacheLens = (InferState arch ids
 -> MapF (App (BlockInferValue arch ids)) (AssignId ids))
-> (InferState arch ids
    -> MapF (App (BlockInferValue arch ids)) (AssignId ids)
    -> InferState arch ids)
-> Lens
     (InferState arch ids)
     (InferState arch ids)
     (MapF (App (BlockInferValue arch ids)) (AssignId ids))
     (MapF (App (BlockInferValue arch ids)) (AssignId ids))
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens InferState arch ids
-> MapF (App (BlockInferValue arch ids)) (AssignId ids)
forall arch ids.
InferState arch ids
-> MapF (App (BlockInferValue arch ids)) (AssignId ids)
sisAppCache (\InferState arch ids
s MapF (App (BlockInferValue arch ids)) (AssignId ids)
v -> InferState arch ids
s { sisAppCache = v })

-- | Maps apps to the assignment identifier that created it.
sisCurrentInstructionOffsetLens :: Lens' (InferState arch ids) (ArchAddrWord arch)
sisCurrentInstructionOffsetLens :: forall arch ids (f :: Type -> Type).
Functor f =>
(ArchAddrWord arch -> f (ArchAddrWord arch))
-> InferState arch ids -> f (InferState arch ids)
sisCurrentInstructionOffsetLens =
  (InferState arch ids -> MemWord (RegAddrWidth (ArchReg arch)))
-> (InferState arch ids
    -> MemWord (RegAddrWidth (ArchReg arch)) -> InferState arch ids)
-> Lens
     (InferState arch ids)
     (InferState arch ids)
     (MemWord (RegAddrWidth (ArchReg arch)))
     (MemWord (RegAddrWidth (ArchReg arch)))
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens InferState arch ids -> MemWord (RegAddrWidth (ArchReg arch))
forall arch ids. InferState arch ids -> ArchAddrWord arch
sisCurrentInstructionOffset (\InferState arch ids
s MemWord (RegAddrWidth (ArchReg arch))
v -> InferState arch ids
s { sisCurrentInstructionOffset = v })

-- | Monad used for inferring start constraints.
--
-- Note. The process of inferring start constraints intentionally does
-- not do stack escape analysis or other
type StartInfer arch ids =
  ReaderT (StartInferContext arch) (StateT (InferState arch ids) (Except (RegisterUseError arch)))

-- | Set the value associated with an assignment
setAssignVal :: AssignId ids tp
             -> BlockInferValue arch ids tp
             -> StartInfer arch ids ()
setAssignVal :: forall ids (tp :: Type) arch.
AssignId ids tp
-> BlockInferValue arch ids tp -> StartInfer arch ids ()
setAssignVal AssignId ids tp
aid BlockInferValue arch ids tp
v = (MapF (AssignId ids) (BlockInferValue arch ids)
 -> Identity (MapF (AssignId ids) (BlockInferValue arch ids)))
-> InferState arch ids -> Identity (InferState arch ids)
forall arch ids (f :: Type -> Type).
Functor f =>
(MapF (AssignId ids) (BlockInferValue arch ids)
 -> f (MapF (AssignId ids) (BlockInferValue arch ids)))
-> InferState arch ids -> f (InferState arch ids)
sisAssignMapLens ((MapF (AssignId ids) (BlockInferValue arch ids)
  -> Identity (MapF (AssignId ids) (BlockInferValue arch ids)))
 -> InferState arch ids -> Identity (InferState arch ids))
-> (MapF (AssignId ids) (BlockInferValue arch ids)
    -> MapF (AssignId ids) (BlockInferValue arch ids))
-> ReaderT
     (StartInferContext arch)
     (StateT (InferState arch ids) (Except (RegisterUseError arch)))
     ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= AssignId ids tp
-> BlockInferValue arch ids tp
-> MapF (AssignId ids) (BlockInferValue arch ids)
-> MapF (AssignId ids) (BlockInferValue arch ids)
forall {v} (k :: v -> Type) (tp :: v) (a :: v -> Type).
OrdF k =>
k tp -> a tp -> MapF k a -> MapF k a
MapF.insert AssignId ids tp
aid BlockInferValue arch ids tp
v

-- | Record the mem access information
addMemAccessInfo :: StmtIndex -> MemAccessInfo arch ids -> StartInfer arch ids ()
addMemAccessInfo :: forall arch ids.
Int -> MemAccessInfo arch ids -> StartInfer arch ids ()
addMemAccessInfo Int
idx MemAccessInfo arch ids
i = Int -> StartInfer arch ids () -> StartInfer arch ids ()
forall a b. a -> b -> b
seq Int
idx (StartInfer arch ids () -> StartInfer arch ids ())
-> StartInfer arch ids () -> StartInfer arch ids ()
forall a b. (a -> b) -> a -> b
$ MemAccessInfo arch ids
-> StartInfer arch ids () -> StartInfer arch ids ()
forall a b. a -> b -> b
seq MemAccessInfo arch ids
i (StartInfer arch ids () -> StartInfer arch ids ())
-> StartInfer arch ids () -> StartInfer arch ids ()
forall a b. (a -> b) -> a -> b
$ do
  (InferState arch ids -> InferState arch ids)
-> StartInfer arch ids ()
forall s (m :: Type -> Type). MonadState s m => (s -> s) -> m ()
modify ((InferState arch ids -> InferState arch ids)
 -> StartInfer arch ids ())
-> (InferState arch ids -> InferState arch ids)
-> StartInfer arch ids ()
forall a b. (a -> b) -> a -> b
$ \InferState arch ids
s -> InferState arch ids
s { sisMemAccessStack = (idx,i) : sisMemAccessStack s }

-- | @processApp aid app@ computes the effect of a program assignment @aid <- app@.  When `app` is
-- a computation over a stack offset expression (a `FrameExpr`), we attempt to simplify it, as we
-- require a concrete stack offset when computing `postCallConstraints`.
processApp :: (OrdF (ArchReg arch), MemWidth (ArchAddrWidth arch))
           => AssignId ids tp
           -> App (Value arch ids) tp
           -> StartInfer arch ids ()
processApp :: forall arch ids (tp :: Type).
(OrdF (ArchReg arch), MemWidth (ArchAddrWidth arch)) =>
AssignId ids tp
-> App (Value arch ids) tp -> StartInfer arch ids ()
processApp AssignId ids tp
aid App (Value arch ids) tp
app = do
  StartInferContext arch
ctx <- ReaderT
  (StartInferContext arch)
  (StateT (InferState arch ids) (Except (RegisterUseError arch)))
  (StartInferContext arch)
forall r (m :: Type -> Type). MonadReader r m => m r
ask
  MapF (AssignId ids) (BlockInferValue arch ids)
am <- (InferState arch ids
 -> MapF (AssignId ids) (BlockInferValue arch ids))
-> ReaderT
     (StartInferContext arch)
     (StateT (InferState arch ids) (Except (RegisterUseError arch)))
     (MapF (AssignId ids) (BlockInferValue arch ids))
forall s (m :: Type -> Type) a. MonadState s m => (s -> a) -> m a
gets InferState arch ids
-> MapF (AssignId ids) (BlockInferValue arch ids)
forall arch ids.
InferState arch ids
-> MapF (AssignId ids) (BlockInferValue arch ids)
sisAssignMap
  -- This inspects the `app` term to detect cases where the abstract expression can be simplified
  -- down to a `FrameExpr` expression.  In such cases, the simplified expression is registered as
  -- the value for this assignment.  Otherwise, the value for the assignment remains abstract.
  -- This may not be exhaustive, so if you encounter the `CallStackHeightError` in
  -- `postCallConstraints`, you may need to extend the patterns recognized here.
  case (forall (x :: Type).
 Value arch ids x -> BlockInferValue arch ids x)
-> forall (x :: Type).
   App (Value arch ids) x -> App (BlockInferValue arch ids) x
forall k l (t :: (k -> Type) -> l -> Type) (f :: k -> Type)
       (g :: k -> Type).
FunctorFC t =>
(forall (x :: k). f x -> g x) -> forall (x :: l). t f x -> t g x
forall (f :: Type -> Type) (g :: Type -> Type).
(forall (x :: Type). f x -> g x)
-> forall (x :: Type). App f x -> App g x
fmapFC (StartInferContext arch
-> MapF (AssignId ids) (BlockInferValue arch ids)
-> Value arch ids x
-> BlockInferValue arch ids x
forall arch ids (tp :: Type).
OrdF (ArchReg arch) =>
StartInferContext arch
-> MapF (AssignId ids) (BlockInferValue arch ids)
-> Value arch ids tp
-> BlockInferValue arch ids tp
valueToStartExpr StartInferContext arch
ctx MapF (AssignId ids) (BlockInferValue arch ids)
am) App (Value arch ids) tp
app of
    BVAdd NatRepr n
_ (FrameExpr MemInt (ArchAddrWidth arch)
o) (IVCValue (BVCValue NatRepr n
_ Integer
c)) ->
      AssignId ids tp
-> BlockInferValue arch ids tp -> StartInfer arch ids ()
forall ids (tp :: Type) arch.
AssignId ids tp
-> BlockInferValue arch ids tp -> StartInfer arch ids ()
setAssignVal AssignId ids tp
aid (MemInt (ArchAddrWidth arch) -> BlockInferValue arch ids tp
forall (tp :: Type) arch ids.
(tp ~ BVType (ArchAddrWidth arch)) =>
MemInt (ArchAddrWidth arch) -> BlockInferValue arch ids tp
FrameExpr (MemInt n
MemInt (ArchAddrWidth arch)
oMemInt n -> MemInt n -> MemInt n
forall a. Num a => a -> a -> a
+Integer -> MemInt n
forall a. Num a => Integer -> a
fromInteger Integer
c))
    BVAdd NatRepr n
_ (IVCValue (BVCValue NatRepr n
_ Integer
c)) (FrameExpr MemInt (ArchAddrWidth arch)
o) ->
      AssignId ids tp
-> BlockInferValue arch ids tp -> StartInfer arch ids ()
forall ids (tp :: Type) arch.
AssignId ids tp
-> BlockInferValue arch ids tp -> StartInfer arch ids ()
setAssignVal AssignId ids tp
aid (MemInt (ArchAddrWidth arch) -> BlockInferValue arch ids tp
forall (tp :: Type) arch ids.
(tp ~ BVType (ArchAddrWidth arch)) =>
MemInt (ArchAddrWidth arch) -> BlockInferValue arch ids tp
FrameExpr (MemInt n
MemInt (ArchAddrWidth arch)
oMemInt n -> MemInt n -> MemInt n
forall a. Num a => a -> a -> a
+Integer -> MemInt n
forall a. Num a => Integer -> a
fromInteger Integer
c))
    BVSub NatRepr n
_ (FrameExpr MemInt (ArchAddrWidth arch)
o) (IVCValue (BVCValue NatRepr n
_ Integer
c)) ->
      AssignId ids tp
-> BlockInferValue arch ids tp -> StartInfer arch ids ()
forall ids (tp :: Type) arch.
AssignId ids tp
-> BlockInferValue arch ids tp -> StartInfer arch ids ()
setAssignVal AssignId ids tp
aid (MemInt (ArchAddrWidth arch) -> BlockInferValue arch ids tp
forall (tp :: Type) arch ids.
(tp ~ BVType (ArchAddrWidth arch)) =>
MemInt (ArchAddrWidth arch) -> BlockInferValue arch ids tp
FrameExpr (MemInt n
MemInt (ArchAddrWidth arch)
oMemInt n -> MemInt n -> MemInt n
forall a. Num a => a -> a -> a
-Integer -> MemInt n
forall a. Num a => Integer -> a
fromInteger Integer
c))
    BVAnd NatRepr n
_ (FrameExpr MemInt (ArchAddrWidth arch)
o) (IVCValue (BVCValue NatRepr n
_ Integer
c)) ->
      AssignId ids tp
-> BlockInferValue arch ids tp -> StartInfer arch ids ()
forall ids (tp :: Type) arch.
AssignId ids tp
-> BlockInferValue arch ids tp -> StartInfer arch ids ()
setAssignVal AssignId ids tp
aid (MemInt (ArchAddrWidth arch) -> BlockInferValue arch ids tp
forall (tp :: Type) arch ids.
(tp ~ BVType (ArchAddrWidth arch)) =>
MemInt (ArchAddrWidth arch) -> BlockInferValue arch ids tp
FrameExpr (MemInt n
MemInt (ArchAddrWidth arch)
o MemInt n -> MemInt n -> MemInt n
forall a. Bits a => a -> a -> a
Bits..&. Integer -> MemInt n
forall a. Num a => Integer -> a
fromInteger Integer
c))
    BVAnd NatRepr n
_ (IVCValue (BVCValue NatRepr n
_ Integer
c)) (FrameExpr MemInt (ArchAddrWidth arch)
o) ->
      AssignId ids tp
-> BlockInferValue arch ids tp -> StartInfer arch ids ()
forall ids (tp :: Type) arch.
AssignId ids tp
-> BlockInferValue arch ids tp -> StartInfer arch ids ()
setAssignVal AssignId ids tp
aid (MemInt (ArchAddrWidth arch) -> BlockInferValue arch ids tp
forall (tp :: Type) arch ids.
(tp ~ BVType (ArchAddrWidth arch)) =>
MemInt (ArchAddrWidth arch) -> BlockInferValue arch ids tp
FrameExpr (MemInt n
MemInt (ArchAddrWidth arch)
o MemInt n -> MemInt n -> MemInt n
forall a. Bits a => a -> a -> a
Bits..&. Integer -> MemInt n
forall a. Num a => Integer -> a
fromInteger Integer
c))
    App (BlockInferValue arch ids) tp
appExpr -> do
      MapF (App (BlockInferValue arch ids)) (AssignId ids)
c <- (InferState arch ids
 -> MapF (App (BlockInferValue arch ids)) (AssignId ids))
-> ReaderT
     (StartInferContext arch)
     (StateT (InferState arch ids) (Except (RegisterUseError arch)))
     (MapF (App (BlockInferValue arch ids)) (AssignId ids))
forall s (m :: Type -> Type) a. MonadState s m => (s -> a) -> m a
gets InferState arch ids
-> MapF (App (BlockInferValue arch ids)) (AssignId ids)
forall arch ids.
InferState arch ids
-> MapF (App (BlockInferValue arch ids)) (AssignId ids)
sisAppCache
      -- Check to see if we have seen an app equivalent to
      -- this one under the invariant assumption.
      case App (BlockInferValue arch ids) tp
-> MapF (App (BlockInferValue arch ids)) (AssignId ids)
-> Maybe (AssignId ids tp)
forall {v} (k :: v -> Type) (tp :: v) (a :: v -> Type).
OrdF k =>
k tp -> MapF k a -> Maybe (a tp)
MapF.lookup App (BlockInferValue arch ids) tp
appExpr MapF (App (BlockInferValue arch ids)) (AssignId ids)
c of
        -- If we have not, then record it in the cache for
        -- later.
        Maybe (AssignId ids tp)
Nothing -> do
          (MapF (App (BlockInferValue arch ids)) (AssignId ids)
 -> Identity (MapF (App (BlockInferValue arch ids)) (AssignId ids)))
-> InferState arch ids -> Identity (InferState arch ids)
forall arch ids (f :: Type -> Type).
Functor f =>
(MapF (App (BlockInferValue arch ids)) (AssignId ids)
 -> f (MapF (App (BlockInferValue arch ids)) (AssignId ids)))
-> InferState arch ids -> f (InferState arch ids)
sisAppCacheLens ((MapF (App (BlockInferValue arch ids)) (AssignId ids)
  -> Identity (MapF (App (BlockInferValue arch ids)) (AssignId ids)))
 -> InferState arch ids -> Identity (InferState arch ids))
-> (MapF (App (BlockInferValue arch ids)) (AssignId ids)
    -> MapF (App (BlockInferValue arch ids)) (AssignId ids))
-> StartInfer arch ids ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= App (BlockInferValue arch ids) tp
-> AssignId ids tp
-> MapF (App (BlockInferValue arch ids)) (AssignId ids)
-> MapF (App (BlockInferValue arch ids)) (AssignId ids)
forall {v} (k :: v -> Type) (tp :: v) (a :: v -> Type).
OrdF k =>
k tp -> a tp -> MapF k a -> MapF k a
MapF.insert App (BlockInferValue arch ids) tp
appExpr AssignId ids tp
aid
        -- If we have seen this app, then we set it equal to previous.
        Just AssignId ids tp
prevId -> do
          AssignId ids tp
-> BlockInferValue arch ids tp -> StartInfer arch ids ()
forall ids (tp :: Type) arch.
AssignId ids tp
-> BlockInferValue arch ids tp -> StartInfer arch ids ()
setAssignVal AssignId ids tp
aid (AssignId ids tp -> BlockInferValue arch ids tp
forall ids (tp :: Type) arch.
AssignId ids tp -> BlockInferValue arch ids tp
IVAssignValue AssignId ids tp
prevId)

-- | @checkReadWithinWrite writeOff writeType readOff readType@ checks that
-- the read is contained within the write and returns a mem slice if so.
checkReadWithinWrite :: MemWidth w
           => MemInt w -- ^ Write offset
           -> MemRepr wtp -- ^ Write repr
           -> MemInt w -- ^ Read offset
           -> MemRepr rtp -- ^ Read repr
           -> Maybe (MemSlice wtp rtp)
checkReadWithinWrite :: forall (w :: Nat) (wtp :: Type) (rtp :: Type).
MemWidth w =>
MemInt w
-> MemRepr wtp
-> MemInt w
-> MemRepr rtp
-> Maybe (MemSlice wtp rtp)
checkReadWithinWrite MemInt w
wo MemRepr wtp
wr MemInt w
ro MemRepr rtp
rr
  | MemInt w
wo MemInt w -> MemInt w -> Bool
forall a. Eq a => a -> a -> Bool
== MemInt w
ro, Just wtp :~: rtp
Refl <- MemRepr wtp -> MemRepr rtp -> Maybe (wtp :~: rtp)
forall {k} (f :: k -> Type) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
forall (a :: Type) (b :: Type).
MemRepr a -> MemRepr b -> Maybe (a :~: b)
testEquality MemRepr wtp
wr MemRepr rtp
rr =
      MemSlice wtp rtp -> Maybe (MemSlice wtp rtp)
forall a. a -> Maybe a
Just MemSlice wtp wtp
MemSlice wtp rtp
forall (tp :: Type). MemSlice tp tp
NoMemSlice
  | MemInt w
wo MemInt w -> MemInt w -> Bool
forall a. Ord a => a -> a -> Bool
<= MemInt w
ro
  , Integer
d <- MemInt w -> Integer
forall a. Integral a => a -> Integer
toInteger MemInt w
ro Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- MemInt w -> Integer
forall a. Integral a => a -> Integer
toInteger MemInt w
wo
  , Integer
rEnd <- Integer
d Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Nat -> Integer
forall a. Integral a => a -> Integer
toInteger (MemRepr rtp -> Nat
forall (tp :: Type). MemRepr tp -> Nat
memReprBytes MemRepr rtp
rr)
  , Integer
wEnd <- Nat -> Integer
forall a. Integral a => a -> Integer
toInteger (MemRepr wtp -> Nat
forall (tp :: Type). MemRepr tp -> Nat
memReprBytes MemRepr wtp
wr)
  , Integer
rEnd Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
wEnd =
    MemSlice wtp rtp -> Maybe (MemSlice wtp rtp)
forall a. a -> Maybe a
Just (Integer -> MemRepr wtp -> MemRepr rtp -> MemSlice wtp rtp
forall (wtp :: Type) (rtp :: Type).
Integer -> MemRepr wtp -> MemRepr rtp -> MemSlice wtp rtp
MemSlice Integer
d MemRepr wtp
wr MemRepr rtp
rr)
  | Bool
otherwise = Maybe (MemSlice wtp rtp)
forall a. Maybe a
Nothing


throwRegError :: StmtIndex -> RegisterUseErrorTag e -> e -> StartInfer arch ids a
throwRegError :: forall e arch ids a.
Int -> RegisterUseErrorTag e -> e -> StartInfer arch ids a
throwRegError Int
stmtIdx RegisterUseErrorTag e
tag e
v = do
  MemSegmentOff (RegAddrWidth (ArchReg arch))
blockAddr <- (StartInferContext arch
 -> MemSegmentOff (RegAddrWidth (ArchReg arch)))
-> ReaderT
     (StartInferContext arch)
     (StateT (InferState arch ids) (Except (RegisterUseError arch)))
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks StartInferContext arch
-> MemSegmentOff (RegAddrWidth (ArchReg arch))
forall arch. StartInferContext arch -> ArchSegmentOff arch
sicAddr
  RegisterUseError arch -> StartInfer arch ids a
forall a.
RegisterUseError arch
-> ReaderT
     (StartInferContext arch)
     (StateT (InferState arch ids) (Except (RegisterUseError arch)))
     a
forall e (m :: Type -> Type) a. MonadError e m => e -> m a
throwError (RegisterUseError arch -> StartInfer arch ids a)
-> RegisterUseError arch -> StartInfer arch ids a
forall a b. (a -> b) -> a -> b
$
    RegisterUseError
      { ruBlock :: MemSegmentOff (RegAddrWidth (ArchReg arch))
ruBlock = MemSegmentOff (RegAddrWidth (ArchReg arch))
blockAddr,
        ruStmt :: Int
ruStmt = Int
stmtIdx,
        ruReason :: RegisterUseErrorReason
ruReason = RegisterUseErrorTag e -> e -> RegisterUseErrorReason
forall e. RegisterUseErrorTag e -> e -> RegisterUseErrorReason
Reason RegisterUseErrorTag e
tag e
v
      }

unresolvedStackRead :: StmtIndex -> StartInfer arch ids as
unresolvedStackRead :: forall arch ids as. Int -> StartInfer arch ids as
unresolvedStackRead Int
stmtIdx = do
  Int -> RegisterUseErrorTag () -> () -> StartInfer arch ids as
forall e arch ids a.
Int -> RegisterUseErrorTag e -> e -> StartInfer arch ids a
throwRegError Int
stmtIdx RegisterUseErrorTag ()
UnresolvedStackRead ()

-- | Infer constraints from a memory read
inferReadMem ::
  (MemWidth (ArchAddrWidth arch), OrdF (ArchReg arch)) =>
  StmtIndex ->
  AssignId ids tp ->
  Value arch ids (BVType (ArchAddrWidth arch)) ->
  MemRepr tp ->
  StartInfer arch ids ()
inferReadMem :: forall arch ids (tp :: Type).
(MemWidth (ArchAddrWidth arch), OrdF (ArchReg arch)) =>
Int
-> AssignId ids tp
-> Value arch ids (BVType (ArchAddrWidth arch))
-> MemRepr tp
-> StartInfer arch ids ()
inferReadMem Int
stmtIdx AssignId ids tp
aid Value arch ids (BVType (ArchAddrWidth arch))
addr MemRepr tp
repr = do
  StartInferContext arch
ctx <- ReaderT
  (StartInferContext arch)
  (StateT (InferState arch ids) (Except (RegisterUseError arch)))
  (StartInferContext arch)
forall r (m :: Type -> Type). MonadReader r m => m r
ask
  MapF (AssignId ids) (BlockInferValue arch ids)
am <- (InferState arch ids
 -> MapF (AssignId ids) (BlockInferValue arch ids))
-> ReaderT
     (StartInferContext arch)
     (StateT (InferState arch ids) (Except (RegisterUseError arch)))
     (MapF (AssignId ids) (BlockInferValue arch ids))
forall s (m :: Type -> Type) a. MonadState s m => (s -> a) -> m a
gets InferState arch ids
-> MapF (AssignId ids) (BlockInferValue arch ids)
forall arch ids.
InferState arch ids
-> MapF (AssignId ids) (BlockInferValue arch ids)
sisAssignMap
  case StartInferContext arch
-> MapF (AssignId ids) (BlockInferValue arch ids)
-> Value arch ids (BVType (ArchAddrWidth arch))
-> BlockInferValue arch ids (BVType (ArchAddrWidth arch))
forall arch ids (tp :: Type).
OrdF (ArchReg arch) =>
StartInferContext arch
-> MapF (AssignId ids) (BlockInferValue arch ids)
-> Value arch ids tp
-> BlockInferValue arch ids tp
valueToStartExpr StartInferContext arch
ctx MapF (AssignId ids) (BlockInferValue arch ids)
am Value arch ids (BVType (ArchAddrWidth arch))
addr of
    FrameExpr MemInt (ArchAddrWidth arch)
o -> do
      MemMap (MemInt (ArchAddrWidth arch)) (InferStackValue arch ids)
stk <- (InferState arch ids
 -> MemMap (MemInt (ArchAddrWidth arch)) (InferStackValue arch ids))
-> ReaderT
     (StartInferContext arch)
     (StateT (InferState arch ids) (Except (RegisterUseError arch)))
     (MemMap (MemInt (ArchAddrWidth arch)) (InferStackValue arch ids))
forall s (m :: Type -> Type) a. MonadState s m => (s -> a) -> m a
gets InferState arch ids
-> MemMap (MemInt (ArchAddrWidth arch)) (InferStackValue arch ids)
forall arch ids.
InferState arch ids
-> MemMap (MemInt (ArchAddrWidth arch)) (InferStackValue arch ids)
sisStack
      case MemInt (ArchAddrWidth arch)
-> MemRepr tp
-> MemMap (MemInt (ArchAddrWidth arch)) (InferStackValue arch ids)
-> Maybe
     (MemInt (ArchAddrWidth arch), MemVal (InferStackValue arch ids))
forall o (tp :: Type) (v :: Type -> Type).
MemIndex o =>
o -> MemRepr tp -> MemMap o v -> Maybe (o, MemVal v)
memMapLookup' MemInt (ArchAddrWidth arch)
o MemRepr tp
repr MemMap (MemInt (ArchAddrWidth arch)) (InferStackValue arch ids)
stk of
        Just (MemInt (ArchAddrWidth arch)
writeOff, MemVal MemRepr tp
writeRepr InferStackValue arch ids tp
sv) ->
          case MemInt (ArchAddrWidth arch)
-> MemRepr tp
-> MemInt (ArchAddrWidth arch)
-> MemRepr tp
-> Maybe (MemSlice tp tp)
forall (w :: Nat) (wtp :: Type) (rtp :: Type).
MemWidth w =>
MemInt w
-> MemRepr wtp
-> MemInt w
-> MemRepr rtp
-> Maybe (MemSlice wtp rtp)
checkReadWithinWrite MemInt (ArchAddrWidth arch)
writeOff MemRepr tp
writeRepr MemInt (ArchAddrWidth arch)
o MemRepr tp
repr of
            -- Overlap reads just get recorded
            Maybe (MemSlice tp tp)
Nothing ->
              Int -> MemAccessInfo arch ids -> StartInfer arch ids ()
forall arch ids.
Int -> MemAccessInfo arch ids -> StartInfer arch ids ()
addMemAccessInfo Int
stmtIdx (MemInt (ArchAddrWidth arch) -> MemAccessInfo arch ids
forall arch ids.
MemInt (ArchAddrWidth arch) -> MemAccessInfo arch ids
FrameReadOverlapAccess MemInt (ArchAddrWidth arch)
o)
            -- Reads within writes get propagated.
            Just MemSlice tp tp
ms -> do
              (BlockInferValue arch ids tp
v, MemAccessInfo arch ids
memInfo) <-
                case InferStackValue arch ids tp
sv of
                  ISVInitValue InitInferValue arch tp
d -> do
                    (BlockInferValue arch ids tp, MemAccessInfo arch ids)
-> ReaderT
     (StartInferContext arch)
     (StateT (InferState arch ids) (Except (RegisterUseError arch)))
     (BlockInferValue arch ids tp, MemAccessInfo arch ids)
forall a.
a
-> ReaderT
     (StartInferContext arch)
     (StateT (InferState arch ids) (Except (RegisterUseError arch)))
     a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (InitInferValue arch tp
-> MemSlice tp tp -> BlockInferValue arch ids tp
forall arch (wtp :: Type) (rtp :: Type) ids.
InitInferValue arch wtp
-> MemSlice wtp rtp -> BlockInferValue arch ids rtp
IVDomain InitInferValue arch tp
d MemSlice tp tp
ms, MemInt (ArchAddrWidth arch)
-> InitInferValue arch tp -> MemAccessInfo arch ids
forall arch ids (tp :: Type).
MemInt (ArchAddrWidth arch)
-> InitInferValue arch tp -> MemAccessInfo arch ids
FrameReadInitAccess MemInt (ArchAddrWidth arch)
o InitInferValue arch tp
d)
                  ISVWrite Int
writeIdx Value arch ids tp
v ->
                    case StartInferContext arch
-> MapF (AssignId ids) (BlockInferValue arch ids)
-> Value arch ids tp
-> MemSlice tp tp
-> Maybe (BlockInferValue arch ids tp)
forall arch ids (wtp :: Type) (rtp :: Type).
OrdF (ArchReg arch) =>
StartInferContext arch
-> MapF (AssignId ids) (BlockInferValue arch ids)
-> Value arch ids wtp
-> MemSlice wtp rtp
-> Maybe (BlockInferValue arch ids rtp)
valueToStartExpr' StartInferContext arch
ctx MapF (AssignId ids) (BlockInferValue arch ids)
am Value arch ids tp
v MemSlice tp tp
ms of
                      Maybe (BlockInferValue arch ids tp)
Nothing -> do
                        Int
-> ReaderT
     (StartInferContext arch)
     (StateT (InferState arch ids) (Except (RegisterUseError arch)))
     (BlockInferValue arch ids tp, MemAccessInfo arch ids)
forall arch ids as. Int -> StartInfer arch ids as
unresolvedStackRead Int
stmtIdx
                      Just BlockInferValue arch ids tp
iv ->
                        (BlockInferValue arch ids tp, MemAccessInfo arch ids)
-> ReaderT
     (StartInferContext arch)
     (StateT (InferState arch ids) (Except (RegisterUseError arch)))
     (BlockInferValue arch ids tp, MemAccessInfo arch ids)
forall a.
a
-> ReaderT
     (StartInferContext arch)
     (StateT (InferState arch ids) (Except (RegisterUseError arch)))
     a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (BlockInferValue arch ids tp
iv, Int -> MemAccessInfo arch ids
forall arch ids. Int -> MemAccessInfo arch ids
FrameReadWriteAccess Int
writeIdx)
                  ISVCondWrite Int
writeIdx Value arch ids BoolType
_ Value arch ids tp
_ InferStackValue arch ids tp
_ -> do
                    case MemSlice tp tp
ms of
                      MemSlice tp tp
NoMemSlice ->
                        (BlockInferValue arch ids tp, MemAccessInfo arch ids)
-> ReaderT
     (StartInferContext arch)
     (StateT (InferState arch ids) (Except (RegisterUseError arch)))
     (BlockInferValue arch ids tp, MemAccessInfo arch ids)
forall a.
a
-> ReaderT
     (StartInferContext arch)
     (StateT (InferState arch ids) (Except (RegisterUseError arch)))
     a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Int -> MemRepr tp -> BlockInferValue arch ids tp
forall (tp :: Type) arch ids.
Int -> MemRepr tp -> BlockInferValue arch ids tp
IVCondWrite Int
writeIdx MemRepr tp
repr, Int -> MemAccessInfo arch ids
forall arch ids. Int -> MemAccessInfo arch ids
FrameReadWriteAccess Int
writeIdx)
                      MemSlice Integer
_ MemRepr tp
_ MemRepr tp
_ ->
                        Int
-> ReaderT
     (StartInferContext arch)
     (StateT (InferState arch ids) (Except (RegisterUseError arch)))
     (BlockInferValue arch ids tp, MemAccessInfo arch ids)
forall arch ids as. Int -> StartInfer arch ids as
unresolvedStackRead Int
stmtIdx
              AssignId ids tp
-> BlockInferValue arch ids tp -> StartInfer arch ids ()
forall ids (tp :: Type) arch.
AssignId ids tp
-> BlockInferValue arch ids tp -> StartInfer arch ids ()
setAssignVal AssignId ids tp
aid BlockInferValue arch ids tp
v
              Int -> MemAccessInfo arch ids -> StartInfer arch ids ()
forall arch ids.
Int -> MemAccessInfo arch ids -> StartInfer arch ids ()
addMemAccessInfo Int
stmtIdx MemAccessInfo arch ids
memInfo
        -- Uninitialized reads are equal to what came before.
        Maybe
  (MemInt (ArchAddrWidth arch), MemVal (InferStackValue arch ids))
Nothing -> do
          let d :: InitInferValue arch tp
d = BoundLoc (ArchReg arch) tp -> InitInferValue arch tp
forall arch (tp :: Type).
BoundLoc (ArchReg arch) tp -> InitInferValue arch tp
RegEqualLoc (MemInt (ArchAddrWidth arch)
-> MemRepr tp -> BoundLoc (ArchReg arch) tp
forall (r :: Type -> Type) (tp :: Type).
MemInt (RegAddrWidth r) -> MemRepr tp -> BoundLoc r tp
StackOffLoc MemInt (ArchAddrWidth arch)
o MemRepr tp
repr)
          AssignId ids tp
-> BlockInferValue arch ids tp -> StartInfer arch ids ()
forall ids (tp :: Type) arch.
AssignId ids tp
-> BlockInferValue arch ids tp -> StartInfer arch ids ()
setAssignVal AssignId ids tp
aid (InitInferValue arch tp
-> MemSlice tp tp -> BlockInferValue arch ids tp
forall arch (wtp :: Type) (rtp :: Type) ids.
InitInferValue arch wtp
-> MemSlice wtp rtp -> BlockInferValue arch ids rtp
IVDomain InitInferValue arch tp
d MemSlice tp tp
forall (tp :: Type). MemSlice tp tp
NoMemSlice)
          Int -> MemAccessInfo arch ids -> StartInfer arch ids ()
forall arch ids.
Int -> MemAccessInfo arch ids -> StartInfer arch ids ()
addMemAccessInfo Int
stmtIdx (MemInt (ArchAddrWidth arch)
-> InitInferValue arch tp -> MemAccessInfo arch ids
forall arch ids (tp :: Type).
MemInt (ArchAddrWidth arch)
-> InitInferValue arch tp -> MemAccessInfo arch ids
FrameReadInitAccess MemInt (ArchAddrWidth arch)
o InitInferValue arch tp
d)
    -- Non-stack reads are just equal to themselves.
    BlockInferValue arch ids (BVType (ArchAddrWidth arch))
_ -> Int -> MemAccessInfo arch ids -> StartInfer arch ids ()
forall arch ids.
Int -> MemAccessInfo arch ids -> StartInfer arch ids ()
addMemAccessInfo Int
stmtIdx MemAccessInfo arch ids
forall arch ids. MemAccessInfo arch ids
NotFrameAccess

-- | Infer constraints from a memory read.
--
-- Unlike inferReadMem these are not assigned a value, but we still
-- track which write was associated if possible.
inferCondReadMem :: (MemWidth (ArchAddrWidth arch), OrdF (ArchReg arch))
                 => StmtIndex
                 -> Value arch ids (BVType (ArchAddrWidth arch))
                 -> MemRepr tp
                 -> StartInfer arch ids ()
inferCondReadMem :: forall arch ids (tp :: Type).
(MemWidth (ArchAddrWidth arch), OrdF (ArchReg arch)) =>
Int
-> Value arch ids (BVType (ArchAddrWidth arch))
-> MemRepr tp
-> StartInfer arch ids ()
inferCondReadMem Int
stmtIdx Value arch ids (BVType (ArchAddrWidth arch))
addr MemRepr tp
_repr = do
  StartInferContext arch
ctx <- ReaderT
  (StartInferContext arch)
  (StateT (InferState arch ids) (Except (RegisterUseError arch)))
  (StartInferContext arch)
forall r (m :: Type -> Type). MonadReader r m => m r
ask
  MapF (AssignId ids) (BlockInferValue arch ids)
s <- (InferState arch ids
 -> MapF (AssignId ids) (BlockInferValue arch ids))
-> ReaderT
     (StartInferContext arch)
     (StateT (InferState arch ids) (Except (RegisterUseError arch)))
     (MapF (AssignId ids) (BlockInferValue arch ids))
forall s (m :: Type -> Type) a. MonadState s m => (s -> a) -> m a
gets InferState arch ids
-> MapF (AssignId ids) (BlockInferValue arch ids)
forall arch ids.
InferState arch ids
-> MapF (AssignId ids) (BlockInferValue arch ids)
sisAssignMap
  case StartInferContext arch
-> MapF (AssignId ids) (BlockInferValue arch ids)
-> Value arch ids (BVType (ArchAddrWidth arch))
-> BlockInferValue arch ids (BVType (ArchAddrWidth arch))
forall arch ids (tp :: Type).
OrdF (ArchReg arch) =>
StartInferContext arch
-> MapF (AssignId ids) (BlockInferValue arch ids)
-> Value arch ids tp
-> BlockInferValue arch ids tp
valueToStartExpr StartInferContext arch
ctx MapF (AssignId ids) (BlockInferValue arch ids)
s Value arch ids (BVType (ArchAddrWidth arch))
addr of
    -- Stack reads need to record the offset.
    FrameExpr MemInt (ArchAddrWidth arch)
_o -> do
      Int -> RegisterUseErrorTag () -> () -> StartInfer arch ids ()
forall e arch ids a.
Int -> RegisterUseErrorTag e -> e -> StartInfer arch ids a
throwRegError Int
stmtIdx RegisterUseErrorTag ()
UnsupportedCondStackRead ()
    -- Non-stack reads are just equal to themselves.
    BlockInferValue arch ids (BVType (ArchAddrWidth arch))
_ -> Int -> MemAccessInfo arch ids -> StartInfer arch ids ()
forall arch ids.
Int -> MemAccessInfo arch ids -> StartInfer arch ids ()
addMemAccessInfo Int
stmtIdx MemAccessInfo arch ids
forall arch ids. MemAccessInfo arch ids
NotFrameAccess

-- | Update start infer statement to reflect statement.
processStmt :: (OrdF (ArchReg arch), MemWidth (ArchAddrWidth arch))
            => StmtIndex
            -> Stmt arch ids
            -> StartInfer arch ids ()
processStmt :: forall arch ids.
(OrdF (ArchReg arch), MemWidth (ArchAddrWidth arch)) =>
Int -> Stmt arch ids -> StartInfer arch ids ()
processStmt Int
stmtIdx Stmt arch ids
stmt = do
  case Stmt arch ids
stmt of
    AssignStmt (Assignment AssignId ids tp
aid AssignRhs arch (Value arch ids) tp
arhs) ->
      case AssignRhs arch (Value arch ids) tp
arhs of
        EvalApp App (Value arch ids) tp
app -> AssignId ids tp
-> App (Value arch ids) tp -> StartInfer arch ids ()
forall arch ids (tp :: Type).
(OrdF (ArchReg arch), MemWidth (ArchAddrWidth arch)) =>
AssignId ids tp
-> App (Value arch ids) tp -> StartInfer arch ids ()
processApp AssignId ids tp
aid App (Value arch ids) tp
app
        -- Assignment equal to itself.
        SetUndefined TypeRepr tp
_ -> () -> StartInfer arch ids ()
forall a.
a
-> ReaderT
     (StartInferContext arch)
     (StateT (InferState arch ids) (Except (RegisterUseError arch)))
     a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ()
        ReadMem Value arch ids (BVType (ArchAddrWidth arch))
addr MemRepr tp
repr -> Int
-> AssignId ids tp
-> Value arch ids (BVType (ArchAddrWidth arch))
-> MemRepr tp
-> StartInfer arch ids ()
forall arch ids (tp :: Type).
(MemWidth (ArchAddrWidth arch), OrdF (ArchReg arch)) =>
Int
-> AssignId ids tp
-> Value arch ids (BVType (ArchAddrWidth arch))
-> MemRepr tp
-> StartInfer arch ids ()
inferReadMem Int
stmtIdx AssignId ids tp
aid Value arch ids (BVType (ArchAddrWidth arch))
addr MemRepr tp
repr
        CondReadMem MemRepr tp
repr Value arch ids BoolType
_cond Value arch ids (BVType (ArchAddrWidth arch))
addr Value arch ids tp
_falseVal -> Int
-> Value arch ids (BVType (ArchAddrWidth arch))
-> MemRepr tp
-> StartInfer arch ids ()
forall arch ids (tp :: Type).
(MemWidth (ArchAddrWidth arch), OrdF (ArchReg arch)) =>
Int
-> Value arch ids (BVType (ArchAddrWidth arch))
-> MemRepr tp
-> StartInfer arch ids ()
inferCondReadMem Int
stmtIdx Value arch ids (BVType (ArchAddrWidth arch))
addr MemRepr tp
repr
        -- Architecture-specific functions are just equal to themselves.
        EvalArchFn ArchFn arch (Value arch ids) tp
_afn TypeRepr tp
_repr -> () -> StartInfer arch ids ()
forall a.
a
-> ReaderT
     (StartInferContext arch)
     (StateT (InferState arch ids) (Except (RegisterUseError arch)))
     a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ()
    WriteMem Value arch ids (BVType (ArchAddrWidth arch))
addr MemRepr tp
repr Value arch ids tp
val -> do
      StartInferContext arch
ctx <- ReaderT
  (StartInferContext arch)
  (StateT (InferState arch ids) (Except (RegisterUseError arch)))
  (StartInferContext arch)
forall r (m :: Type -> Type). MonadReader r m => m r
ask
      MapF (AssignId ids) (BlockInferValue arch ids)
s <- (InferState arch ids
 -> MapF (AssignId ids) (BlockInferValue arch ids))
-> ReaderT
     (StartInferContext arch)
     (StateT (InferState arch ids) (Except (RegisterUseError arch)))
     (MapF (AssignId ids) (BlockInferValue arch ids))
forall s (m :: Type -> Type) a. MonadState s m => (s -> a) -> m a
gets InferState arch ids
-> MapF (AssignId ids) (BlockInferValue arch ids)
forall arch ids.
InferState arch ids
-> MapF (AssignId ids) (BlockInferValue arch ids)
sisAssignMap
      case StartInferContext arch
-> MapF (AssignId ids) (BlockInferValue arch ids)
-> Value arch ids (BVType (ArchAddrWidth arch))
-> BlockInferValue arch ids (BVType (ArchAddrWidth arch))
forall arch ids (tp :: Type).
OrdF (ArchReg arch) =>
StartInferContext arch
-> MapF (AssignId ids) (BlockInferValue arch ids)
-> Value arch ids tp
-> BlockInferValue arch ids tp
valueToStartExpr StartInferContext arch
ctx MapF (AssignId ids) (BlockInferValue arch ids)
s Value arch ids (BVType (ArchAddrWidth arch))
addr of
        FrameExpr MemInt (ArchAddrWidth arch)
o -> do
          Int -> MemAccessInfo arch ids -> StartInfer arch ids ()
forall arch ids.
Int -> MemAccessInfo arch ids -> StartInfer arch ids ()
addMemAccessInfo Int
stmtIdx (MemInt (ArchAddrWidth arch) -> MemAccessInfo arch ids
forall arch ids.
MemInt (ArchAddrWidth arch) -> MemAccessInfo arch ids
FrameWriteAccess MemInt (ArchAddrWidth arch)
o)
          -- Get value of val under current equality constraints.
          (MemMap (MemInt (ArchAddrWidth arch)) (InferStackValue arch ids)
 -> Identity
      (MemMap (MemInt (ArchAddrWidth arch)) (InferStackValue arch ids)))
-> InferState arch ids -> Identity (InferState arch ids)
forall arch ids (f :: Type -> Type).
Functor f =>
(MemMap (MemInt (ArchAddrWidth arch)) (InferStackValue arch ids)
 -> f (MemMap
         (MemInt (ArchAddrWidth arch)) (InferStackValue arch ids)))
-> InferState arch ids -> f (InferState arch ids)
sisStackLens ((MemMap (MemInt (ArchAddrWidth arch)) (InferStackValue arch ids)
  -> Identity
       (MemMap (MemInt (ArchAddrWidth arch)) (InferStackValue arch ids)))
 -> InferState arch ids -> Identity (InferState arch ids))
-> (MemMap (MemInt (ArchAddrWidth arch)) (InferStackValue arch ids)
    -> MemMap (MemInt (ArchAddrWidth arch)) (InferStackValue arch ids))
-> StartInfer arch ids ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= MemInt (ArchAddrWidth arch)
-> MemRepr tp
-> InferStackValue arch ids tp
-> MemMap (MemInt (ArchAddrWidth arch)) (InferStackValue arch ids)
-> MemMap (MemInt (ArchAddrWidth arch)) (InferStackValue arch ids)
forall o (p :: Type -> Type) (tp :: Type).
(Ord o, Num o) =>
o -> MemRepr tp -> p tp -> MemMap o p -> MemMap o p
memMapOverwrite MemInt (ArchAddrWidth arch)
o MemRepr tp
repr (Int -> Value arch ids tp -> InferStackValue arch ids tp
forall arch ids (tp :: Type).
Int -> Value arch ids tp -> InferStackValue arch ids tp
ISVWrite Int
stmtIdx Value arch ids tp
val)
        -- Do nothing for things that are not stack expressions.
        --
        -- Note.  If @addr@ actually may point to the stack but we end
        -- up in this case, then @sisStack@ will not be properly
        -- updated to reflect real contents, and the value refered
        -- to be subsequent @readMem@ operations may be incorrect.
        --
        -- This is currently unavoidable to fix in this code, and
        -- perhaps can never be fully addressed as we'd basically need
        -- a proof that that the stack could not be overwritten.
        -- However, this will be caught by verification of the
        -- eventual LLVM.
        BlockInferValue arch ids (BVType (ArchAddrWidth arch))
_ -> Int -> MemAccessInfo arch ids -> StartInfer arch ids ()
forall arch ids.
Int -> MemAccessInfo arch ids -> StartInfer arch ids ()
addMemAccessInfo Int
stmtIdx MemAccessInfo arch ids
forall arch ids. MemAccessInfo arch ids
NotFrameAccess
    CondWriteMem Value arch ids BoolType
cond Value arch ids (BVType (ArchAddrWidth arch))
addr MemRepr tp
repr Value arch ids tp
val -> do
      StartInferContext arch
ctx <- ReaderT
  (StartInferContext arch)
  (StateT (InferState arch ids) (Except (RegisterUseError arch)))
  (StartInferContext arch)
forall r (m :: Type -> Type). MonadReader r m => m r
ask
      MapF (AssignId ids) (BlockInferValue arch ids)
s <- (InferState arch ids
 -> MapF (AssignId ids) (BlockInferValue arch ids))
-> ReaderT
     (StartInferContext arch)
     (StateT (InferState arch ids) (Except (RegisterUseError arch)))
     (MapF (AssignId ids) (BlockInferValue arch ids))
forall s (m :: Type -> Type) a. MonadState s m => (s -> a) -> m a
gets InferState arch ids
-> MapF (AssignId ids) (BlockInferValue arch ids)
forall arch ids.
InferState arch ids
-> MapF (AssignId ids) (BlockInferValue arch ids)
sisAssignMap
      case StartInferContext arch
-> MapF (AssignId ids) (BlockInferValue arch ids)
-> Value arch ids (BVType (ArchAddrWidth arch))
-> BlockInferValue arch ids (BVType (ArchAddrWidth arch))
forall arch ids (tp :: Type).
OrdF (ArchReg arch) =>
StartInferContext arch
-> MapF (AssignId ids) (BlockInferValue arch ids)
-> Value arch ids tp
-> BlockInferValue arch ids tp
valueToStartExpr StartInferContext arch
ctx MapF (AssignId ids) (BlockInferValue arch ids)
s Value arch ids (BVType (ArchAddrWidth arch))
addr of
        FrameExpr MemInt (ArchAddrWidth arch)
o -> do
          MemMap (MemInt (ArchAddrWidth arch)) (InferStackValue arch ids)
stk <- (InferState arch ids
 -> MemMap (MemInt (ArchAddrWidth arch)) (InferStackValue arch ids))
-> ReaderT
     (StartInferContext arch)
     (StateT (InferState arch ids) (Except (RegisterUseError arch)))
     (MemMap (MemInt (ArchAddrWidth arch)) (InferStackValue arch ids))
forall s (m :: Type -> Type) a. MonadState s m => (s -> a) -> m a
gets InferState arch ids
-> MemMap (MemInt (ArchAddrWidth arch)) (InferStackValue arch ids)
forall arch ids.
InferState arch ids
-> MemMap (MemInt (ArchAddrWidth arch)) (InferStackValue arch ids)
sisStack
          InferStackValue arch ids tp
sv <-
            case MemInt (ArchAddrWidth arch)
-> MemRepr tp
-> MemMap (MemInt (ArchAddrWidth arch)) (InferStackValue arch ids)
-> MemMapLookup
     (MemInt (ArchAddrWidth arch)) (InferStackValue arch ids) tp
forall o (tp :: Type) (p :: Type -> Type).
MemIndex o =>
o -> MemRepr tp -> MemMap o p -> MemMapLookup o p tp
memMapLookup MemInt (ArchAddrWidth arch)
o MemRepr tp
repr MemMap (MemInt (ArchAddrWidth arch)) (InferStackValue arch ids)
stk of
              MMLResult InferStackValue arch ids tp
sv -> do
                Int -> MemAccessInfo arch ids -> StartInfer arch ids ()
forall arch ids.
Int -> MemAccessInfo arch ids -> StartInfer arch ids ()
addMemAccessInfo Int
stmtIdx (MemInt (ArchAddrWidth arch)
-> MemRepr tp
-> InferStackValue arch ids tp
-> MemAccessInfo arch ids
forall arch ids (tp :: Type).
MemInt (ArchAddrWidth arch)
-> MemRepr tp
-> InferStackValue arch ids tp
-> MemAccessInfo arch ids
FrameCondWriteAccess MemInt (ArchAddrWidth arch)
o MemRepr tp
repr InferStackValue arch ids tp
sv)
                InferStackValue arch ids tp
-> ReaderT
     (StartInferContext arch)
     (StateT (InferState arch ids) (Except (RegisterUseError arch)))
     (InferStackValue arch ids tp)
forall a.
a
-> ReaderT
     (StartInferContext arch)
     (StateT (InferState arch ids) (Except (RegisterUseError arch)))
     a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure InferStackValue arch ids tp
sv
              MMLOverlap{} -> do
                Int -> MemAccessInfo arch ids -> StartInfer arch ids ()
forall arch ids.
Int -> MemAccessInfo arch ids -> StartInfer arch ids ()
addMemAccessInfo Int
stmtIdx (MemInt (ArchAddrWidth arch) -> MemAccessInfo arch ids
forall arch ids.
MemInt (ArchAddrWidth arch) -> MemAccessInfo arch ids
FrameCondWriteOverlapAccess MemInt (ArchAddrWidth arch)
o)
                InferStackValue arch ids tp
-> ReaderT
     (StartInferContext arch)
     (StateT (InferState arch ids) (Except (RegisterUseError arch)))
     (InferStackValue arch ids tp)
forall a.
a
-> ReaderT
     (StartInferContext arch)
     (StateT (InferState arch ids) (Except (RegisterUseError arch)))
     a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (InferStackValue arch ids tp
 -> ReaderT
      (StartInferContext arch)
      (StateT (InferState arch ids) (Except (RegisterUseError arch)))
      (InferStackValue arch ids tp))
-> InferStackValue arch ids tp
-> ReaderT
     (StartInferContext arch)
     (StateT (InferState arch ids) (Except (RegisterUseError arch)))
     (InferStackValue arch ids tp)
forall a b. (a -> b) -> a -> b
$ InitInferValue arch tp -> InferStackValue arch ids tp
forall arch (tp :: Type) ids.
InitInferValue arch tp -> InferStackValue arch ids tp
ISVInitValue (BoundLoc (ArchReg arch) tp -> InitInferValue arch tp
forall arch (tp :: Type).
BoundLoc (ArchReg arch) tp -> InitInferValue arch tp
RegEqualLoc (MemInt (ArchAddrWidth arch)
-> MemRepr tp -> BoundLoc (ArchReg arch) tp
forall (r :: Type -> Type) (tp :: Type).
MemInt (RegAddrWidth r) -> MemRepr tp -> BoundLoc r tp
StackOffLoc MemInt (ArchAddrWidth arch)
o MemRepr tp
repr))
              MemMapLookup
  (MemInt (ArchAddrWidth arch)) (InferStackValue arch ids) tp
MMLNone -> do
                let sv :: InferStackValue arch ids tp
sv = InitInferValue arch tp -> InferStackValue arch ids tp
forall arch (tp :: Type) ids.
InitInferValue arch tp -> InferStackValue arch ids tp
ISVInitValue (BoundLoc (ArchReg arch) tp -> InitInferValue arch tp
forall arch (tp :: Type).
BoundLoc (ArchReg arch) tp -> InitInferValue arch tp
RegEqualLoc (MemInt (ArchAddrWidth arch)
-> MemRepr tp -> BoundLoc (ArchReg arch) tp
forall (r :: Type -> Type) (tp :: Type).
MemInt (RegAddrWidth r) -> MemRepr tp -> BoundLoc r tp
StackOffLoc MemInt (ArchAddrWidth arch)
o MemRepr tp
repr))
                Int -> MemAccessInfo arch ids -> StartInfer arch ids ()
forall arch ids.
Int -> MemAccessInfo arch ids -> StartInfer arch ids ()
addMemAccessInfo Int
stmtIdx (MemInt (ArchAddrWidth arch)
-> MemRepr tp
-> InferStackValue arch ids tp
-> MemAccessInfo arch ids
forall arch ids (tp :: Type).
MemInt (ArchAddrWidth arch)
-> MemRepr tp
-> InferStackValue arch ids tp
-> MemAccessInfo arch ids
FrameCondWriteAccess MemInt (ArchAddrWidth arch)
o MemRepr tp
repr InferStackValue arch ids tp
sv)
                InferStackValue arch ids tp
-> ReaderT
     (StartInferContext arch)
     (StateT (InferState arch ids) (Except (RegisterUseError arch)))
     (InferStackValue arch ids tp)
forall a.
a
-> ReaderT
     (StartInferContext arch)
     (StateT (InferState arch ids) (Except (RegisterUseError arch)))
     a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure InferStackValue arch ids tp
sv
          (MemMap (MemInt (ArchAddrWidth arch)) (InferStackValue arch ids)
 -> Identity
      (MemMap (MemInt (ArchAddrWidth arch)) (InferStackValue arch ids)))
-> InferState arch ids -> Identity (InferState arch ids)
forall arch ids (f :: Type -> Type).
Functor f =>
(MemMap (MemInt (ArchAddrWidth arch)) (InferStackValue arch ids)
 -> f (MemMap
         (MemInt (ArchAddrWidth arch)) (InferStackValue arch ids)))
-> InferState arch ids -> f (InferState arch ids)
sisStackLens ((MemMap (MemInt (ArchAddrWidth arch)) (InferStackValue arch ids)
  -> Identity
       (MemMap (MemInt (ArchAddrWidth arch)) (InferStackValue arch ids)))
 -> InferState arch ids -> Identity (InferState arch ids))
-> (MemMap (MemInt (ArchAddrWidth arch)) (InferStackValue arch ids)
    -> MemMap (MemInt (ArchAddrWidth arch)) (InferStackValue arch ids))
-> StartInfer arch ids ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= MemInt (ArchAddrWidth arch)
-> MemRepr tp
-> InferStackValue arch ids tp
-> MemMap (MemInt (ArchAddrWidth arch)) (InferStackValue arch ids)
-> MemMap (MemInt (ArchAddrWidth arch)) (InferStackValue arch ids)
forall o (p :: Type -> Type) (tp :: Type).
(Ord o, Num o) =>
o -> MemRepr tp -> p tp -> MemMap o p -> MemMap o p
memMapOverwrite MemInt (ArchAddrWidth arch)
o MemRepr tp
repr (Int
-> Value arch ids BoolType
-> Value arch ids tp
-> InferStackValue arch ids tp
-> InferStackValue arch ids tp
forall arch ids (tp :: Type).
Int
-> Value arch ids BoolType
-> Value arch ids tp
-> InferStackValue arch ids tp
-> InferStackValue arch ids tp
ISVCondWrite Int
stmtIdx Value arch ids BoolType
cond Value arch ids tp
val InferStackValue arch ids tp
sv)
        BlockInferValue arch ids (BVType (ArchAddrWidth arch))
_ -> do
          Int -> MemAccessInfo arch ids -> StartInfer arch ids ()
forall arch ids.
Int -> MemAccessInfo arch ids -> StartInfer arch ids ()
addMemAccessInfo Int
stmtIdx MemAccessInfo arch ids
forall arch ids. MemAccessInfo arch ids
NotFrameAccess
    -- Do nothing with instruction start/comment/register update
    InstructionStart ArchAddrWord arch
o Text
_ ->
      (ArchAddrWord arch -> Identity (ArchAddrWord arch))
-> InferState arch ids -> Identity (InferState arch ids)
forall arch ids (f :: Type -> Type).
Functor f =>
(ArchAddrWord arch -> f (ArchAddrWord arch))
-> InferState arch ids -> f (InferState arch ids)
sisCurrentInstructionOffsetLens ((ArchAddrWord arch -> Identity (ArchAddrWord arch))
 -> InferState arch ids -> Identity (InferState arch ids))
-> ArchAddrWord arch -> StartInfer arch ids ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= ArchAddrWord arch
o
    Comment Text
_ -> () -> StartInfer arch ids ()
forall a.
a
-> ReaderT
     (StartInferContext arch)
     (StateT (InferState arch ids) (Except (RegisterUseError arch)))
     a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ()
    ArchState{} -> () -> StartInfer arch ids ()
forall a.
a
-> ReaderT
     (StartInferContext arch)
     (StateT (InferState arch ids) (Except (RegisterUseError arch)))
     a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ()
    -- For now we assume architecture statement does not modify any
    -- of the locations.
    ExecArchStmt ArchStmt arch (Value arch ids)
_ -> () -> StartInfer arch ids ()
forall a.
a
-> ReaderT
     (StartInferContext arch)
     (StateT (InferState arch ids) (Except (RegisterUseError arch)))
     a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ()

-- | Maps locations to the values to initialize next locations with.
newtype PostValueMap arch ids =
  PVM { forall arch ids.
PostValueMap arch ids
-> MapF (BoundLoc (ArchReg arch)) (BlockInferValue arch ids)
_pvmMap :: MapF (BoundLoc (ArchReg arch)) (BlockInferValue arch ids) }

emptyPVM :: PostValueMap arch ids
emptyPVM :: forall arch ids. PostValueMap arch ids
emptyPVM = MapF (BoundLoc (ArchReg arch)) (BlockInferValue arch ids)
-> PostValueMap arch ids
forall arch ids.
MapF (BoundLoc (ArchReg arch)) (BlockInferValue arch ids)
-> PostValueMap arch ids
PVM MapF (BoundLoc (ArchReg arch)) (BlockInferValue arch ids)
forall {v} (k :: v -> Type) (a :: v -> Type). MapF k a
MapF.empty

pvmBind :: OrdF (ArchReg arch)
        => BoundLoc (ArchReg arch) tp
        -> BlockInferValue arch ids tp
        -> PostValueMap arch ids
        -> PostValueMap arch ids
pvmBind :: forall arch (tp :: Type) ids.
OrdF (ArchReg arch) =>
BoundLoc (ArchReg arch) tp
-> BlockInferValue arch ids tp
-> PostValueMap arch ids
-> PostValueMap arch ids
pvmBind BoundLoc (ArchReg arch) tp
l BlockInferValue arch ids tp
v (PVM MapF (BoundLoc (ArchReg arch)) (BlockInferValue arch ids)
m) = MapF (BoundLoc (ArchReg arch)) (BlockInferValue arch ids)
-> PostValueMap arch ids
forall arch ids.
MapF (BoundLoc (ArchReg arch)) (BlockInferValue arch ids)
-> PostValueMap arch ids
PVM (BoundLoc (ArchReg arch) tp
-> BlockInferValue arch ids tp
-> MapF (BoundLoc (ArchReg arch)) (BlockInferValue arch ids)
-> MapF (BoundLoc (ArchReg arch)) (BlockInferValue arch ids)
forall {v} (k :: v -> Type) (tp :: v) (a :: v -> Type).
OrdF k =>
k tp -> a tp -> MapF k a -> MapF k a
MapF.insert BoundLoc (ArchReg arch) tp
l BlockInferValue arch ids tp
v MapF (BoundLoc (ArchReg arch)) (BlockInferValue arch ids)
m)

pvmFind :: OrdF (ArchReg arch)
        => BoundLoc (ArchReg arch) tp
        -> PostValueMap arch ids
        -> BlockInferValue arch ids tp
pvmFind :: forall arch (tp :: Type) ids.
OrdF (ArchReg arch) =>
BoundLoc (ArchReg arch) tp
-> PostValueMap arch ids -> BlockInferValue arch ids tp
pvmFind BoundLoc (ArchReg arch) tp
l (PVM MapF (BoundLoc (ArchReg arch)) (BlockInferValue arch ids)
m) = BlockInferValue arch ids tp
-> BoundLoc (ArchReg arch) tp
-> MapF (BoundLoc (ArchReg arch)) (BlockInferValue arch ids)
-> BlockInferValue arch ids tp
forall {v} (k :: v -> Type) (a :: v -> Type) (tp :: v).
OrdF k =>
a tp -> k tp -> MapF k a -> a tp
MapF.findWithDefault (InitInferValue arch tp
-> MemSlice tp tp -> BlockInferValue arch ids tp
forall arch (wtp :: Type) (rtp :: Type) ids.
InitInferValue arch wtp
-> MemSlice wtp rtp -> BlockInferValue arch ids rtp
IVDomain (BoundLoc (ArchReg arch) tp -> InitInferValue arch tp
forall arch (tp :: Type).
BoundLoc (ArchReg arch) tp -> InitInferValue arch tp
RegEqualLoc BoundLoc (ArchReg arch) tp
l) MemSlice tp tp
forall (tp :: Type). MemSlice tp tp
NoMemSlice) BoundLoc (ArchReg arch) tp
l MapF (BoundLoc (ArchReg arch)) (BlockInferValue arch ids)
m

instance ShowF (ArchReg arch) => Show (PostValueMap arch ids) where
  show :: PostValueMap arch ids -> String
show (PVM MapF (BoundLoc (ArchReg arch)) (BlockInferValue arch ids)
m) = MapF (BoundLoc (ArchReg arch)) (BlockInferValue arch ids) -> String
forall a. Show a => a -> String
show MapF (BoundLoc (ArchReg arch)) (BlockInferValue arch ids)
m

ppPVM :: forall arch ids ann . ShowF (ArchReg arch) => PostValueMap arch ids -> Doc ann
ppPVM :: forall arch ids ann.
ShowF (ArchReg arch) =>
PostValueMap arch ids -> Doc ann
ppPVM (PVM MapF (BoundLoc (ArchReg arch)) (BlockInferValue arch ids)
m) = [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vcat ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$ Pair (BoundLoc (ArchReg arch)) (BlockInferValue arch ids)
-> Doc ann
ppVal (Pair (BoundLoc (ArchReg arch)) (BlockInferValue arch ids)
 -> Doc ann)
-> [Pair (BoundLoc (ArchReg arch)) (BlockInferValue arch ids)]
-> [Doc ann]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> MapF (BoundLoc (ArchReg arch)) (BlockInferValue arch ids)
-> [Pair (BoundLoc (ArchReg arch)) (BlockInferValue arch ids)]
forall {k1} (k2 :: k1 -> Type) (a :: k1 -> Type).
MapF k2 a -> [Pair k2 a]
MapF.toList MapF (BoundLoc (ArchReg arch)) (BlockInferValue arch ids)
m
  where ppVal :: Pair (BoundLoc (ArchReg arch)) (BlockInferValue arch ids) -> Doc ann
        ppVal :: Pair (BoundLoc (ArchReg arch)) (BlockInferValue arch ids)
-> Doc ann
ppVal (Pair BoundLoc (ArchReg arch) tp
l BlockInferValue arch ids tp
v) = BoundLoc (ArchReg arch) tp -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. BoundLoc (ArchReg arch) tp -> Doc ann
pretty BoundLoc (ArchReg arch) tp
l Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
":=" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> BlockInferValue arch ids tp -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow BlockInferValue arch ids tp
v

type StartInferInfo arch ids =
  ( ParsedBlock arch ids
  , BlockStartConstraints arch
  , InferState arch ids
  , Map (ArchSegmentOff arch) (PostValueMap arch ids)
  )

siiCns :: StartInferInfo arch ids -> BlockStartConstraints arch
siiCns :: forall arch ids.
StartInferInfo arch ids -> BlockStartConstraints arch
siiCns (ParsedBlock arch ids
_,BlockStartConstraints arch
cns,InferState arch ids
_,Map (ArchSegmentOff arch) (PostValueMap arch ids)
_) = BlockStartConstraints arch
cns

type FrontierMap arch = Map (ArchSegmentOff arch) (BlockStartConstraints arch)

data InferNextState arch ids =
  InferNextState { forall arch ids.
InferNextState arch ids
-> MapF (BlockInferValue arch ids) (InitInferValue arch)
insSeenValues :: !(MapF (BlockInferValue arch ids) (InitInferValue arch))
                 , forall arch ids. InferNextState arch ids -> PostValueMap arch ids
insPVM        :: !(PostValueMap arch ids)
                 }

-- | Monad for inferring next state.
type InferNextM arch ids = State (InferNextState arch ids)

runInferNextM :: InferNextM arch ids a -> a
runInferNextM :: forall arch ids a. InferNextM arch ids a -> a
runInferNextM InferNextM arch ids a
m =
  let s :: InferNextState arch ids
s = InferNextState { insSeenValues :: MapF (BlockInferValue arch ids) (InitInferValue arch)
insSeenValues = MapF (BlockInferValue arch ids) (InitInferValue arch)
forall {v} (k :: v -> Type) (a :: v -> Type). MapF k a
MapF.empty
                         , insPVM :: PostValueMap arch ids
insPVM       = PostValueMap arch ids
forall arch ids. PostValueMap arch ids
emptyPVM
                         }
   in InferNextM arch ids a -> InferNextState arch ids -> a
forall s a. State s a -> s -> a
evalState InferNextM arch ids a
m InferNextState arch ids
forall {arch} {ids}. InferNextState arch ids
s

-- | @memoNextDomain loc expr@ assumes that @expr@ is the value
-- assigned to @loc@ in the next function, and returns the domain to
-- use for that location in the next block start constraints or
-- @Nothing@ if the value is unconstrained.
memoNextDomain :: OrdF (ArchReg arch)
               => BoundLoc (ArchReg arch) tp
               -> BlockInferValue arch ids tp
               -> InferNextM arch ids (Maybe (InitInferValue arch tp))
memoNextDomain :: forall arch (tp :: Type) ids.
OrdF (ArchReg arch) =>
BoundLoc (ArchReg arch) tp
-> BlockInferValue arch ids tp
-> InferNextM arch ids (Maybe (InitInferValue arch tp))
memoNextDomain BoundLoc (ArchReg arch) tp
_ (IVDomain d :: InitInferValue arch wtp
d@InferredStackOffset{} MemSlice wtp tp
NoMemSlice) =
  Maybe (InitInferValue arch tp)
-> StateT
     (InferNextState arch ids) Identity (Maybe (InitInferValue arch tp))
forall a. a -> StateT (InferNextState arch ids) Identity a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (InitInferValue arch tp -> Maybe (InitInferValue arch tp)
forall a. a -> Maybe a
Just InitInferValue arch tp
InitInferValue arch wtp
d)
memoNextDomain BoundLoc (ArchReg arch) tp
_ (IVDomain d :: InitInferValue arch wtp
d@FnStartRegister{} MemSlice wtp tp
NoMemSlice) = Maybe (InitInferValue arch tp)
-> StateT
     (InferNextState arch ids) Identity (Maybe (InitInferValue arch tp))
forall a. a -> StateT (InferNextState arch ids) Identity a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (InitInferValue arch tp -> Maybe (InitInferValue arch tp)
forall a. a -> Maybe a
Just InitInferValue arch tp
InitInferValue arch wtp
d)
memoNextDomain BoundLoc (ArchReg arch) tp
loc BlockInferValue arch ids tp
e = do
  MapF (BlockInferValue arch ids) (InitInferValue arch)
m <- (InferNextState arch ids
 -> MapF (BlockInferValue arch ids) (InitInferValue arch))
-> StateT
     (InferNextState arch ids)
     Identity
     (MapF (BlockInferValue arch ids) (InitInferValue arch))
forall s (m :: Type -> Type) a. MonadState s m => (s -> a) -> m a
gets InferNextState arch ids
-> MapF (BlockInferValue arch ids) (InitInferValue arch)
forall arch ids.
InferNextState arch ids
-> MapF (BlockInferValue arch ids) (InitInferValue arch)
insSeenValues
  case BlockInferValue arch ids tp
-> MapF (BlockInferValue arch ids) (InitInferValue arch)
-> Maybe (InitInferValue arch tp)
forall {v} (k :: v -> Type) (tp :: v) (a :: v -> Type).
OrdF k =>
k tp -> MapF k a -> Maybe (a tp)
MapF.lookup BlockInferValue arch ids tp
e MapF (BlockInferValue arch ids) (InitInferValue arch)
m of
    Just InitInferValue arch tp
d -> do
      (InferNextState arch ids -> InferNextState arch ids)
-> StateT (InferNextState arch ids) Identity ()
forall s (m :: Type -> Type). MonadState s m => (s -> s) -> m ()
modify ((InferNextState arch ids -> InferNextState arch ids)
 -> StateT (InferNextState arch ids) Identity ())
-> (InferNextState arch ids -> InferNextState arch ids)
-> StateT (InferNextState arch ids) Identity ()
forall a b. (a -> b) -> a -> b
$ \InferNextState arch ids
s -> InferNextState { insSeenValues :: MapF (BlockInferValue arch ids) (InitInferValue arch)
insSeenValues = MapF (BlockInferValue arch ids) (InitInferValue arch)
m
                                    , insPVM :: PostValueMap arch ids
insPVM = BoundLoc (ArchReg arch) tp
-> BlockInferValue arch ids tp
-> PostValueMap arch ids
-> PostValueMap arch ids
forall arch (tp :: Type) ids.
OrdF (ArchReg arch) =>
BoundLoc (ArchReg arch) tp
-> BlockInferValue arch ids tp
-> PostValueMap arch ids
-> PostValueMap arch ids
pvmBind BoundLoc (ArchReg arch) tp
loc BlockInferValue arch ids tp
e (InferNextState arch ids -> PostValueMap arch ids
forall arch ids. InferNextState arch ids -> PostValueMap arch ids
insPVM InferNextState arch ids
s)
                                    }
      Maybe (InitInferValue arch tp)
-> StateT
     (InferNextState arch ids) Identity (Maybe (InitInferValue arch tp))
forall a. a -> StateT (InferNextState arch ids) Identity a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (InitInferValue arch tp -> Maybe (InitInferValue arch tp)
forall a. a -> Maybe a
Just InitInferValue arch tp
d)
    Maybe (InitInferValue arch tp)
Nothing -> do
      (InferNextState arch ids -> InferNextState arch ids)
-> StateT (InferNextState arch ids) Identity ()
forall s (m :: Type -> Type). MonadState s m => (s -> s) -> m ()
modify ((InferNextState arch ids -> InferNextState arch ids)
 -> StateT (InferNextState arch ids) Identity ())
-> (InferNextState arch ids -> InferNextState arch ids)
-> StateT (InferNextState arch ids) Identity ()
forall a b. (a -> b) -> a -> b
$ \InferNextState arch ids
s -> InferNextState { insSeenValues :: MapF (BlockInferValue arch ids) (InitInferValue arch)
insSeenValues = BlockInferValue arch ids tp
-> InitInferValue arch tp
-> MapF (BlockInferValue arch ids) (InitInferValue arch)
-> MapF (BlockInferValue arch ids) (InitInferValue arch)
forall {v} (k :: v -> Type) (tp :: v) (a :: v -> Type).
OrdF k =>
k tp -> a tp -> MapF k a -> MapF k a
MapF.insert BlockInferValue arch ids tp
e (BoundLoc (ArchReg arch) tp -> InitInferValue arch tp
forall arch (tp :: Type).
BoundLoc (ArchReg arch) tp -> InitInferValue arch tp
RegEqualLoc BoundLoc (ArchReg arch) tp
loc) MapF (BlockInferValue arch ids) (InitInferValue arch)
m
                                    , insPVM :: PostValueMap arch ids
insPVM = BoundLoc (ArchReg arch) tp
-> BlockInferValue arch ids tp
-> PostValueMap arch ids
-> PostValueMap arch ids
forall arch (tp :: Type) ids.
OrdF (ArchReg arch) =>
BoundLoc (ArchReg arch) tp
-> BlockInferValue arch ids tp
-> PostValueMap arch ids
-> PostValueMap arch ids
pvmBind BoundLoc (ArchReg arch) tp
loc BlockInferValue arch ids tp
e (InferNextState arch ids -> PostValueMap arch ids
forall arch ids. InferNextState arch ids -> PostValueMap arch ids
insPVM InferNextState arch ids
s)
                                    }
      Maybe (InitInferValue arch tp)
-> StateT
     (InferNextState arch ids) Identity (Maybe (InitInferValue arch tp))
forall a. a -> StateT (InferNextState arch ids) Identity a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Maybe (InitInferValue arch tp)
forall a. Maybe a
Nothing

-- | Process terminal registers
addNextConstraints :: forall arch
                   .  (MemWidth (ArchAddrWidth arch), OrdF (ArchReg arch))
                   => (ArchSegmentOff arch -> Maybe (BlockStartConstraints arch))
                   -- ^ Map of previously explored constraints
                   -> ArchSegmentOff arch
                   -- ^ Address to jump to
                   -> BlockStartConstraints arch
                   -- ^ Start constraints at address.
                   -> FrontierMap arch
                   -- ^ New frontier
                   -> FrontierMap arch
addNextConstraints :: forall arch.
(MemWidth (ArchAddrWidth arch), OrdF (ArchReg arch)) =>
(ArchSegmentOff arch -> Maybe (BlockStartConstraints arch))
-> ArchSegmentOff arch
-> BlockStartConstraints arch
-> FrontierMap arch
-> FrontierMap arch
addNextConstraints MemSegmentOff (ArchAddrWidth arch)
-> Maybe (BlockStartConstraints arch)
lastMap MemSegmentOff (ArchAddrWidth arch)
addr BlockStartConstraints arch
nextCns FrontierMap arch
frontierMap =
  let modifyFrontier :: Maybe (BlockStartConstraints arch)
                     -> Maybe (BlockStartConstraints arch)
      modifyFrontier :: Maybe (BlockStartConstraints arch)
-> Maybe (BlockStartConstraints arch)
modifyFrontier (Just BlockStartConstraints arch
prevCns) =
        BlockStartConstraints arch -> Maybe (BlockStartConstraints arch)
forall a. a -> Maybe a
Just (BlockStartConstraints arch
-> BlockStartConstraints arch -> BlockStartConstraints arch
forall arch.
(MemWidth (ArchAddrWidth arch), OrdF (ArchReg arch)) =>
BlockStartConstraints arch
-> BlockStartConstraints arch -> BlockStartConstraints arch
unionBlockStartConstraints BlockStartConstraints arch
nextCns BlockStartConstraints arch
prevCns)
      modifyFrontier Maybe (BlockStartConstraints arch)
Nothing =
        case MemSegmentOff (ArchAddrWidth arch)
-> Maybe (BlockStartConstraints arch)
lastMap MemSegmentOff (ArchAddrWidth arch)
addr of
          Maybe (BlockStartConstraints arch)
Nothing -> BlockStartConstraints arch -> Maybe (BlockStartConstraints arch)
forall a. a -> Maybe a
Just BlockStartConstraints arch
nextCns
          Just BlockStartConstraints arch
prevCns -> (forall s. Changed s (BlockStartConstraints arch))
-> Maybe (BlockStartConstraints arch)
forall a. (forall s. Changed s a) -> Maybe a
runChanged (BlockStartConstraints arch
-> BlockStartConstraints arch
-> Changed s (BlockStartConstraints arch)
forall s arch.
(MemWidth (ArchAddrWidth arch), OrdF (ArchReg arch)) =>
BlockStartConstraints arch
-> BlockStartConstraints arch
-> Changed s (BlockStartConstraints arch)
joinBlockStartConstraints BlockStartConstraints arch
prevCns BlockStartConstraints arch
nextCns)
   in (Maybe (BlockStartConstraints arch)
 -> Maybe (BlockStartConstraints arch))
-> MemSegmentOff (ArchAddrWidth arch)
-> FrontierMap arch
-> FrontierMap arch
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter Maybe (BlockStartConstraints arch)
-> Maybe (BlockStartConstraints arch)
modifyFrontier MemSegmentOff (ArchAddrWidth arch)
addr FrontierMap arch
frontierMap

-- | Get post value map an dnext constraints for an intra-procedural jump to target.
intraJumpConstraints :: forall arch ids
                     .  OrdF (ArchReg arch)
                     => StartInferContext arch
                     -> InferState arch ids
                     -> RegState (ArchReg arch) (Value arch ids)
                     -- ^ Values assigned to registers at end of blocks.
                     --
                     -- Unassigned registers are considered to be assigned
                     -- arbitrary values.  This is used for modeling calls
                     -- where only some registers are preserved.
                     -> (PostValueMap arch ids, BlockStartConstraints arch)
intraJumpConstraints :: forall arch ids.
OrdF (ArchReg arch) =>
StartInferContext arch
-> InferState arch ids
-> RegState (ArchReg arch) (Value arch ids)
-> (PostValueMap arch ids, BlockStartConstraints arch)
intraJumpConstraints StartInferContext arch
ctx InferState arch ids
s RegState (ArchReg arch) (Value arch ids)
regs = InferNextM
  arch ids (PostValueMap arch ids, BlockStartConstraints arch)
-> (PostValueMap arch ids, BlockStartConstraints arch)
forall arch ids a. InferNextM arch ids a -> a
runInferNextM (InferNextM
   arch ids (PostValueMap arch ids, BlockStartConstraints arch)
 -> (PostValueMap arch ids, BlockStartConstraints arch))
-> InferNextM
     arch ids (PostValueMap arch ids, BlockStartConstraints arch)
-> (PostValueMap arch ids, BlockStartConstraints arch)
forall a b. (a -> b) -> a -> b
$ do
  let intraRegFn :: ArchReg arch tp
                 -> Value arch ids tp
                 -> InferNextM arch ids (Maybe (InitInferValue arch tp))
      intraRegFn :: forall (tp :: Type).
ArchReg arch tp
-> Value arch ids tp
-> InferNextM arch ids (Maybe (InitInferValue arch tp))
intraRegFn ArchReg arch tp
r Value arch ids tp
v = BoundLoc (ArchReg arch) tp
-> BlockInferValue arch ids tp
-> InferNextM arch ids (Maybe (InitInferValue arch tp))
forall arch (tp :: Type) ids.
OrdF (ArchReg arch) =>
BoundLoc (ArchReg arch) tp
-> BlockInferValue arch ids tp
-> InferNextM arch ids (Maybe (InitInferValue arch tp))
memoNextDomain (ArchReg arch tp -> BoundLoc (ArchReg arch) tp
forall (r :: Type -> Type) (tp :: Type). r tp -> BoundLoc r tp
RegLoc ArchReg arch tp
r) (StartInferContext arch
-> MapF (AssignId ids) (BlockInferValue arch ids)
-> Value arch ids tp
-> BlockInferValue arch ids tp
forall arch ids (tp :: Type).
OrdF (ArchReg arch) =>
StartInferContext arch
-> MapF (AssignId ids) (BlockInferValue arch ids)
-> Value arch ids tp
-> BlockInferValue arch ids tp
valueToStartExpr StartInferContext arch
ctx (InferState arch ids
-> MapF (AssignId ids) (BlockInferValue arch ids)
forall arch ids.
InferState arch ids
-> MapF (AssignId ids) (BlockInferValue arch ids)
sisAssignMap InferState arch ids
s) Value arch ids tp
v)
  MapF (ArchReg arch) (InitInferValue arch)
regs' <- (forall (tp :: Type).
 ArchReg arch tp
 -> Value arch ids tp
 -> InferNextM arch ids (Maybe (InitInferValue arch tp)))
-> MapF (ArchReg arch) (Value arch ids)
-> StateT
     (InferNextState arch ids)
     Identity
     (MapF (ArchReg arch) (InitInferValue arch))
forall {v} (f :: Type -> Type) (k :: v -> Type) (a :: v -> Type)
       (b :: v -> Type).
Applicative f =>
(forall (tp :: v). k tp -> a tp -> f (Maybe (b tp)))
-> MapF k a -> f (MapF k b)
MapF.traverseMaybeWithKey ArchReg arch tp
-> Value arch ids tp
-> InferNextM arch ids (Maybe (InitInferValue arch tp))
forall (tp :: Type).
ArchReg arch tp
-> Value arch ids tp
-> InferNextM arch ids (Maybe (InitInferValue arch tp))
intraRegFn (RegState (ArchReg arch) (Value arch ids)
-> MapF (ArchReg arch) (Value arch ids)
forall {v} (r :: v -> Type) (f :: v -> Type).
RegState r f -> MapF r f
regStateMap RegState (ArchReg arch) (Value arch ids)
regs)

  let stackFn :: MemInt (ArchAddrWidth arch)
              -> MemRepr tp
              -> InferStackValue arch ids tp
              -> InferNextM arch ids (Maybe (InitInferValue arch tp))
      stackFn :: forall (tp :: Type).
MemInt (ArchAddrWidth arch)
-> MemRepr tp
-> InferStackValue arch ids tp
-> InferNextM arch ids (Maybe (InitInferValue arch tp))
stackFn MemInt (ArchAddrWidth arch)
o MemRepr tp
repr InferStackValue arch ids tp
sv =
        BoundLoc (ArchReg arch) tp
-> BlockInferValue arch ids tp
-> InferNextM arch ids (Maybe (InitInferValue arch tp))
forall arch (tp :: Type) ids.
OrdF (ArchReg arch) =>
BoundLoc (ArchReg arch) tp
-> BlockInferValue arch ids tp
-> InferNextM arch ids (Maybe (InitInferValue arch tp))
memoNextDomain (MemInt (ArchAddrWidth arch)
-> MemRepr tp -> BoundLoc (ArchReg arch) tp
forall (r :: Type -> Type) (tp :: Type).
MemInt (RegAddrWidth r) -> MemRepr tp -> BoundLoc r tp
StackOffLoc MemInt (ArchAddrWidth arch)
o MemRepr tp
repr) (StartInferContext arch
-> MapF (AssignId ids) (BlockInferValue arch ids)
-> InferStackValue arch ids tp
-> MemRepr tp
-> BlockInferValue arch ids tp
forall arch ids (tp :: Type).
OrdF (ArchReg arch) =>
StartInferContext arch
-> MapF (AssignId ids) (BlockInferValue arch ids)
-> InferStackValue arch ids tp
-> MemRepr tp
-> BlockInferValue arch ids tp
inferStackValueToValue StartInferContext arch
ctx (InferState arch ids
-> MapF (AssignId ids) (BlockInferValue arch ids)
forall arch ids.
InferState arch ids
-> MapF (AssignId ids) (BlockInferValue arch ids)
sisAssignMap InferState arch ids
s) InferStackValue arch ids tp
sv MemRepr tp
repr)
  MemMap (MemInt (ArchAddrWidth arch)) (InitInferValue arch)
stk <- (forall (tp :: Type).
 MemInt (ArchAddrWidth arch)
 -> MemRepr tp
 -> InferStackValue arch ids tp
 -> InferNextM arch ids (Maybe (InitInferValue arch tp)))
-> MemMap (MemInt (ArchAddrWidth arch)) (InferStackValue arch ids)
-> StateT
     (InferNextState arch ids)
     Identity
     (MemMap (MemInt (ArchAddrWidth arch)) (InitInferValue arch))
forall (m :: Type -> Type) o (a :: Type -> Type)
       (b :: Type -> Type).
Applicative m =>
(forall (tp :: Type). o -> MemRepr tp -> a tp -> m (Maybe (b tp)))
-> MemMap o a -> m (MemMap o b)
memMapTraverseMaybeWithKey MemInt (ArchAddrWidth arch)
-> MemRepr tp
-> InferStackValue arch ids tp
-> InferNextM arch ids (Maybe (InitInferValue arch tp))
forall (tp :: Type).
MemInt (ArchAddrWidth arch)
-> MemRepr tp
-> InferStackValue arch ids tp
-> InferNextM arch ids (Maybe (InitInferValue arch tp))
stackFn (InferState arch ids
-> MemMap (MemInt (ArchAddrWidth arch)) (InferStackValue arch ids)
forall arch ids.
InferState arch ids
-> MemMap (MemInt (ArchAddrWidth arch)) (InferStackValue arch ids)
sisStack InferState arch ids
s)

  PostValueMap arch ids
postValMap <- (InferNextState arch ids -> PostValueMap arch ids)
-> StateT
     (InferNextState arch ids) Identity (PostValueMap arch ids)
forall s (m :: Type -> Type) a. MonadState s m => (s -> a) -> m a
gets InferNextState arch ids -> PostValueMap arch ids
forall arch ids. InferNextState arch ids -> PostValueMap arch ids
insPVM
  let cns :: BlockStartConstraints arch
cns = LocMap (ArchReg arch) (InitInferValue arch)
-> BlockStartConstraints arch
forall arch.
LocMap (ArchReg arch) (InitInferValue arch)
-> BlockStartConstraints arch
BSC LocMap { locMapRegs :: MapF (ArchReg arch) (InitInferValue arch)
locMapRegs = MapF (ArchReg arch) (InitInferValue arch)
regs'
                       , locMapStack :: MemMap (MemInt (ArchAddrWidth arch)) (InitInferValue arch)
locMapStack = MemMap (MemInt (ArchAddrWidth arch)) (InitInferValue arch)
stk
                       }
  (PostValueMap arch ids, BlockStartConstraints arch)
-> InferNextM
     arch ids (PostValueMap arch ids, BlockStartConstraints arch)
forall a. a -> StateT (InferNextState arch ids) Identity a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (PostValueMap arch ids
postValMap, BlockStartConstraints arch
cns)

-- | Post call constraints for return address.
postCallConstraints :: forall arch ids
                    .  ArchConstraints arch
                    => CallParams (ArchReg arch)
                       -- ^ Architecture-specific call parameters
                    -> StartInferContext arch
                       -- ^ Context for block invariants inference.
                    -> InferState arch ids
                       -- ^ State for start inference
                    -> Int
                       -- ^ Index of term statement
                    -> RegState (ArchReg arch) (Value arch ids)
                       -- ^ Registers at time of call.
                    -> Either (RegisterUseError arch)
                              (PostValueMap arch ids, BlockStartConstraints arch)
postCallConstraints :: forall arch ids.
ArchConstraints arch =>
CallParams (ArchReg arch)
-> StartInferContext arch
-> InferState arch ids
-> Int
-> RegState (ArchReg arch) (Value arch ids)
-> Either
     (RegisterUseError arch)
     (PostValueMap arch ids, BlockStartConstraints arch)
postCallConstraints CallParams (ArchReg arch)
params StartInferContext arch
ctx InferState arch ids
s Int
tidx RegState (ArchReg arch) (Value arch ids)
regs =
  InferNextM
  arch
  ids
  (Either
     (RegisterUseError arch)
     (PostValueMap arch ids, BlockStartConstraints arch))
-> Either
     (RegisterUseError arch)
     (PostValueMap arch ids, BlockStartConstraints arch)
forall arch ids a. InferNextM arch ids a -> a
runInferNextM (InferNextM
   arch
   ids
   (Either
      (RegisterUseError arch)
      (PostValueMap arch ids, BlockStartConstraints arch))
 -> Either
      (RegisterUseError arch)
      (PostValueMap arch ids, BlockStartConstraints arch))
-> InferNextM
     arch
     ids
     (Either
        (RegisterUseError arch)
        (PostValueMap arch ids, BlockStartConstraints arch))
-> Either
     (RegisterUseError arch)
     (PostValueMap arch ids, BlockStartConstraints arch)
forall a b. (a -> b) -> a -> b
$ do
    case StartInferContext arch
-> MapF (AssignId ids) (BlockInferValue arch ids)
-> Value arch ids (BVType (RegAddrWidth (ArchReg arch)))
-> BlockInferValue arch ids (BVType (RegAddrWidth (ArchReg arch)))
forall arch ids (tp :: Type).
OrdF (ArchReg arch) =>
StartInferContext arch
-> MapF (AssignId ids) (BlockInferValue arch ids)
-> Value arch ids tp
-> BlockInferValue arch ids tp
valueToStartExpr StartInferContext arch
ctx (InferState arch ids
-> MapF (AssignId ids) (BlockInferValue arch ids)
forall arch ids.
InferState arch ids
-> MapF (AssignId ids) (BlockInferValue arch ids)
sisAssignMap InferState arch ids
s) (RegState (ArchReg arch) (Value arch ids)
regsRegState (ArchReg arch) (Value arch ids)
-> Getting
     (Value arch ids (BVType (RegAddrWidth (ArchReg arch))))
     (RegState (ArchReg arch) (Value arch ids))
     (Value arch ids (BVType (RegAddrWidth (ArchReg arch))))
-> Value arch ids (BVType (RegAddrWidth (ArchReg arch)))
forall s a. s -> Getting a s a -> a
^.ArchReg arch (BVType (RegAddrWidth (ArchReg arch)))
-> Lens'
     (RegState (ArchReg arch) (Value arch ids))
     (Value arch ids (BVType (RegAddrWidth (ArchReg arch))))
forall {k} (r :: k -> Type) (f :: k -> Type) (tp :: k).
OrdF r =>
r tp -> Lens' (RegState r f) (f tp)
boundValue ArchReg arch (BVType (RegAddrWidth (ArchReg arch)))
forall (r :: Type -> Type).
RegisterInfo r =>
r (BVType (RegAddrWidth r))
sp_reg) of
      FrameExpr MemInt (RegAddrWidth (ArchReg arch))
spOff -> do
        Bool
-> StateT (InferNextState arch ids) Identity ()
-> StateT (InferNextState arch ids) Identity ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
unless (CallParams (ArchReg arch) -> Bool
forall (r :: Type -> Type). CallParams r -> Bool
stackGrowsDown CallParams (ArchReg arch)
params) (StateT (InferNextState arch ids) Identity ()
 -> StateT (InferNextState arch ids) Identity ())
-> StateT (InferNextState arch ids) Identity ()
-> StateT (InferNextState arch ids) Identity ()
forall a b. (a -> b) -> a -> b
$
          String -> StateT (InferNextState arch ids) Identity ()
forall a. HasCallStack => String -> a
error String
"Do not yet support architectures where stack grows up."
        Bool
-> StateT (InferNextState arch ids) Identity ()
-> StateT (InferNextState arch ids) Identity ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (CallParams (ArchReg arch) -> Integer
forall (r :: Type -> Type). CallParams r -> Integer
postCallStackDelta CallParams (ArchReg arch)
params Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0) (StateT (InferNextState arch ids) Identity ()
 -> StateT (InferNextState arch ids) Identity ())
-> StateT (InferNextState arch ids) Identity ()
-> StateT (InferNextState arch ids) Identity ()
forall a b. (a -> b) -> a -> b
$
          String -> StateT (InferNextState arch ids) Identity ()
forall a. HasCallStack => String -> a
error String
"Unexpected post call stack delta."
        -- Upper bound is stack offset before call.
        let h :: Integer
h = MemInt (RegAddrWidth (ArchReg arch)) -> Integer
forall a. Integral a => a -> Integer
toInteger MemInt (RegAddrWidth (ArchReg arch))
spOff
        -- Lower bound is stack bound after call.
        let l :: Integer
l = Integer
h Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- CallParams (ArchReg arch) -> Integer
forall (r :: Type -> Type). CallParams r -> Integer
postCallStackDelta CallParams (ArchReg arch)
params
        -- Function to update register state.
        let intraRegFn :: ArchReg arch tp
                       -> Value arch ids tp
                       -> InferNextM arch ids (Maybe (InitInferValue arch tp))
            intraRegFn :: forall (tp :: Type).
ArchReg arch tp
-> Value arch ids tp
-> InferNextM arch ids (Maybe (InitInferValue arch tp))
intraRegFn ArchReg arch tp
r Value arch ids tp
v
              | Just tp :~: BVType (RegAddrWidth (ArchReg arch))
Refl <- ArchReg arch tp
-> ArchReg arch (BVType (RegAddrWidth (ArchReg arch)))
-> Maybe (tp :~: BVType (RegAddrWidth (ArchReg arch)))
forall {k} (f :: k -> Type) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
forall (a :: Type) (b :: Type).
ArchReg arch a -> ArchReg arch b -> Maybe (a :~: b)
testEquality ArchReg arch tp
r ArchReg arch (BVType (RegAddrWidth (ArchReg arch)))
forall (r :: Type -> Type).
RegisterInfo r =>
r (BVType (RegAddrWidth r))
sp_reg = do
                  let spOff' :: MemInt (RegAddrWidth (ArchReg arch))
spOff' = MemInt (RegAddrWidth (ArchReg arch))
spOff MemInt (RegAddrWidth (ArchReg arch))
-> MemInt (RegAddrWidth (ArchReg arch))
-> MemInt (RegAddrWidth (ArchReg arch))
forall a. Num a => a -> a -> a
+ Integer -> MemInt (RegAddrWidth (ArchReg arch))
forall a. Num a => Integer -> a
fromInteger (CallParams (ArchReg arch) -> Integer
forall (r :: Type -> Type). CallParams r -> Integer
postCallStackDelta CallParams (ArchReg arch)
params)
                  Maybe (InitInferValue arch tp)
-> InferNextM arch ids (Maybe (InitInferValue arch tp))
forall a. a -> StateT (InferNextState arch ids) Identity a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (InitInferValue arch tp -> Maybe (InitInferValue arch tp)
forall a. a -> Maybe a
Just (MemInt (RegAddrWidth (ArchReg arch))
-> InitInferValue arch (BVType (RegAddrWidth (ArchReg arch)))
forall arch.
MemInt (ArchAddrWidth arch)
-> InitInferValue arch (BVType (ArchAddrWidth arch))
InferredStackOffset MemInt (RegAddrWidth (ArchReg arch))
spOff'))
              | CallParams (ArchReg arch)
-> forall (tp :: Type). ArchReg arch tp -> Bool
forall (r :: Type -> Type).
CallParams r -> forall (tp :: Type). r tp -> Bool
preserveReg CallParams (ArchReg arch)
params ArchReg arch tp
r =
                BoundLoc (ArchReg arch) tp
-> BlockInferValue arch ids tp
-> InferNextM arch ids (Maybe (InitInferValue arch tp))
forall arch (tp :: Type) ids.
OrdF (ArchReg arch) =>
BoundLoc (ArchReg arch) tp
-> BlockInferValue arch ids tp
-> InferNextM arch ids (Maybe (InitInferValue arch tp))
memoNextDomain (ArchReg arch tp -> BoundLoc (ArchReg arch) tp
forall (r :: Type -> Type) (tp :: Type). r tp -> BoundLoc r tp
RegLoc ArchReg arch tp
r) (StartInferContext arch
-> MapF (AssignId ids) (BlockInferValue arch ids)
-> Value arch ids tp
-> BlockInferValue arch ids tp
forall arch ids (tp :: Type).
OrdF (ArchReg arch) =>
StartInferContext arch
-> MapF (AssignId ids) (BlockInferValue arch ids)
-> Value arch ids tp
-> BlockInferValue arch ids tp
valueToStartExpr StartInferContext arch
ctx (InferState arch ids
-> MapF (AssignId ids) (BlockInferValue arch ids)
forall arch ids.
InferState arch ids
-> MapF (AssignId ids) (BlockInferValue arch ids)
sisAssignMap InferState arch ids
s) Value arch ids tp
v)
              | Bool
otherwise =
                Maybe (InitInferValue arch tp)
-> InferNextM arch ids (Maybe (InitInferValue arch tp))
forall a. a -> StateT (InferNextState arch ids) Identity a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Maybe (InitInferValue arch tp)
forall a. Maybe a
Nothing
        MapF (ArchReg arch) (InitInferValue arch)
regs' <- (forall (tp :: Type).
 ArchReg arch tp
 -> Value arch ids tp
 -> InferNextM arch ids (Maybe (InitInferValue arch tp)))
-> MapF (ArchReg arch) (Value arch ids)
-> StateT
     (InferNextState arch ids)
     Identity
     (MapF (ArchReg arch) (InitInferValue arch))
forall {v} (f :: Type -> Type) (k :: v -> Type) (a :: v -> Type)
       (b :: v -> Type).
Applicative f =>
(forall (tp :: v). k tp -> a tp -> f (Maybe (b tp)))
-> MapF k a -> f (MapF k b)
MapF.traverseMaybeWithKey ArchReg arch tp
-> Value arch ids tp
-> InferNextM arch ids (Maybe (InitInferValue arch tp))
forall (tp :: Type).
ArchReg arch tp
-> Value arch ids tp
-> InferNextM arch ids (Maybe (InitInferValue arch tp))
intraRegFn (RegState (ArchReg arch) (Value arch ids)
-> MapF (ArchReg arch) (Value arch ids)
forall {v} (r :: v -> Type) (f :: v -> Type).
RegState r f -> MapF r f
regStateMap RegState (ArchReg arch) (Value arch ids)
regs)

        let stackFn :: MemInt (ArchAddrWidth arch)
                    -> MemRepr tp
                    -> InferStackValue arch ids tp
                    -> InferNextM arch ids (Maybe (InitInferValue arch tp))
            stackFn :: forall (tp :: Type).
MemInt (RegAddrWidth (ArchReg arch))
-> MemRepr tp
-> InferStackValue arch ids tp
-> InferNextM arch ids (Maybe (InitInferValue arch tp))
stackFn MemInt (RegAddrWidth (ArchReg arch))
o MemRepr tp
repr InferStackValue arch ids tp
sv
              -- Drop the return address pointer
              | Integer
l Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= MemInt (RegAddrWidth (ArchReg arch)) -> Integer
forall a. Integral a => a -> Integer
toInteger MemInt (RegAddrWidth (ArchReg arch))
o, MemInt (RegAddrWidth (ArchReg arch)) -> Integer
forall a. Integral a => a -> Integer
toInteger MemInt (RegAddrWidth (ArchReg arch))
o Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
h =
                  Maybe (InitInferValue arch tp)
-> StateT
     (InferNextState arch ids) Identity (Maybe (InitInferValue arch tp))
forall a. a -> StateT (InferNextState arch ids) Identity a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Maybe (InitInferValue arch tp)
forall a. Maybe a
Nothing
              | Bool
otherwise =
                -- Otherwise preserve the value.
                  BoundLoc (ArchReg arch) tp
-> BlockInferValue arch ids tp
-> StateT
     (InferNextState arch ids) Identity (Maybe (InitInferValue arch tp))
forall arch (tp :: Type) ids.
OrdF (ArchReg arch) =>
BoundLoc (ArchReg arch) tp
-> BlockInferValue arch ids tp
-> InferNextM arch ids (Maybe (InitInferValue arch tp))
memoNextDomain (MemInt (RegAddrWidth (ArchReg arch))
-> MemRepr tp -> BoundLoc (ArchReg arch) tp
forall (r :: Type -> Type) (tp :: Type).
MemInt (RegAddrWidth r) -> MemRepr tp -> BoundLoc r tp
StackOffLoc MemInt (RegAddrWidth (ArchReg arch))
o MemRepr tp
repr) (StartInferContext arch
-> MapF (AssignId ids) (BlockInferValue arch ids)
-> InferStackValue arch ids tp
-> MemRepr tp
-> BlockInferValue arch ids tp
forall arch ids (tp :: Type).
OrdF (ArchReg arch) =>
StartInferContext arch
-> MapF (AssignId ids) (BlockInferValue arch ids)
-> InferStackValue arch ids tp
-> MemRepr tp
-> BlockInferValue arch ids tp
inferStackValueToValue StartInferContext arch
ctx (InferState arch ids
-> MapF (AssignId ids) (BlockInferValue arch ids)
forall arch ids.
InferState arch ids
-> MapF (AssignId ids) (BlockInferValue arch ids)
sisAssignMap InferState arch ids
s) InferStackValue arch ids tp
sv MemRepr tp
repr)

        MemMap (MemInt (RegAddrWidth (ArchReg arch))) (InitInferValue arch)
stk <- (forall (tp :: Type).
 MemInt (RegAddrWidth (ArchReg arch))
 -> MemRepr tp
 -> InferStackValue arch ids tp
 -> InferNextM arch ids (Maybe (InitInferValue arch tp)))
-> MemMap
     (MemInt (RegAddrWidth (ArchReg arch))) (InferStackValue arch ids)
-> StateT
     (InferNextState arch ids)
     Identity
     (MemMap
        (MemInt (RegAddrWidth (ArchReg arch))) (InitInferValue arch))
forall (m :: Type -> Type) o (a :: Type -> Type)
       (b :: Type -> Type).
Applicative m =>
(forall (tp :: Type). o -> MemRepr tp -> a tp -> m (Maybe (b tp)))
-> MemMap o a -> m (MemMap o b)
memMapTraverseMaybeWithKey MemInt (RegAddrWidth (ArchReg arch))
-> MemRepr tp
-> InferStackValue arch ids tp
-> InferNextM arch ids (Maybe (InitInferValue arch tp))
forall (tp :: Type).
MemInt (RegAddrWidth (ArchReg arch))
-> MemRepr tp
-> InferStackValue arch ids tp
-> InferNextM arch ids (Maybe (InitInferValue arch tp))
stackFn (InferState arch ids
-> MemMap
     (MemInt (RegAddrWidth (ArchReg arch))) (InferStackValue arch ids)
forall arch ids.
InferState arch ids
-> MemMap (MemInt (ArchAddrWidth arch)) (InferStackValue arch ids)
sisStack InferState arch ids
s)

        PostValueMap arch ids
postValMap <- (InferNextState arch ids -> PostValueMap arch ids)
-> StateT
     (InferNextState arch ids) Identity (PostValueMap arch ids)
forall s (m :: Type -> Type) a. MonadState s m => (s -> a) -> m a
gets InferNextState arch ids -> PostValueMap arch ids
forall arch ids. InferNextState arch ids -> PostValueMap arch ids
insPVM
        let cns :: BlockStartConstraints arch
cns = LocMap (ArchReg arch) (InitInferValue arch)
-> BlockStartConstraints arch
forall arch.
LocMap (ArchReg arch) (InitInferValue arch)
-> BlockStartConstraints arch
BSC LocMap { locMapRegs :: MapF (ArchReg arch) (InitInferValue arch)
locMapRegs = MapF (ArchReg arch) (InitInferValue arch)
regs'
                             , locMapStack :: MemMap (MemInt (RegAddrWidth (ArchReg arch))) (InitInferValue arch)
locMapStack = MemMap (MemInt (RegAddrWidth (ArchReg arch))) (InitInferValue arch)
stk
                             }
        Either
  (RegisterUseError arch)
  (PostValueMap arch ids, BlockStartConstraints arch)
-> InferNextM
     arch
     ids
     (Either
        (RegisterUseError arch)
        (PostValueMap arch ids, BlockStartConstraints arch))
forall a. a -> StateT (InferNextState arch ids) Identity a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Either
   (RegisterUseError arch)
   (PostValueMap arch ids, BlockStartConstraints arch)
 -> InferNextM
      arch
      ids
      (Either
         (RegisterUseError arch)
         (PostValueMap arch ids, BlockStartConstraints arch)))
-> Either
     (RegisterUseError arch)
     (PostValueMap arch ids, BlockStartConstraints arch)
-> InferNextM
     arch
     ids
     (Either
        (RegisterUseError arch)
        (PostValueMap arch ids, BlockStartConstraints arch))
forall a b. (a -> b) -> a -> b
$ (PostValueMap arch ids, BlockStartConstraints arch)
-> Either
     (RegisterUseError arch)
     (PostValueMap arch ids, BlockStartConstraints arch)
forall a b. b -> Either a b
Right (PostValueMap arch ids
postValMap, BlockStartConstraints arch
cns)
      BlockInferValue arch ids (BVType (RegAddrWidth (ArchReg arch)))
_ -> Either
  (RegisterUseError arch)
  (PostValueMap arch ids, BlockStartConstraints arch)
-> InferNextM
     arch
     ids
     (Either
        (RegisterUseError arch)
        (PostValueMap arch ids, BlockStartConstraints arch))
forall a. a -> StateT (InferNextState arch ids) Identity a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Either
   (RegisterUseError arch)
   (PostValueMap arch ids, BlockStartConstraints arch)
 -> InferNextM
      arch
      ids
      (Either
         (RegisterUseError arch)
         (PostValueMap arch ids, BlockStartConstraints arch)))
-> Either
     (RegisterUseError arch)
     (PostValueMap arch ids, BlockStartConstraints arch)
-> InferNextM
     arch
     ids
     (Either
        (RegisterUseError arch)
        (PostValueMap arch ids, BlockStartConstraints arch))
forall a b. (a -> b) -> a -> b
$ RegisterUseError arch
-> Either
     (RegisterUseError arch)
     (PostValueMap arch ids, BlockStartConstraints arch)
forall a b. a -> Either a b
Left (RegisterUseError arch
 -> Either
      (RegisterUseError arch)
      (PostValueMap arch ids, BlockStartConstraints arch))
-> RegisterUseError arch
-> Either
     (RegisterUseError arch)
     (PostValueMap arch ids, BlockStartConstraints arch)
forall a b. (a -> b) -> a -> b
$
            RegisterUseError
            { ruBlock :: ArchSegmentOff arch
ruBlock = StartInferContext arch -> ArchSegmentOff arch
forall arch. StartInferContext arch -> ArchSegmentOff arch
sicAddr StartInferContext arch
ctx,
              ruStmt :: Int
ruStmt = Int
tidx,
              ruReason :: RegisterUseErrorReason
ruReason = RegisterUseErrorTag () -> () -> RegisterUseErrorReason
forall e. RegisterUseErrorTag e -> e -> RegisterUseErrorReason
Reason RegisterUseErrorTag ()
CallStackHeightError ()
            }

-------------------------------------------------------------------------------
-- DependencySet

-- | This records what assignments and initial value locations are
-- needed to compute a value or execute code in a block with side
-- effects.
data DependencySet (r :: M.Type -> Type) ids =
  DepSet { forall (r :: Type -> Type) ids.
DependencySet r ids -> Set (Some (BoundLoc r))
dsLocSet :: !(Set (Some (BoundLoc r)))
           -- ^ Set of locations that block reads the initial
           -- value of.
         , forall (r :: Type -> Type) ids.
DependencySet r ids -> Set (Some (AssignId ids))
dsAssignSet :: !(Set (Some (AssignId ids)))
           -- ^ Set of assignments that must be executed.
         , forall (r :: Type -> Type) ids. DependencySet r ids -> Set Int
dsWriteStmtIndexSet :: !(Set StmtIndex)
           -- ^ Block start address and index of write statement that
           -- writes a value to the stack that is read later.
         }

ppSet :: (a -> Doc ann) -> Set a -> Doc ann
ppSet :: forall a ann. (a -> Doc ann) -> Set a -> Doc ann
ppSet a -> Doc ann
f Set a
s = Doc ann -> Doc ann -> Doc ann -> [Doc ann] -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann -> [Doc ann] -> Doc ann
encloseSep Doc ann
forall ann. Doc ann
lbrace Doc ann
forall ann. Doc ann
rbrace Doc ann
forall ann. Doc ann
comma (a -> Doc ann
f (a -> Doc ann) -> [a] -> [Doc ann]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Set a -> [a]
forall a. Set a -> [a]
Set.toList Set a
s)

ppSomeAssignId :: Some (AssignId ids) -> Doc ann
ppSomeAssignId :: forall ids ann. Some (AssignId ids) -> Doc ann
ppSomeAssignId (Some AssignId ids x
aid) = AssignId ids x -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow AssignId ids x
aid

ppSomeBoundLoc :: MapF.ShowF r => Some (BoundLoc r) -> Doc ann
ppSomeBoundLoc :: forall (r :: Type -> Type) ann.
ShowF r =>
Some (BoundLoc r) -> Doc ann
ppSomeBoundLoc (Some BoundLoc r x
loc) = BoundLoc r x -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. BoundLoc r x -> Doc ann
pretty BoundLoc r x
loc

instance MapF.ShowF r => Pretty (DependencySet r ids) where
  pretty :: forall ann. DependencySet r ids -> Doc ann
pretty DependencySet r ids
ds =
    [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vcat [ Doc ann
"Assignments:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> (Some (AssignId ids) -> Doc ann)
-> Set (Some (AssignId ids)) -> Doc ann
forall a ann. (a -> Doc ann) -> Set a -> Doc ann
ppSet Some (AssignId ids) -> Doc ann
forall ids ann. Some (AssignId ids) -> Doc ann
ppSomeAssignId (DependencySet r ids -> Set (Some (AssignId ids))
forall (r :: Type -> Type) ids.
DependencySet r ids -> Set (Some (AssignId ids))
dsAssignSet DependencySet r ids
ds)
         , Doc ann
"Locations:  " Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> (Some (BoundLoc r) -> Doc ann)
-> Set (Some (BoundLoc r)) -> Doc ann
forall a ann. (a -> Doc ann) -> Set a -> Doc ann
ppSet Some (BoundLoc r) -> Doc ann
forall (r :: Type -> Type) ann.
ShowF r =>
Some (BoundLoc r) -> Doc ann
ppSomeBoundLoc (DependencySet r ids -> Set (Some (BoundLoc r))
forall (r :: Type -> Type) ids.
DependencySet r ids -> Set (Some (BoundLoc r))
dsLocSet DependencySet r ids
ds)
         , Doc ann
"Write Stmts:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> (Int -> Doc ann) -> Set Int -> Doc ann
forall a ann. (a -> Doc ann) -> Set a -> Doc ann
ppSet Int -> Doc ann
forall ann. Int -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (DependencySet r ids -> Set Int
forall (r :: Type -> Type) ids. DependencySet r ids -> Set Int
dsWriteStmtIndexSet DependencySet r ids
ds)
         ]

-- | Empty dependency set.
emptyDeps :: DependencySet r ids
emptyDeps :: forall (r :: Type -> Type) ids. DependencySet r ids
emptyDeps =
  DepSet { dsLocSet :: Set (Some (BoundLoc r))
dsLocSet = Set (Some (BoundLoc r))
forall a. Set a
Set.empty
         , dsAssignSet :: Set (Some (AssignId ids))
dsAssignSet = Set (Some (AssignId ids))
forall a. Set a
Set.empty
         , dsWriteStmtIndexSet :: Set Int
dsWriteStmtIndexSet = Set Int
forall a. Set a
Set.empty
         }

-- | Dependency set for a single assignment
assignSet :: AssignId ids tp -> DependencySet r ids
assignSet :: forall ids (tp :: Type) (r :: Type -> Type).
AssignId ids tp -> DependencySet r ids
assignSet AssignId ids tp
aid =
  DepSet { dsLocSet :: Set (Some (BoundLoc r))
dsLocSet = Set (Some (BoundLoc r))
forall a. Set a
Set.empty
         , dsAssignSet :: Set (Some (AssignId ids))
dsAssignSet = Some (AssignId ids) -> Set (Some (AssignId ids))
forall a. a -> Set a
Set.singleton (AssignId ids tp -> Some (AssignId ids)
forall k (f :: k -> Type) (x :: k). f x -> Some f
Some AssignId ids tp
aid)
         , dsWriteStmtIndexSet :: Set Int
dsWriteStmtIndexSet = Set Int
forall a. Set a
Set.empty
         }

-- | Create a dependency set for a single location.
locDepSet :: BoundLoc r tp -> DependencySet r ids
locDepSet :: forall (r :: Type -> Type) (tp :: Type) ids.
BoundLoc r tp -> DependencySet r ids
locDepSet BoundLoc r tp
l =
  DepSet { dsLocSet :: Set (Some (BoundLoc r))
dsLocSet = Some (BoundLoc r) -> Set (Some (BoundLoc r))
forall a. a -> Set a
Set.singleton (BoundLoc r tp -> Some (BoundLoc r)
forall k (f :: k -> Type) (x :: k). f x -> Some f
Some BoundLoc r tp
l)
         , dsAssignSet :: Set (Some (AssignId ids))
dsAssignSet = Set (Some (AssignId ids))
forall a. Set a
Set.empty
         , dsWriteStmtIndexSet :: Set Int
dsWriteStmtIndexSet = Set Int
forall a. Set a
Set.empty
         }

-- | @addWriteDep stmtIdx
addWriteDep :: StmtIndex -> DependencySet r ids -> DependencySet r ids
addWriteDep :: forall (r :: Type -> Type) ids.
Int -> DependencySet r ids -> DependencySet r ids
addWriteDep Int
idx DependencySet r ids
s = Int -> DependencySet r ids -> DependencySet r ids
forall a b. a -> b -> b
seq Int
idx (DependencySet r ids -> DependencySet r ids)
-> DependencySet r ids -> DependencySet r ids
forall a b. (a -> b) -> a -> b
$
  DependencySet r ids
s { dsWriteStmtIndexSet = Set.insert idx (dsWriteStmtIndexSet s) }

instance MapF.OrdF r => Semigroup (DependencySet r ids) where
  DependencySet r ids
x <> :: DependencySet r ids -> DependencySet r ids -> DependencySet r ids
<> DependencySet r ids
y = DepSet { dsAssignSet :: Set (Some (AssignId ids))
dsAssignSet = Set (Some (AssignId ids))
-> Set (Some (AssignId ids)) -> Set (Some (AssignId ids))
forall a. Ord a => Set a -> Set a -> Set a
Set.union (DependencySet r ids -> Set (Some (AssignId ids))
forall (r :: Type -> Type) ids.
DependencySet r ids -> Set (Some (AssignId ids))
dsAssignSet DependencySet r ids
x) (DependencySet r ids -> Set (Some (AssignId ids))
forall (r :: Type -> Type) ids.
DependencySet r ids -> Set (Some (AssignId ids))
dsAssignSet DependencySet r ids
y)
                  , dsLocSet :: Set (Some (BoundLoc r))
dsLocSet = Set (Some (BoundLoc r))
-> Set (Some (BoundLoc r)) -> Set (Some (BoundLoc r))
forall a. Ord a => Set a -> Set a -> Set a
Set.union (DependencySet r ids -> Set (Some (BoundLoc r))
forall (r :: Type -> Type) ids.
DependencySet r ids -> Set (Some (BoundLoc r))
dsLocSet DependencySet r ids
x) (DependencySet r ids -> Set (Some (BoundLoc r))
forall (r :: Type -> Type) ids.
DependencySet r ids -> Set (Some (BoundLoc r))
dsLocSet DependencySet r ids
y)
                  , dsWriteStmtIndexSet :: Set Int
dsWriteStmtIndexSet =
                      Set Int -> Set Int -> Set Int
forall a. Ord a => Set a -> Set a -> Set a
Set.union (DependencySet r ids -> Set Int
forall (r :: Type -> Type) ids. DependencySet r ids -> Set Int
dsWriteStmtIndexSet DependencySet r ids
x) (DependencySet r ids -> Set Int
forall (r :: Type -> Type) ids. DependencySet r ids -> Set Int
dsWriteStmtIndexSet DependencySet r ids
y)
                  }

instance MapF.OrdF r => Monoid (DependencySet r ids) where
  mempty :: DependencySet r ids
mempty = DependencySet r ids
forall (r :: Type -> Type) ids. DependencySet r ids
emptyDeps

------------------------------------------------------------------------
-- RegDependencyMap

-- | Map from register to the dependencies for that register.
newtype RegDependencyMap arch ids =
  RDM { forall arch ids.
RegDependencyMap arch ids
-> MapF (ArchReg arch) (Const (DependencySet (ArchReg arch) ids))
rdmMap :: MapF (ArchReg arch) (Const (DependencySet (ArchReg arch) ids)) }

emptyRegDepMap :: RegDependencyMap arch ids
emptyRegDepMap :: forall arch ids. RegDependencyMap arch ids
emptyRegDepMap = MapF (ArchReg arch) (Const (DependencySet (ArchReg arch) ids))
-> RegDependencyMap arch ids
forall arch ids.
MapF (ArchReg arch) (Const (DependencySet (ArchReg arch) ids))
-> RegDependencyMap arch ids
RDM MapF (ArchReg arch) (Const (DependencySet (ArchReg arch) ids))
forall {v} (k :: v -> Type) (a :: v -> Type). MapF k a
MapF.empty

instance OrdF (ArchReg arch) => Semigroup (RegDependencyMap arch ids) where
  RDM MapF (ArchReg arch) (Const (DependencySet (ArchReg arch) ids))
x <> :: RegDependencyMap arch ids
-> RegDependencyMap arch ids -> RegDependencyMap arch ids
<> RDM MapF (ArchReg arch) (Const (DependencySet (ArchReg arch) ids))
y = MapF (ArchReg arch) (Const (DependencySet (ArchReg arch) ids))
-> RegDependencyMap arch ids
forall arch ids.
MapF (ArchReg arch) (Const (DependencySet (ArchReg arch) ids))
-> RegDependencyMap arch ids
RDM (MapF (ArchReg arch) (Const (DependencySet (ArchReg arch) ids))
-> MapF (ArchReg arch) (Const (DependencySet (ArchReg arch) ids))
-> MapF (ArchReg arch) (Const (DependencySet (ArchReg arch) ids))
forall {v} (k :: v -> Type) (a :: v -> Type).
OrdF k =>
MapF k a -> MapF k a -> MapF k a
MapF.union MapF (ArchReg arch) (Const (DependencySet (ArchReg arch) ids))
x MapF (ArchReg arch) (Const (DependencySet (ArchReg arch) ids))
y)

instance OrdF (ArchReg arch) => Monoid (RegDependencyMap arch ids) where
  mempty :: RegDependencyMap arch ids
mempty = RegDependencyMap arch ids
forall arch ids. RegDependencyMap arch ids
emptyRegDepMap

-- | Set dependency for register
setRegDep :: OrdF (ArchReg arch)
          => ArchReg arch tp
          -> DependencySet (ArchReg arch) ids
          -> RegDependencyMap arch ids
          -> RegDependencyMap arch ids
setRegDep :: forall arch (tp :: Type) ids.
OrdF (ArchReg arch) =>
ArchReg arch tp
-> DependencySet (ArchReg arch) ids
-> RegDependencyMap arch ids
-> RegDependencyMap arch ids
setRegDep ArchReg arch tp
r DependencySet (ArchReg arch) ids
d (RDM MapF (ArchReg arch) (Const (DependencySet (ArchReg arch) ids))
m) = MapF (ArchReg arch) (Const (DependencySet (ArchReg arch) ids))
-> RegDependencyMap arch ids
forall arch ids.
MapF (ArchReg arch) (Const (DependencySet (ArchReg arch) ids))
-> RegDependencyMap arch ids
RDM (ArchReg arch tp
-> Const (DependencySet (ArchReg arch) ids) tp
-> MapF (ArchReg arch) (Const (DependencySet (ArchReg arch) ids))
-> MapF (ArchReg arch) (Const (DependencySet (ArchReg arch) ids))
forall {v} (k :: v -> Type) (tp :: v) (a :: v -> Type).
OrdF k =>
k tp -> a tp -> MapF k a -> MapF k a
MapF.insert ArchReg arch tp
r (DependencySet (ArchReg arch) ids
-> Const (DependencySet (ArchReg arch) ids) tp
forall {k} a (b :: k). a -> Const a b
Const DependencySet (ArchReg arch) ids
d) MapF (ArchReg arch) (Const (DependencySet (ArchReg arch) ids))
m)

-- | Create dependencies from map
regDepsFromMap :: (forall tp . a tp -> DependencySet (ArchReg arch) ids)
               -> MapF (ArchReg arch) a
               -> RegDependencyMap arch ids
regDepsFromMap :: forall (a :: Type -> Type) arch ids.
(forall (tp :: Type). a tp -> DependencySet (ArchReg arch) ids)
-> MapF (ArchReg arch) a -> RegDependencyMap arch ids
regDepsFromMap forall (tp :: Type). a tp -> DependencySet (ArchReg arch) ids
f MapF (ArchReg arch) a
m = MapF (ArchReg arch) (Const (DependencySet (ArchReg arch) ids))
-> RegDependencyMap arch ids
forall arch ids.
MapF (ArchReg arch) (Const (DependencySet (ArchReg arch) ids))
-> RegDependencyMap arch ids
RDM ((forall (x :: Type).
 a x -> Const (DependencySet (ArchReg arch) ids) x)
-> MapF (ArchReg arch) a
-> MapF (ArchReg arch) (Const (DependencySet (ArchReg arch) ids))
forall {k} (m :: (k -> Type) -> Type) (f :: k -> Type)
       (g :: k -> Type).
FunctorF m =>
(forall (x :: k). f x -> g x) -> m f -> m g
forall (f :: Type -> Type) (g :: Type -> Type).
(forall (x :: Type). f x -> g x)
-> MapF (ArchReg arch) f -> MapF (ArchReg arch) g
fmapF (DependencySet (ArchReg arch) ids
-> Const (DependencySet (ArchReg arch) ids) x
forall {k} a (b :: k). a -> Const a b
Const (DependencySet (ArchReg arch) ids
 -> Const (DependencySet (ArchReg arch) ids) x)
-> (a x -> DependencySet (ArchReg arch) ids)
-> a x
-> Const (DependencySet (ArchReg arch) ids) x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a x -> DependencySet (ArchReg arch) ids
forall (tp :: Type). a tp -> DependencySet (ArchReg arch) ids
f) MapF (ArchReg arch) a
m)

------------------------------------------------------------------------
-- BlockUsageSummary

-- | This contains information about a specific block needed to infer
-- which locations and assignments are needed to execute the block
-- along with information about the demands to compute the value of
-- particular locations after the block executes.
data BlockUsageSummary (arch :: Type) ids = BUS
  { forall arch ids.
BlockUsageSummary arch ids -> BlockStartConstraints arch
blockUsageStartConstraints :: !(BlockStartConstraints arch)
    -- | Offset of start of last instruction processed relative to start of block.
  , forall arch ids. BlockUsageSummary arch ids -> ArchAddrWord arch
blockCurOff :: !(ArchAddrWord arch)
    -- | Inferred state computed at beginning
  , forall arch ids. BlockUsageSummary arch ids -> InferState arch ids
blockInferState :: !(InferState arch ids)
    -- | Dependencies needed to execute statements with side effects.
  ,forall arch ids.
BlockUsageSummary arch ids -> DependencySet (ArchReg arch) ids
_blockExecDemands :: !(DependencySet (ArchReg arch) ids)
    -- | Map registers to the dependencies of the values they store.
    --
    -- Defined in block terminator.
  , forall arch ids.
BlockUsageSummary arch ids -> RegDependencyMap arch ids
blockRegDependencies :: !(RegDependencyMap arch ids)
    -- | Map indexes of writes and cond write instructions to their dependency set.
  , forall arch ids.
BlockUsageSummary arch ids
-> Map Int (DependencySet (ArchReg arch) ids)
blockWriteDependencies :: !(Map StmtIndex (DependencySet (ArchReg arch) ids))
    -- | Maps assignments to their dependencies.
  , forall arch ids.
BlockUsageSummary arch ids
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
assignDeps :: !(Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids))
    -- | Information about next memory reads.
  , forall arch ids.
BlockUsageSummary arch ids -> [(Int, MemAccessInfo arch ids)]
pendingMemAccesses :: ![(StmtIndex, MemAccessInfo arch ids)]
    -- | If this block ends with a call, this has the type of the function called.
    -- Otherwise, the value should be @Nothing@.
  , forall arch ids.
BlockUsageSummary arch ids -> Maybe (ArchFunType arch)
blockCallFunType :: !(Maybe (ArchFunType arch))
  }

initBlockUsageSummary :: BlockStartConstraints arch
                      -> InferState arch ids
                      -> BlockUsageSummary arch ids
initBlockUsageSummary :: forall arch ids.
BlockStartConstraints arch
-> InferState arch ids -> BlockUsageSummary arch ids
initBlockUsageSummary BlockStartConstraints arch
cns InferState arch ids
s =
  let a :: [(Int, MemAccessInfo arch ids)]
a = [(Int, MemAccessInfo arch ids)] -> [(Int, MemAccessInfo arch ids)]
forall a. [a] -> [a]
reverse (InferState arch ids -> [(Int, MemAccessInfo arch ids)]
forall arch ids.
InferState arch ids -> [(Int, MemAccessInfo arch ids)]
sisMemAccessStack InferState arch ids
s)
   in BUS { blockUsageStartConstraints :: BlockStartConstraints arch
blockUsageStartConstraints = BlockStartConstraints arch
cns
          , blockCurOff :: ArchAddrWord arch
blockCurOff            = ArchAddrWord arch
forall (w :: Nat). MemWord w
zeroMemWord
          , blockInferState :: InferState arch ids
blockInferState        = InferState arch ids
s
          , _blockExecDemands :: DependencySet (ArchReg arch) ids
_blockExecDemands      = DependencySet (ArchReg arch) ids
forall (r :: Type -> Type) ids. DependencySet r ids
emptyDeps
          , blockRegDependencies :: RegDependencyMap arch ids
blockRegDependencies   = RegDependencyMap arch ids
forall arch ids. RegDependencyMap arch ids
emptyRegDepMap
          , blockWriteDependencies :: Map Int (DependencySet (ArchReg arch) ids)
blockWriteDependencies = Map Int (DependencySet (ArchReg arch) ids)
forall k a. Map k a
Map.empty
          , assignDeps :: Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
assignDeps             = Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
forall k a. Map k a
Map.empty
          , pendingMemAccesses :: [(Int, MemAccessInfo arch ids)]
pendingMemAccesses     = [(Int, MemAccessInfo arch ids)]
a
          , blockCallFunType :: Maybe (ArchFunType arch)
blockCallFunType = Maybe (ArchFunType arch)
forall a. Maybe a
Nothing
          }

-- | Dependencies needed to execute statements with side effects.
blockExecDemands :: Lens' (BlockUsageSummary arch ids) (DependencySet (ArchReg arch) ids)
blockExecDemands :: forall arch ids (f :: Type -> Type).
Functor f =>
(DependencySet (ArchReg arch) ids
 -> f (DependencySet (ArchReg arch) ids))
-> BlockUsageSummary arch ids -> f (BlockUsageSummary arch ids)
blockExecDemands = (BlockUsageSummary arch ids -> DependencySet (ArchReg arch) ids)
-> (BlockUsageSummary arch ids
    -> DependencySet (ArchReg arch) ids -> BlockUsageSummary arch ids)
-> Lens
     (BlockUsageSummary arch ids)
     (BlockUsageSummary arch ids)
     (DependencySet (ArchReg arch) ids)
     (DependencySet (ArchReg arch) ids)
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens BlockUsageSummary arch ids -> DependencySet (ArchReg arch) ids
forall arch ids.
BlockUsageSummary arch ids -> DependencySet (ArchReg arch) ids
_blockExecDemands (\BlockUsageSummary arch ids
s DependencySet (ArchReg arch) ids
v -> BlockUsageSummary arch ids
s { _blockExecDemands = v })

-- | Maps registers to the dependencies needed to compute that
-- register value.
blockRegDependenciesLens :: Lens' (BlockUsageSummary arch ids) (RegDependencyMap arch ids)
blockRegDependenciesLens :: forall arch ids (f :: Type -> Type).
Functor f =>
(RegDependencyMap arch ids -> f (RegDependencyMap arch ids))
-> BlockUsageSummary arch ids -> f (BlockUsageSummary arch ids)
blockRegDependenciesLens = (BlockUsageSummary arch ids -> RegDependencyMap arch ids)
-> (BlockUsageSummary arch ids
    -> RegDependencyMap arch ids -> BlockUsageSummary arch ids)
-> Lens
     (BlockUsageSummary arch ids)
     (BlockUsageSummary arch ids)
     (RegDependencyMap arch ids)
     (RegDependencyMap arch ids)
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens BlockUsageSummary arch ids -> RegDependencyMap arch ids
forall arch ids.
BlockUsageSummary arch ids -> RegDependencyMap arch ids
blockRegDependencies (\BlockUsageSummary arch ids
s RegDependencyMap arch ids
v -> BlockUsageSummary arch ids
s { blockRegDependencies = v })

-- | Maps stack offsets to the dependencies needed to compute the
-- value stored at that offset.
blockWriteDependencyLens :: Lens' (BlockUsageSummary arch ids)
                                  (Map StmtIndex (DependencySet (ArchReg arch) ids))
blockWriteDependencyLens :: forall arch ids (f :: Type -> Type).
Functor f =>
(Map Int (DependencySet (ArchReg arch) ids)
 -> f (Map Int (DependencySet (ArchReg arch) ids)))
-> BlockUsageSummary arch ids -> f (BlockUsageSummary arch ids)
blockWriteDependencyLens = (BlockUsageSummary arch ids
 -> Map Int (DependencySet (ArchReg arch) ids))
-> (BlockUsageSummary arch ids
    -> Map Int (DependencySet (ArchReg arch) ids)
    -> BlockUsageSummary arch ids)
-> Lens
     (BlockUsageSummary arch ids)
     (BlockUsageSummary arch ids)
     (Map Int (DependencySet (ArchReg arch) ids))
     (Map Int (DependencySet (ArchReg arch) ids))
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens BlockUsageSummary arch ids
-> Map Int (DependencySet (ArchReg arch) ids)
forall arch ids.
BlockUsageSummary arch ids
-> Map Int (DependencySet (ArchReg arch) ids)
blockWriteDependencies (\BlockUsageSummary arch ids
s Map Int (DependencySet (ArchReg arch) ids)
v -> BlockUsageSummary arch ids
s { blockWriteDependencies = v })

assignmentCache :: Lens' (BlockUsageSummary arch ids)
                         (Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids))
assignmentCache :: forall arch ids (f :: Type -> Type).
Functor f =>
(Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
 -> f (Map
         (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)))
-> BlockUsageSummary arch ids -> f (BlockUsageSummary arch ids)
assignmentCache = (BlockUsageSummary arch ids
 -> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids))
-> (BlockUsageSummary arch ids
    -> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
    -> BlockUsageSummary arch ids)
-> Lens
     (BlockUsageSummary arch ids)
     (BlockUsageSummary arch ids)
     (Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids))
     (Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids))
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens BlockUsageSummary arch ids
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
forall arch ids.
BlockUsageSummary arch ids
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
assignDeps (\BlockUsageSummary arch ids
s Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
v -> BlockUsageSummary arch ids
s { assignDeps = v })

------------------------------------------------------------------------
-- CallRegs

-- | Identifies demand information about a particular call.
data CallRegs (arch :: Type) (ids :: Type) =
  CallRegs { forall arch ids. CallRegs arch ids -> ArchFunType arch
callRegsFnType :: !(ArchFunType arch)
           , forall arch ids. CallRegs arch ids -> [Some (Value arch ids)]
callArgValues :: [Some (Value arch ids)]
           , forall arch ids. CallRegs arch ids -> [Some (ArchReg arch)]
callReturnRegs :: [Some (ArchReg arch)]
           }

------------------------------------------------------------------------
-- RegisterUseContext

type PostTermStmtInvariants arch ids =
  StartInferContext arch
  -> InferState arch ids
  -> Int
  -> ArchTermStmt arch (Value arch ids)
  -> RegState (ArchReg arch) (Value arch ids)
  -> Either (RegisterUseError arch) (PostValueMap arch ids, BlockStartConstraints arch)

type ArchTermStmtUsageFn arch ids
  = ArchTermStmt arch (Value arch ids)
  -> RegState (ArchReg arch) (Value arch ids)
  -> BlockUsageSummary arch ids
  -> Either (RegisterUseError arch) (RegDependencyMap arch ids)

-- | Architecture specific information about the type of function
-- called by inferring call-site information.
--
-- Used to memoize analysis returned by @callDemandFn@.
type family ArchFunType (arch::Type) :: Type

data RegisterUseContext arch
  = RegisterUseContext
    { -- | Set of registers preserved by a call.
      forall arch. RegisterUseContext arch -> CallParams (ArchReg arch)
archCallParams :: !(CallParams (ArchReg arch))
      -- | Given a terminal statement and list of registers it returns
      -- Map containing values afterwards.
    , forall arch.
RegisterUseContext arch
-> forall ids. PostTermStmtInvariants arch ids
archPostTermStmtInvariants :: !(forall ids . PostTermStmtInvariants arch ids)
      -- | Registers that are saved by calls (excludes rsp)
    , forall arch. RegisterUseContext arch -> [Some (ArchReg arch)]
calleeSavedRegisters :: ![Some (ArchReg arch)]
      -- | List of registers that callers may freely change.
    , forall arch. RegisterUseContext arch -> [Some (ArchReg arch)]
callScratchRegisters :: ![Some (ArchReg arch)]
      -- ^ The list of registers that are preserved by a function
      -- call.
      --
      -- Note. Should not include stack pointer as thay is
      -- handled differently.
      -- | Return registers demanded by this function
    , forall arch. RegisterUseContext arch -> [Some (ArchReg arch)]
returnRegisters :: ![Some (ArchReg arch)]
      -- | Callback function for summarizing register usage of terminal
      -- statements.
    , forall arch.
RegisterUseContext arch -> forall ids. ArchTermStmtUsageFn arch ids
reguseTermFn :: !(forall ids . ArchTermStmtUsageFn arch ids)
      -- | Given the address of a call instruction and registers, this returns the
      -- values read and returned.
    , forall arch.
RegisterUseContext arch
-> forall ids.
   ArchSegmentOff arch
   -> RegState (ArchReg arch) (Value arch ids)
   -> Either RegisterUseErrorReason (CallRegs arch ids)
callDemandFn    :: !(forall ids
                          .  ArchSegmentOff arch
                          -> RegState (ArchReg arch) (Value arch ids)
                          -> Either RegisterUseErrorReason (CallRegs arch ids))
      -- | Information needed to demands of architecture-specific functions.
    , forall arch. RegisterUseContext arch -> DemandContext arch
demandContext :: !(DemandContext arch)
    }

-- | Add frontier for an intra-procedural jump that preserves register
-- and stack.
visitIntraJumpTarget :: forall arch ids
                     .  (MemWidth (ArchAddrWidth arch), OrdF (ArchReg arch))
                     => (ArchSegmentOff arch -> Maybe (BlockStartConstraints arch))
                     -> StartInferContext arch
                     -> InferState arch ids
                     -> RegState (ArchReg arch) (Value arch ids)
                     -- ^ Values assigned to registers at end of blocks.
                     --
                     -- Unassigned registers are considered to be assigned
                     -- arbitrary values.  This is used for modeling calls
                     -- where only some registers are preserved.
                     -> (Map (ArchSegmentOff arch) (PostValueMap arch ids), FrontierMap arch)
                     -- ^ Frontier so far
                     -> ArchSegmentOff arch -- ^ Address to jump to
                     -> (Map (ArchSegmentOff arch) (PostValueMap arch ids), FrontierMap arch)
visitIntraJumpTarget :: forall arch ids.
(MemWidth (ArchAddrWidth arch), OrdF (ArchReg arch)) =>
(ArchSegmentOff arch -> Maybe (BlockStartConstraints arch))
-> StartInferContext arch
-> InferState arch ids
-> RegState (ArchReg arch) (Value arch ids)
-> (Map (ArchSegmentOff arch) (PostValueMap arch ids),
    FrontierMap arch)
-> ArchSegmentOff arch
-> (Map (ArchSegmentOff arch) (PostValueMap arch ids),
    FrontierMap arch)
visitIntraJumpTarget MemSegmentOff (ArchAddrWidth arch)
-> Maybe (BlockStartConstraints arch)
lastMap StartInferContext arch
ctx InferState arch ids
s RegState (ArchReg arch) (Value arch ids)
regs (Map (MemSegmentOff (ArchAddrWidth arch)) (PostValueMap arch ids)
m,FrontierMap arch
frontierMap) MemSegmentOff (ArchAddrWidth arch)
addr =
  let nextCns :: BlockStartConstraints arch
      (PostValueMap arch ids
postValMap, BlockStartConstraints arch
nextCns) = StartInferContext arch
-> InferState arch ids
-> RegState (ArchReg arch) (Value arch ids)
-> (PostValueMap arch ids, BlockStartConstraints arch)
forall arch ids.
OrdF (ArchReg arch) =>
StartInferContext arch
-> InferState arch ids
-> RegState (ArchReg arch) (Value arch ids)
-> (PostValueMap arch ids, BlockStartConstraints arch)
intraJumpConstraints StartInferContext arch
ctx InferState arch ids
s RegState (ArchReg arch) (Value arch ids)
regs
   in (MemSegmentOff (ArchAddrWidth arch)
-> PostValueMap arch ids
-> Map (MemSegmentOff (ArchAddrWidth arch)) (PostValueMap arch ids)
-> Map (MemSegmentOff (ArchAddrWidth arch)) (PostValueMap arch ids)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert MemSegmentOff (ArchAddrWidth arch)
addr PostValueMap arch ids
postValMap Map (MemSegmentOff (ArchAddrWidth arch)) (PostValueMap arch ids)
m, (MemSegmentOff (ArchAddrWidth arch)
 -> Maybe (BlockStartConstraints arch))
-> MemSegmentOff (ArchAddrWidth arch)
-> BlockStartConstraints arch
-> FrontierMap arch
-> FrontierMap arch
forall arch.
(MemWidth (ArchAddrWidth arch), OrdF (ArchReg arch)) =>
(ArchSegmentOff arch -> Maybe (BlockStartConstraints arch))
-> ArchSegmentOff arch
-> BlockStartConstraints arch
-> FrontierMap arch
-> FrontierMap arch
addNextConstraints MemSegmentOff (ArchAddrWidth arch)
-> Maybe (BlockStartConstraints arch)
lastMap MemSegmentOff (ArchAddrWidth arch)
addr BlockStartConstraints arch
nextCns FrontierMap arch
frontierMap)

-- | Analyze block to update start constraints on successors and add blocks
-- with changed constraints to frontier.
blockStartConstraints :: ArchConstraints arch
                      => RegisterUseContext arch
                      -> Map (ArchSegmentOff arch) (ParsedBlock arch ids)
                      -- ^ Map from starting addresses to blocks.
                      -> ArchSegmentOff arch
                         -- ^ Address of start of block.
                      -> BlockStartConstraints arch
                      -> Map (ArchSegmentOff arch) (StartInferInfo arch ids)
                      -- ^ Results from last explore map
                      -> FrontierMap arch
                      -- ^ Maps addresses of blocks to explore to the
                      -- starting constraints.
                      -> Except (RegisterUseError arch)
                                (Map (ArchSegmentOff arch) (StartInferInfo arch ids), FrontierMap arch)
blockStartConstraints :: forall arch ids.
ArchConstraints arch =>
RegisterUseContext arch
-> Map (ArchSegmentOff arch) (ParsedBlock arch ids)
-> ArchSegmentOff arch
-> BlockStartConstraints arch
-> Map (ArchSegmentOff arch) (StartInferInfo arch ids)
-> FrontierMap arch
-> Except
     (RegisterUseError arch)
     (Map (ArchSegmentOff arch) (StartInferInfo arch ids),
      FrontierMap arch)
blockStartConstraints RegisterUseContext arch
rctx Map
  (MemSegmentOff (RegAddrWidth (ArchReg arch)))
  (ParsedBlock arch ids)
blockMap MemSegmentOff (RegAddrWidth (ArchReg arch))
addr (BSC LocMap (ArchReg arch) (InitInferValue arch)
cns) Map
  (MemSegmentOff (RegAddrWidth (ArchReg arch)))
  (StartInferInfo arch ids)
lastMap FrontierMap arch
frontierMap = do
  let b :: ParsedBlock arch ids
b = ParsedBlock arch ids
-> MemSegmentOff (RegAddrWidth (ArchReg arch))
-> Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (ParsedBlock arch ids)
-> ParsedBlock arch ids
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault (String -> ParsedBlock arch ids
forall a. HasCallStack => String -> a
error String
"No block") MemSegmentOff (RegAddrWidth (ArchReg arch))
addr Map
  (MemSegmentOff (RegAddrWidth (ArchReg arch)))
  (ParsedBlock arch ids)
blockMap
  let ctx :: StartInferContext arch
ctx = SIC { sicAddr :: MemSegmentOff (RegAddrWidth (ArchReg arch))
sicAddr = MemSegmentOff (RegAddrWidth (ArchReg arch))
addr
                , sicRegs :: MapF (ArchReg arch) (InitInferValue arch)
sicRegs = LocMap (ArchReg arch) (InitInferValue arch)
-> MapF (ArchReg arch) (InitInferValue arch)
forall (r :: Type -> Type) (v :: Type -> Type).
LocMap r v -> MapF r v
locMapRegs LocMap (ArchReg arch) (InitInferValue arch)
cns
                }
  let s0 :: InferState arch ids
s0  = SIS { sisStack :: MemMap
  (MemInt (RegAddrWidth (ArchReg arch))) (InferStackValue arch ids)
sisStack = (forall (x :: Type).
 InitInferValue arch x -> InferStackValue arch ids x)
-> MemMap
     (MemInt (RegAddrWidth (ArchReg arch))) (InitInferValue arch)
-> MemMap
     (MemInt (RegAddrWidth (ArchReg arch))) (InferStackValue arch ids)
forall {k} (m :: (k -> Type) -> Type) (f :: k -> Type)
       (g :: k -> Type).
FunctorF m =>
(forall (x :: k). f x -> g x) -> m f -> m g
forall (f :: Type -> Type) (g :: Type -> Type).
(forall (x :: Type). f x -> g x)
-> MemMap (MemInt (RegAddrWidth (ArchReg arch))) f
-> MemMap (MemInt (RegAddrWidth (ArchReg arch))) g
fmapF InitInferValue arch x -> InferStackValue arch ids x
forall arch (tp :: Type) ids.
InitInferValue arch tp -> InferStackValue arch ids tp
forall (x :: Type).
InitInferValue arch x -> InferStackValue arch ids x
ISVInitValue (LocMap (ArchReg arch) (InitInferValue arch)
-> MemMap
     (MemInt (RegAddrWidth (ArchReg arch))) (InitInferValue arch)
forall (r :: Type -> Type) (v :: Type -> Type).
LocMap r v -> MemMap (MemInt (RegAddrWidth r)) v
locMapStack LocMap (ArchReg arch) (InitInferValue arch)
cns)
                , sisAssignMap :: MapF (AssignId ids) (BlockInferValue arch ids)
sisAssignMap = MapF (AssignId ids) (BlockInferValue arch ids)
forall {v} (k :: v -> Type) (a :: v -> Type). MapF k a
MapF.empty
                , sisAppCache :: MapF (App (BlockInferValue arch ids)) (AssignId ids)
sisAppCache  = MapF (App (BlockInferValue arch ids)) (AssignId ids)
forall {v} (k :: v -> Type) (a :: v -> Type). MapF k a
MapF.empty
                , sisCurrentInstructionOffset :: MemWord (RegAddrWidth (ArchReg arch))
sisCurrentInstructionOffset = MemWord (RegAddrWidth (ArchReg arch))
0
                , sisMemAccessStack :: [(Int, MemAccessInfo arch ids)]
sisMemAccessStack = []
                }
  -- Get statements in block
  let stmts :: [Stmt arch ids]
stmts = ParsedBlock arch ids -> [Stmt arch ids]
forall arch ids. ParsedBlock arch ids -> [Stmt arch ids]
pblockStmts ParsedBlock arch ids
b
  let stmtCount :: Int
stmtCount = [Stmt arch ids] -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [Stmt arch ids]
stmts
  -- Get state from processing all statements
  InferState arch ids
s <- StateT
  (InferState arch ids) (ExceptT (RegisterUseError arch) Identity) ()
-> InferState arch ids
-> ExceptT (RegisterUseError arch) Identity (InferState arch ids)
forall (m :: Type -> Type) s a. Monad m => StateT s m a -> s -> m s
execStateT (ReaderT
  (StartInferContext arch)
  (StateT
     (InferState arch ids) (ExceptT (RegisterUseError arch) Identity))
  ()
-> StartInferContext arch
-> StateT
     (InferState arch ids) (ExceptT (RegisterUseError arch) Identity) ()
forall r (m :: Type -> Type) a. ReaderT r m a -> r -> m a
runReaderT ((Int
 -> Stmt arch ids
 -> ReaderT
      (StartInferContext arch)
      (StateT
         (InferState arch ids) (ExceptT (RegisterUseError arch) Identity))
      ())
-> [Int]
-> [Stmt arch ids]
-> ReaderT
     (StartInferContext arch)
     (StateT
        (InferState arch ids) (ExceptT (RegisterUseError arch) Identity))
     ()
forall (m :: Type -> Type) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ Int
-> Stmt arch ids
-> ReaderT
     (StartInferContext arch)
     (StateT
        (InferState arch ids) (ExceptT (RegisterUseError arch) Identity))
     ()
forall arch ids.
(OrdF (ArchReg arch), MemWidth (ArchAddrWidth arch)) =>
Int -> Stmt arch ids -> StartInfer arch ids ()
processStmt [Int
0..] [Stmt arch ids]
stmts) StartInferContext arch
ctx) InferState arch ids
s0
  let lastFn :: MemSegmentOff (RegAddrWidth (ArchReg arch))
-> Maybe (BlockStartConstraints arch)
lastFn MemSegmentOff (RegAddrWidth (ArchReg arch))
a = if MemSegmentOff (RegAddrWidth (ArchReg arch))
a MemSegmentOff (RegAddrWidth (ArchReg arch))
-> MemSegmentOff (RegAddrWidth (ArchReg arch)) -> Bool
forall a. Eq a => a -> a -> Bool
== MemSegmentOff (RegAddrWidth (ArchReg arch))
addr then BlockStartConstraints arch -> Maybe (BlockStartConstraints arch)
forall a. a -> Maybe a
Just (LocMap (ArchReg arch) (InitInferValue arch)
-> BlockStartConstraints arch
forall arch.
LocMap (ArchReg arch) (InitInferValue arch)
-> BlockStartConstraints arch
BSC LocMap (ArchReg arch) (InitInferValue arch)
cns) else StartInferInfo arch ids -> BlockStartConstraints arch
forall arch ids.
StartInferInfo arch ids -> BlockStartConstraints arch
siiCns (StartInferInfo arch ids -> BlockStartConstraints arch)
-> Maybe (StartInferInfo arch ids)
-> Maybe (BlockStartConstraints arch)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> MemSegmentOff (RegAddrWidth (ArchReg arch))
-> Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (StartInferInfo arch ids)
-> Maybe (StartInferInfo arch ids)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup MemSegmentOff (RegAddrWidth (ArchReg arch))
a Map
  (MemSegmentOff (RegAddrWidth (ArchReg arch)))
  (StartInferInfo arch ids)
lastMap
  case ParsedBlock arch ids -> ParsedTermStmt arch ids
forall arch ids. ParsedBlock arch ids -> ParsedTermStmt arch ids
pblockTermStmt ParsedBlock arch ids
b of
    ParsedJump RegState (ArchReg arch) (Value arch ids)
regs MemSegmentOff (RegAddrWidth (ArchReg arch))
next -> do
      let (Map
  (MemSegmentOff (RegAddrWidth (ArchReg arch)))
  (PostValueMap arch ids)
pvm,FrontierMap arch
frontierMap') = (MemSegmentOff (RegAddrWidth (ArchReg arch))
 -> Maybe (BlockStartConstraints arch))
-> StartInferContext arch
-> InferState arch ids
-> RegState (ArchReg arch) (Value arch ids)
-> (Map
      (MemSegmentOff (RegAddrWidth (ArchReg arch)))
      (PostValueMap arch ids),
    FrontierMap arch)
-> MemSegmentOff (RegAddrWidth (ArchReg arch))
-> (Map
      (MemSegmentOff (RegAddrWidth (ArchReg arch)))
      (PostValueMap arch ids),
    FrontierMap arch)
forall arch ids.
(MemWidth (ArchAddrWidth arch), OrdF (ArchReg arch)) =>
(ArchSegmentOff arch -> Maybe (BlockStartConstraints arch))
-> StartInferContext arch
-> InferState arch ids
-> RegState (ArchReg arch) (Value arch ids)
-> (Map (ArchSegmentOff arch) (PostValueMap arch ids),
    FrontierMap arch)
-> ArchSegmentOff arch
-> (Map (ArchSegmentOff arch) (PostValueMap arch ids),
    FrontierMap arch)
visitIntraJumpTarget MemSegmentOff (RegAddrWidth (ArchReg arch))
-> Maybe (BlockStartConstraints arch)
lastFn StartInferContext arch
ctx InferState arch ids
s RegState (ArchReg arch) (Value arch ids)
regs (Map
  (MemSegmentOff (RegAddrWidth (ArchReg arch)))
  (PostValueMap arch ids)
forall k a. Map k a
Map.empty, FrontierMap arch
frontierMap) MemSegmentOff (RegAddrWidth (ArchReg arch))
next
      let m' :: Map
  (MemSegmentOff (RegAddrWidth (ArchReg arch)))
  (StartInferInfo arch ids)
m' = MemSegmentOff (RegAddrWidth (ArchReg arch))
-> StartInferInfo arch ids
-> Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (StartInferInfo arch ids)
-> Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (StartInferInfo arch ids)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert MemSegmentOff (RegAddrWidth (ArchReg arch))
addr (ParsedBlock arch ids
b, LocMap (ArchReg arch) (InitInferValue arch)
-> BlockStartConstraints arch
forall arch.
LocMap (ArchReg arch) (InitInferValue arch)
-> BlockStartConstraints arch
BSC LocMap (ArchReg arch) (InitInferValue arch)
cns, InferState arch ids
s, Map
  (MemSegmentOff (RegAddrWidth (ArchReg arch)))
  (PostValueMap arch ids)
pvm) Map
  (MemSegmentOff (RegAddrWidth (ArchReg arch)))
  (StartInferInfo arch ids)
lastMap
      (Map
   (MemSegmentOff (RegAddrWidth (ArchReg arch)))
   (StartInferInfo arch ids),
 FrontierMap arch)
-> Except
     (RegisterUseError arch)
     (Map
        (MemSegmentOff (RegAddrWidth (ArchReg arch)))
        (StartInferInfo arch ids),
      FrontierMap arch)
forall a. a -> ExceptT (RegisterUseError arch) Identity a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Map
  (MemSegmentOff (RegAddrWidth (ArchReg arch)))
  (StartInferInfo arch ids)
m', FrontierMap arch
frontierMap')
    ParsedBranch RegState (ArchReg arch) (Value arch ids)
regs Value arch ids BoolType
_cond MemSegmentOff (RegAddrWidth (ArchReg arch))
t MemSegmentOff (RegAddrWidth (ArchReg arch))
f -> do
      let (Map
  (MemSegmentOff (RegAddrWidth (ArchReg arch)))
  (PostValueMap arch ids)
pvm, FrontierMap arch
frontierMap') = ((Map
    (MemSegmentOff (RegAddrWidth (ArchReg arch)))
    (PostValueMap arch ids),
  FrontierMap arch)
 -> MemSegmentOff (RegAddrWidth (ArchReg arch))
 -> (Map
       (MemSegmentOff (RegAddrWidth (ArchReg arch)))
       (PostValueMap arch ids),
     FrontierMap arch))
-> (Map
      (MemSegmentOff (RegAddrWidth (ArchReg arch)))
      (PostValueMap arch ids),
    FrontierMap arch)
-> [MemSegmentOff (RegAddrWidth (ArchReg arch))]
-> (Map
      (MemSegmentOff (RegAddrWidth (ArchReg arch)))
      (PostValueMap arch ids),
    FrontierMap arch)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ((MemSegmentOff (RegAddrWidth (ArchReg arch))
 -> Maybe (BlockStartConstraints arch))
-> StartInferContext arch
-> InferState arch ids
-> RegState (ArchReg arch) (Value arch ids)
-> (Map
      (MemSegmentOff (RegAddrWidth (ArchReg arch)))
      (PostValueMap arch ids),
    FrontierMap arch)
-> MemSegmentOff (RegAddrWidth (ArchReg arch))
-> (Map
      (MemSegmentOff (RegAddrWidth (ArchReg arch)))
      (PostValueMap arch ids),
    FrontierMap arch)
forall arch ids.
(MemWidth (ArchAddrWidth arch), OrdF (ArchReg arch)) =>
(ArchSegmentOff arch -> Maybe (BlockStartConstraints arch))
-> StartInferContext arch
-> InferState arch ids
-> RegState (ArchReg arch) (Value arch ids)
-> (Map (ArchSegmentOff arch) (PostValueMap arch ids),
    FrontierMap arch)
-> ArchSegmentOff arch
-> (Map (ArchSegmentOff arch) (PostValueMap arch ids),
    FrontierMap arch)
visitIntraJumpTarget MemSegmentOff (RegAddrWidth (ArchReg arch))
-> Maybe (BlockStartConstraints arch)
lastFn StartInferContext arch
ctx InferState arch ids
s RegState (ArchReg arch) (Value arch ids)
regs) (Map
  (MemSegmentOff (RegAddrWidth (ArchReg arch)))
  (PostValueMap arch ids)
forall k a. Map k a
Map.empty, FrontierMap arch
frontierMap) [MemSegmentOff (RegAddrWidth (ArchReg arch))
t,MemSegmentOff (RegAddrWidth (ArchReg arch))
f]
      let m' :: Map
  (MemSegmentOff (RegAddrWidth (ArchReg arch)))
  (StartInferInfo arch ids)
m' = MemSegmentOff (RegAddrWidth (ArchReg arch))
-> StartInferInfo arch ids
-> Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (StartInferInfo arch ids)
-> Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (StartInferInfo arch ids)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert MemSegmentOff (RegAddrWidth (ArchReg arch))
addr (ParsedBlock arch ids
b, LocMap (ArchReg arch) (InitInferValue arch)
-> BlockStartConstraints arch
forall arch.
LocMap (ArchReg arch) (InitInferValue arch)
-> BlockStartConstraints arch
BSC LocMap (ArchReg arch) (InitInferValue arch)
cns, InferState arch ids
s, Map
  (MemSegmentOff (RegAddrWidth (ArchReg arch)))
  (PostValueMap arch ids)
pvm) Map
  (MemSegmentOff (RegAddrWidth (ArchReg arch)))
  (StartInferInfo arch ids)
lastMap
      (Map
   (MemSegmentOff (RegAddrWidth (ArchReg arch)))
   (StartInferInfo arch ids),
 FrontierMap arch)
-> Except
     (RegisterUseError arch)
     (Map
        (MemSegmentOff (RegAddrWidth (ArchReg arch)))
        (StartInferInfo arch ids),
      FrontierMap arch)
forall a. a -> ExceptT (RegisterUseError arch) Identity a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Map
  (MemSegmentOff (RegAddrWidth (ArchReg arch)))
  (StartInferInfo arch ids)
m', FrontierMap arch
frontierMap')
    ParsedLookupTable JumpTableLayout arch
_layout RegState (ArchReg arch) (Value arch ids)
regs ArchAddrValue arch ids
_idx Vector (MemSegmentOff (RegAddrWidth (ArchReg arch)))
lbls -> do
      let (Map
  (MemSegmentOff (RegAddrWidth (ArchReg arch)))
  (PostValueMap arch ids)
pvm, FrontierMap arch
frontierMap') = ((Map
    (MemSegmentOff (RegAddrWidth (ArchReg arch)))
    (PostValueMap arch ids),
  FrontierMap arch)
 -> MemSegmentOff (RegAddrWidth (ArchReg arch))
 -> (Map
       (MemSegmentOff (RegAddrWidth (ArchReg arch)))
       (PostValueMap arch ids),
     FrontierMap arch))
-> (Map
      (MemSegmentOff (RegAddrWidth (ArchReg arch)))
      (PostValueMap arch ids),
    FrontierMap arch)
-> Vector (MemSegmentOff (RegAddrWidth (ArchReg arch)))
-> (Map
      (MemSegmentOff (RegAddrWidth (ArchReg arch)))
      (PostValueMap arch ids),
    FrontierMap arch)
forall b a. (b -> a -> b) -> b -> Vector a -> b
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ((MemSegmentOff (RegAddrWidth (ArchReg arch))
 -> Maybe (BlockStartConstraints arch))
-> StartInferContext arch
-> InferState arch ids
-> RegState (ArchReg arch) (Value arch ids)
-> (Map
      (MemSegmentOff (RegAddrWidth (ArchReg arch)))
      (PostValueMap arch ids),
    FrontierMap arch)
-> MemSegmentOff (RegAddrWidth (ArchReg arch))
-> (Map
      (MemSegmentOff (RegAddrWidth (ArchReg arch)))
      (PostValueMap arch ids),
    FrontierMap arch)
forall arch ids.
(MemWidth (ArchAddrWidth arch), OrdF (ArchReg arch)) =>
(ArchSegmentOff arch -> Maybe (BlockStartConstraints arch))
-> StartInferContext arch
-> InferState arch ids
-> RegState (ArchReg arch) (Value arch ids)
-> (Map (ArchSegmentOff arch) (PostValueMap arch ids),
    FrontierMap arch)
-> ArchSegmentOff arch
-> (Map (ArchSegmentOff arch) (PostValueMap arch ids),
    FrontierMap arch)
visitIntraJumpTarget MemSegmentOff (RegAddrWidth (ArchReg arch))
-> Maybe (BlockStartConstraints arch)
lastFn StartInferContext arch
ctx InferState arch ids
s RegState (ArchReg arch) (Value arch ids)
regs) (Map
  (MemSegmentOff (RegAddrWidth (ArchReg arch)))
  (PostValueMap arch ids)
forall k a. Map k a
Map.empty, FrontierMap arch
frontierMap) Vector (MemSegmentOff (RegAddrWidth (ArchReg arch)))
lbls
      let m' :: Map
  (MemSegmentOff (RegAddrWidth (ArchReg arch)))
  (StartInferInfo arch ids)
m' = MemSegmentOff (RegAddrWidth (ArchReg arch))
-> StartInferInfo arch ids
-> Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (StartInferInfo arch ids)
-> Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (StartInferInfo arch ids)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert MemSegmentOff (RegAddrWidth (ArchReg arch))
addr (ParsedBlock arch ids
b, LocMap (ArchReg arch) (InitInferValue arch)
-> BlockStartConstraints arch
forall arch.
LocMap (ArchReg arch) (InitInferValue arch)
-> BlockStartConstraints arch
BSC LocMap (ArchReg arch) (InitInferValue arch)
cns, InferState arch ids
s, Map
  (MemSegmentOff (RegAddrWidth (ArchReg arch)))
  (PostValueMap arch ids)
pvm) Map
  (MemSegmentOff (RegAddrWidth (ArchReg arch)))
  (StartInferInfo arch ids)
lastMap
      (Map
   (MemSegmentOff (RegAddrWidth (ArchReg arch)))
   (StartInferInfo arch ids),
 FrontierMap arch)
-> Except
     (RegisterUseError arch)
     (Map
        (MemSegmentOff (RegAddrWidth (ArchReg arch)))
        (StartInferInfo arch ids),
      FrontierMap arch)
forall a. a -> ExceptT (RegisterUseError arch) Identity a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Map
  (MemSegmentOff (RegAddrWidth (ArchReg arch)))
  (StartInferInfo arch ids)
m', FrontierMap arch
frontierMap')
    ParsedCall RegState (ArchReg arch) (Value arch ids)
regs (Just MemSegmentOff (RegAddrWidth (ArchReg arch))
next) -> do
      (PostValueMap arch ids
postValCns, BlockStartConstraints arch
nextCns) <-
        case CallParams (ArchReg arch)
-> StartInferContext arch
-> InferState arch ids
-> Int
-> RegState (ArchReg arch) (Value arch ids)
-> Either
     (RegisterUseError arch)
     (PostValueMap arch ids, BlockStartConstraints arch)
forall arch ids.
ArchConstraints arch =>
CallParams (ArchReg arch)
-> StartInferContext arch
-> InferState arch ids
-> Int
-> RegState (ArchReg arch) (Value arch ids)
-> Either
     (RegisterUseError arch)
     (PostValueMap arch ids, BlockStartConstraints arch)
postCallConstraints (RegisterUseContext arch -> CallParams (ArchReg arch)
forall arch. RegisterUseContext arch -> CallParams (ArchReg arch)
archCallParams RegisterUseContext arch
rctx) StartInferContext arch
ctx InferState arch ids
s Int
stmtCount RegState (ArchReg arch) (Value arch ids)
regs of
          Left RegisterUseError arch
e -> RegisterUseError arch
-> ExceptT
     (RegisterUseError arch)
     Identity
     (PostValueMap arch ids, BlockStartConstraints arch)
forall a.
RegisterUseError arch -> ExceptT (RegisterUseError arch) Identity a
forall e (m :: Type -> Type) a. MonadError e m => e -> m a
throwError RegisterUseError arch
e
          Right (PostValueMap arch ids, BlockStartConstraints arch)
r -> (PostValueMap arch ids, BlockStartConstraints arch)
-> ExceptT
     (RegisterUseError arch)
     Identity
     (PostValueMap arch ids, BlockStartConstraints arch)
forall a. a -> ExceptT (RegisterUseError arch) Identity a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (PostValueMap arch ids, BlockStartConstraints arch)
r
      let m' :: Map
  (MemSegmentOff (RegAddrWidth (ArchReg arch)))
  (StartInferInfo arch ids)
m' = MemSegmentOff (RegAddrWidth (ArchReg arch))
-> StartInferInfo arch ids
-> Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (StartInferInfo arch ids)
-> Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (StartInferInfo arch ids)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert MemSegmentOff (RegAddrWidth (ArchReg arch))
addr (ParsedBlock arch ids
b, LocMap (ArchReg arch) (InitInferValue arch)
-> BlockStartConstraints arch
forall arch.
LocMap (ArchReg arch) (InitInferValue arch)
-> BlockStartConstraints arch
BSC LocMap (ArchReg arch) (InitInferValue arch)
cns, InferState arch ids
s,  MemSegmentOff (RegAddrWidth (ArchReg arch))
-> PostValueMap arch ids
-> Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (PostValueMap arch ids)
forall k a. k -> a -> Map k a
Map.singleton MemSegmentOff (RegAddrWidth (ArchReg arch))
next PostValueMap arch ids
postValCns) Map
  (MemSegmentOff (RegAddrWidth (ArchReg arch)))
  (StartInferInfo arch ids)
lastMap
      (Map
   (MemSegmentOff (RegAddrWidth (ArchReg arch)))
   (StartInferInfo arch ids),
 FrontierMap arch)
-> Except
     (RegisterUseError arch)
     (Map
        (MemSegmentOff (RegAddrWidth (ArchReg arch)))
        (StartInferInfo arch ids),
      FrontierMap arch)
forall a. a -> ExceptT (RegisterUseError arch) Identity a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Map
  (MemSegmentOff (RegAddrWidth (ArchReg arch)))
  (StartInferInfo arch ids)
m', (MemSegmentOff (RegAddrWidth (ArchReg arch))
 -> Maybe (BlockStartConstraints arch))
-> MemSegmentOff (RegAddrWidth (ArchReg arch))
-> BlockStartConstraints arch
-> FrontierMap arch
-> FrontierMap arch
forall arch.
(MemWidth (ArchAddrWidth arch), OrdF (ArchReg arch)) =>
(ArchSegmentOff arch -> Maybe (BlockStartConstraints arch))
-> ArchSegmentOff arch
-> BlockStartConstraints arch
-> FrontierMap arch
-> FrontierMap arch
addNextConstraints MemSegmentOff (RegAddrWidth (ArchReg arch))
-> Maybe (BlockStartConstraints arch)
lastFn MemSegmentOff (RegAddrWidth (ArchReg arch))
next BlockStartConstraints arch
nextCns FrontierMap arch
frontierMap)
    -- Tail call
    ParsedCall RegState (ArchReg arch) (Value arch ids)
_ Maybe (MemSegmentOff (RegAddrWidth (ArchReg arch)))
Nothing -> do
      let m' :: Map
  (MemSegmentOff (RegAddrWidth (ArchReg arch)))
  (StartInferInfo arch ids)
m' = MemSegmentOff (RegAddrWidth (ArchReg arch))
-> StartInferInfo arch ids
-> Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (StartInferInfo arch ids)
-> Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (StartInferInfo arch ids)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert MemSegmentOff (RegAddrWidth (ArchReg arch))
addr (ParsedBlock arch ids
b, LocMap (ArchReg arch) (InitInferValue arch)
-> BlockStartConstraints arch
forall arch.
LocMap (ArchReg arch) (InitInferValue arch)
-> BlockStartConstraints arch
BSC LocMap (ArchReg arch) (InitInferValue arch)
cns, InferState arch ids
s, Map
  (MemSegmentOff (RegAddrWidth (ArchReg arch)))
  (PostValueMap arch ids)
forall k a. Map k a
Map.empty) Map
  (MemSegmentOff (RegAddrWidth (ArchReg arch)))
  (StartInferInfo arch ids)
lastMap
      (Map
   (MemSegmentOff (RegAddrWidth (ArchReg arch)))
   (StartInferInfo arch ids),
 FrontierMap arch)
-> Except
     (RegisterUseError arch)
     (Map
        (MemSegmentOff (RegAddrWidth (ArchReg arch)))
        (StartInferInfo arch ids),
      FrontierMap arch)
forall a. a -> ExceptT (RegisterUseError arch) Identity a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Map
  (MemSegmentOff (RegAddrWidth (ArchReg arch)))
  (StartInferInfo arch ids)
m', FrontierMap arch
frontierMap)
    ParsedReturn RegState (ArchReg arch) (Value arch ids)
_ -> do
      let m' :: Map
  (MemSegmentOff (RegAddrWidth (ArchReg arch)))
  (StartInferInfo arch ids)
m' = MemSegmentOff (RegAddrWidth (ArchReg arch))
-> StartInferInfo arch ids
-> Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (StartInferInfo arch ids)
-> Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (StartInferInfo arch ids)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert MemSegmentOff (RegAddrWidth (ArchReg arch))
addr (ParsedBlock arch ids
b, LocMap (ArchReg arch) (InitInferValue arch)
-> BlockStartConstraints arch
forall arch.
LocMap (ArchReg arch) (InitInferValue arch)
-> BlockStartConstraints arch
BSC LocMap (ArchReg arch) (InitInferValue arch)
cns, InferState arch ids
s, Map
  (MemSegmentOff (RegAddrWidth (ArchReg arch)))
  (PostValueMap arch ids)
forall k a. Map k a
Map.empty) Map
  (MemSegmentOff (RegAddrWidth (ArchReg arch)))
  (StartInferInfo arch ids)
lastMap
      (Map
   (MemSegmentOff (RegAddrWidth (ArchReg arch)))
   (StartInferInfo arch ids),
 FrontierMap arch)
-> Except
     (RegisterUseError arch)
     (Map
        (MemSegmentOff (RegAddrWidth (ArchReg arch)))
        (StartInferInfo arch ids),
      FrontierMap arch)
forall a. a -> ExceptT (RegisterUseError arch) Identity a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Map
  (MemSegmentOff (RegAddrWidth (ArchReg arch)))
  (StartInferInfo arch ids)
m', FrontierMap arch
frontierMap)
    -- Works like a tail call.
    ParsedArchTermStmt ArchTermStmt arch (Value arch ids)
_ RegState (ArchReg arch) (Value arch ids)
_ Maybe (MemSegmentOff (RegAddrWidth (ArchReg arch)))
Nothing -> do
      let m' :: Map
  (MemSegmentOff (RegAddrWidth (ArchReg arch)))
  (StartInferInfo arch ids)
m' = MemSegmentOff (RegAddrWidth (ArchReg arch))
-> StartInferInfo arch ids
-> Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (StartInferInfo arch ids)
-> Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (StartInferInfo arch ids)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert MemSegmentOff (RegAddrWidth (ArchReg arch))
addr (ParsedBlock arch ids
b, LocMap (ArchReg arch) (InitInferValue arch)
-> BlockStartConstraints arch
forall arch.
LocMap (ArchReg arch) (InitInferValue arch)
-> BlockStartConstraints arch
BSC LocMap (ArchReg arch) (InitInferValue arch)
cns, InferState arch ids
s, Map
  (MemSegmentOff (RegAddrWidth (ArchReg arch)))
  (PostValueMap arch ids)
forall k a. Map k a
Map.empty) Map
  (MemSegmentOff (RegAddrWidth (ArchReg arch)))
  (StartInferInfo arch ids)
lastMap
      (Map
   (MemSegmentOff (RegAddrWidth (ArchReg arch)))
   (StartInferInfo arch ids),
 FrontierMap arch)
-> Except
     (RegisterUseError arch)
     (Map
        (MemSegmentOff (RegAddrWidth (ArchReg arch)))
        (StartInferInfo arch ids),
      FrontierMap arch)
forall a. a -> ExceptT (RegisterUseError arch) Identity a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Map
  (MemSegmentOff (RegAddrWidth (ArchReg arch)))
  (StartInferInfo arch ids)
m', FrontierMap arch
frontierMap)
    ParsedArchTermStmt ArchTermStmt arch (Value arch ids)
tstmt RegState (ArchReg arch) (Value arch ids)
regs (Just MemSegmentOff (RegAddrWidth (ArchReg arch))
next) -> do
      case RegisterUseContext arch
-> forall ids. PostTermStmtInvariants arch ids
forall arch.
RegisterUseContext arch
-> forall ids. PostTermStmtInvariants arch ids
archPostTermStmtInvariants RegisterUseContext arch
rctx StartInferContext arch
ctx InferState arch ids
s Int
stmtCount ArchTermStmt arch (Value arch ids)
tstmt RegState (ArchReg arch) (Value arch ids)
regs of
        Left RegisterUseError arch
e ->
          RegisterUseError arch
-> Except
     (RegisterUseError arch)
     (Map
        (MemSegmentOff (RegAddrWidth (ArchReg arch)))
        (StartInferInfo arch ids),
      FrontierMap arch)
forall a.
RegisterUseError arch -> ExceptT (RegisterUseError arch) Identity a
forall e (m :: Type -> Type) a. MonadError e m => e -> m a
throwError RegisterUseError arch
e
        Right (PostValueMap arch ids
postValCns, BlockStartConstraints arch
nextCns) -> do
          let m' :: Map
  (MemSegmentOff (RegAddrWidth (ArchReg arch)))
  (StartInferInfo arch ids)
m' = MemSegmentOff (RegAddrWidth (ArchReg arch))
-> StartInferInfo arch ids
-> Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (StartInferInfo arch ids)
-> Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (StartInferInfo arch ids)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert MemSegmentOff (RegAddrWidth (ArchReg arch))
addr (ParsedBlock arch ids
b, LocMap (ArchReg arch) (InitInferValue arch)
-> BlockStartConstraints arch
forall arch.
LocMap (ArchReg arch) (InitInferValue arch)
-> BlockStartConstraints arch
BSC LocMap (ArchReg arch) (InitInferValue arch)
cns, InferState arch ids
s, MemSegmentOff (RegAddrWidth (ArchReg arch))
-> PostValueMap arch ids
-> Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (PostValueMap arch ids)
forall k a. k -> a -> Map k a
Map.singleton MemSegmentOff (RegAddrWidth (ArchReg arch))
next PostValueMap arch ids
postValCns) Map
  (MemSegmentOff (RegAddrWidth (ArchReg arch)))
  (StartInferInfo arch ids)
lastMap
          (Map
   (MemSegmentOff (RegAddrWidth (ArchReg arch)))
   (StartInferInfo arch ids),
 FrontierMap arch)
-> Except
     (RegisterUseError arch)
     (Map
        (MemSegmentOff (RegAddrWidth (ArchReg arch)))
        (StartInferInfo arch ids),
      FrontierMap arch)
forall a. a -> ExceptT (RegisterUseError arch) Identity a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Map
  (MemSegmentOff (RegAddrWidth (ArchReg arch)))
  (StartInferInfo arch ids)
m', (MemSegmentOff (RegAddrWidth (ArchReg arch))
 -> Maybe (BlockStartConstraints arch))
-> MemSegmentOff (RegAddrWidth (ArchReg arch))
-> BlockStartConstraints arch
-> FrontierMap arch
-> FrontierMap arch
forall arch.
(MemWidth (ArchAddrWidth arch), OrdF (ArchReg arch)) =>
(ArchSegmentOff arch -> Maybe (BlockStartConstraints arch))
-> ArchSegmentOff arch
-> BlockStartConstraints arch
-> FrontierMap arch
-> FrontierMap arch
addNextConstraints MemSegmentOff (RegAddrWidth (ArchReg arch))
-> Maybe (BlockStartConstraints arch)
lastFn MemSegmentOff (RegAddrWidth (ArchReg arch))
next BlockStartConstraints arch
nextCns FrontierMap arch
frontierMap)
    ParsedTranslateError Text
_ -> do
      let m' :: Map
  (MemSegmentOff (RegAddrWidth (ArchReg arch)))
  (StartInferInfo arch ids)
m' = MemSegmentOff (RegAddrWidth (ArchReg arch))
-> StartInferInfo arch ids
-> Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (StartInferInfo arch ids)
-> Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (StartInferInfo arch ids)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert MemSegmentOff (RegAddrWidth (ArchReg arch))
addr (ParsedBlock arch ids
b, LocMap (ArchReg arch) (InitInferValue arch)
-> BlockStartConstraints arch
forall arch.
LocMap (ArchReg arch) (InitInferValue arch)
-> BlockStartConstraints arch
BSC LocMap (ArchReg arch) (InitInferValue arch)
cns, InferState arch ids
s, Map
  (MemSegmentOff (RegAddrWidth (ArchReg arch)))
  (PostValueMap arch ids)
forall k a. Map k a
Map.empty) Map
  (MemSegmentOff (RegAddrWidth (ArchReg arch)))
  (StartInferInfo arch ids)
lastMap
      (Map
   (MemSegmentOff (RegAddrWidth (ArchReg arch)))
   (StartInferInfo arch ids),
 FrontierMap arch)
-> Except
     (RegisterUseError arch)
     (Map
        (MemSegmentOff (RegAddrWidth (ArchReg arch)))
        (StartInferInfo arch ids),
      FrontierMap arch)
forall a. a -> ExceptT (RegisterUseError arch) Identity a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Map
  (MemSegmentOff (RegAddrWidth (ArchReg arch)))
  (StartInferInfo arch ids)
m', FrontierMap arch
frontierMap)
    ClassifyFailure RegState (ArchReg arch) (Value arch ids)
_ [String]
_ -> do
      let m' :: Map
  (MemSegmentOff (RegAddrWidth (ArchReg arch)))
  (StartInferInfo arch ids)
m' = MemSegmentOff (RegAddrWidth (ArchReg arch))
-> StartInferInfo arch ids
-> Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (StartInferInfo arch ids)
-> Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (StartInferInfo arch ids)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert MemSegmentOff (RegAddrWidth (ArchReg arch))
addr (ParsedBlock arch ids
b, LocMap (ArchReg arch) (InitInferValue arch)
-> BlockStartConstraints arch
forall arch.
LocMap (ArchReg arch) (InitInferValue arch)
-> BlockStartConstraints arch
BSC LocMap (ArchReg arch) (InitInferValue arch)
cns, InferState arch ids
s, Map
  (MemSegmentOff (RegAddrWidth (ArchReg arch)))
  (PostValueMap arch ids)
forall k a. Map k a
Map.empty) Map
  (MemSegmentOff (RegAddrWidth (ArchReg arch)))
  (StartInferInfo arch ids)
lastMap
      (Map
   (MemSegmentOff (RegAddrWidth (ArchReg arch)))
   (StartInferInfo arch ids),
 FrontierMap arch)
-> Except
     (RegisterUseError arch)
     (Map
        (MemSegmentOff (RegAddrWidth (ArchReg arch)))
        (StartInferInfo arch ids),
      FrontierMap arch)
forall a. a -> ExceptT (RegisterUseError arch) Identity a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Map
  (MemSegmentOff (RegAddrWidth (ArchReg arch)))
  (StartInferInfo arch ids)
m', FrontierMap arch
frontierMap)
    -- PLT stubs are essentiually tail calls with a non-standard
    -- calling convention.
    PLTStub{} -> do
      let m' :: Map
  (MemSegmentOff (RegAddrWidth (ArchReg arch)))
  (StartInferInfo arch ids)
m' = MemSegmentOff (RegAddrWidth (ArchReg arch))
-> StartInferInfo arch ids
-> Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (StartInferInfo arch ids)
-> Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (StartInferInfo arch ids)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert MemSegmentOff (RegAddrWidth (ArchReg arch))
addr (ParsedBlock arch ids
b, LocMap (ArchReg arch) (InitInferValue arch)
-> BlockStartConstraints arch
forall arch.
LocMap (ArchReg arch) (InitInferValue arch)
-> BlockStartConstraints arch
BSC LocMap (ArchReg arch) (InitInferValue arch)
cns, InferState arch ids
s, Map
  (MemSegmentOff (RegAddrWidth (ArchReg arch)))
  (PostValueMap arch ids)
forall k a. Map k a
Map.empty) Map
  (MemSegmentOff (RegAddrWidth (ArchReg arch)))
  (StartInferInfo arch ids)
lastMap
      (Map
   (MemSegmentOff (RegAddrWidth (ArchReg arch)))
   (StartInferInfo arch ids),
 FrontierMap arch)
-> Except
     (RegisterUseError arch)
     (Map
        (MemSegmentOff (RegAddrWidth (ArchReg arch)))
        (StartInferInfo arch ids),
      FrontierMap arch)
forall a. a -> ExceptT (RegisterUseError arch) Identity a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Map
  (MemSegmentOff (RegAddrWidth (ArchReg arch)))
  (StartInferInfo arch ids)
m', FrontierMap arch
frontierMap)

-- | Infer start constraints by recursively evaluating blocks
propStartConstraints :: ArchConstraints arch
                     => RegisterUseContext arch
                     -> Map (ArchSegmentOff arch) (ParsedBlock arch ids)
                     -- ^ Map from starting addresses to blocks.
                     -> Map (ArchSegmentOff arch) (StartInferInfo arch ids)
                     -- ^ Map starting address of blocks to information
                     -- about block from last exploration.
                     -> FrontierMap arch
                     -- ^ Maps addresses of blocks to explore to
                     -- the starting constraints.
                     -> Except (RegisterUseError arch)
                               (Map (ArchSegmentOff arch) (StartInferInfo arch ids))
propStartConstraints :: forall arch ids.
ArchConstraints arch =>
RegisterUseContext arch
-> Map (ArchSegmentOff arch) (ParsedBlock arch ids)
-> Map (ArchSegmentOff arch) (StartInferInfo arch ids)
-> FrontierMap arch
-> Except
     (RegisterUseError arch)
     (Map (ArchSegmentOff arch) (StartInferInfo arch ids))
propStartConstraints RegisterUseContext arch
rctx Map (ArchSegmentOff arch) (ParsedBlock arch ids)
blockMap Map (ArchSegmentOff arch) (StartInferInfo arch ids)
lastMap FrontierMap arch
next =
  case FrontierMap arch
-> Maybe
     ((ArchSegmentOff arch, BlockStartConstraints arch),
      FrontierMap arch)
forall k a. Map k a -> Maybe ((k, a), Map k a)
Map.minViewWithKey FrontierMap arch
next of
    Maybe
  ((ArchSegmentOff arch, BlockStartConstraints arch),
   FrontierMap arch)
Nothing -> Map (ArchSegmentOff arch) (StartInferInfo arch ids)
-> Except
     (RegisterUseError arch)
     (Map (ArchSegmentOff arch) (StartInferInfo arch ids))
forall a. a -> ExceptT (RegisterUseError arch) Identity a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Map (ArchSegmentOff arch) (StartInferInfo arch ids)
lastMap
    Just ((ArchSegmentOff arch
nextAddr, BlockStartConstraints arch
nextCns), FrontierMap arch
rest) -> do
      (Map (ArchSegmentOff arch) (StartInferInfo arch ids)
lastMap', FrontierMap arch
next') <- RegisterUseContext arch
-> Map (ArchSegmentOff arch) (ParsedBlock arch ids)
-> ArchSegmentOff arch
-> BlockStartConstraints arch
-> Map (ArchSegmentOff arch) (StartInferInfo arch ids)
-> FrontierMap arch
-> ExceptT
     (RegisterUseError arch)
     Identity
     (Map (ArchSegmentOff arch) (StartInferInfo arch ids),
      FrontierMap arch)
forall arch ids.
ArchConstraints arch =>
RegisterUseContext arch
-> Map (ArchSegmentOff arch) (ParsedBlock arch ids)
-> ArchSegmentOff arch
-> BlockStartConstraints arch
-> Map (ArchSegmentOff arch) (StartInferInfo arch ids)
-> FrontierMap arch
-> Except
     (RegisterUseError arch)
     (Map (ArchSegmentOff arch) (StartInferInfo arch ids),
      FrontierMap arch)
blockStartConstraints RegisterUseContext arch
rctx Map (ArchSegmentOff arch) (ParsedBlock arch ids)
blockMap ArchSegmentOff arch
nextAddr BlockStartConstraints arch
nextCns Map (ArchSegmentOff arch) (StartInferInfo arch ids)
lastMap FrontierMap arch
rest
      RegisterUseContext arch
-> Map (ArchSegmentOff arch) (ParsedBlock arch ids)
-> Map (ArchSegmentOff arch) (StartInferInfo arch ids)
-> FrontierMap arch
-> Except
     (RegisterUseError arch)
     (Map (ArchSegmentOff arch) (StartInferInfo arch ids))
forall arch ids.
ArchConstraints arch =>
RegisterUseContext arch
-> Map (ArchSegmentOff arch) (ParsedBlock arch ids)
-> Map (ArchSegmentOff arch) (StartInferInfo arch ids)
-> FrontierMap arch
-> Except
     (RegisterUseError arch)
     (Map (ArchSegmentOff arch) (StartInferInfo arch ids))
propStartConstraints RegisterUseContext arch
rctx Map (ArchSegmentOff arch) (ParsedBlock arch ids)
blockMap Map (ArchSegmentOff arch) (StartInferInfo arch ids)
lastMap' FrontierMap arch
next'

-- | Infer start constraints by recursively evaluating blocks
inferStartConstraints :: forall arch ids
                      .  ArchConstraints arch
                      => RegisterUseContext arch
                      -> Map (ArchSegmentOff arch) (ParsedBlock arch ids)
                      -- ^ Map from starting addresses to blocks.
                      -> ArchSegmentOff arch
                      -- ^ Map starting address of blocks to information
                      -- about block from last exploration.
                      -> Except (RegisterUseError arch)
                                (Map (ArchSegmentOff arch) (StartInferInfo arch ids))
inferStartConstraints :: forall arch ids.
ArchConstraints arch =>
RegisterUseContext arch
-> Map (ArchSegmentOff arch) (ParsedBlock arch ids)
-> ArchSegmentOff arch
-> Except
     (RegisterUseError arch)
     (Map (ArchSegmentOff arch) (StartInferInfo arch ids))
inferStartConstraints RegisterUseContext arch
rctx Map (ArchSegmentOff arch) (ParsedBlock arch ids)
blockMap ArchSegmentOff arch
addr = do
  let savedRegs :: [Pair (ArchReg arch) (InitInferValue arch)]
      savedRegs :: [Pair (ArchReg arch) (InitInferValue arch)]
savedRegs
        =  [ ArchReg arch (BVType (RegAddrWidth (ArchReg arch)))
-> InitInferValue arch (BVType (RegAddrWidth (ArchReg arch)))
-> Pair (ArchReg arch) (InitInferValue arch)
forall {k} (a :: k -> Type) (tp :: k) (b :: k -> Type).
a tp -> b tp -> Pair a b
Pair ArchReg arch (BVType (RegAddrWidth (ArchReg arch)))
forall (r :: Type -> Type).
RegisterInfo r =>
r (BVType (RegAddrWidth r))
sp_reg (MemInt (RegAddrWidth (ArchReg arch))
-> InitInferValue arch (BVType (RegAddrWidth (ArchReg arch)))
forall arch.
MemInt (ArchAddrWidth arch)
-> InitInferValue arch (BVType (ArchAddrWidth arch))
InferredStackOffset MemInt (RegAddrWidth (ArchReg arch))
0) ]
        [Pair (ArchReg arch) (InitInferValue arch)]
-> [Pair (ArchReg arch) (InitInferValue arch)]
-> [Pair (ArchReg arch) (InitInferValue arch)]
forall a. [a] -> [a] -> [a]
++ [ ArchReg arch x
-> InitInferValue arch x
-> Pair (ArchReg arch) (InitInferValue arch)
forall {k} (a :: k -> Type) (tp :: k) (b :: k -> Type).
a tp -> b tp -> Pair a b
Pair ArchReg arch x
r (ArchReg arch x -> InitInferValue arch x
forall arch (tp :: Type). ArchReg arch tp -> InitInferValue arch tp
FnStartRegister ArchReg arch x
r) | Some ArchReg arch x
r <- RegisterUseContext arch -> [Some (ArchReg arch)]
forall arch. RegisterUseContext arch -> [Some (ArchReg arch)]
calleeSavedRegisters RegisterUseContext arch
rctx ]
  let cns :: BlockStartConstraints arch
cns = LocMap (ArchReg arch) (InitInferValue arch)
-> BlockStartConstraints arch
forall arch.
LocMap (ArchReg arch) (InitInferValue arch)
-> BlockStartConstraints arch
BSC LocMap { locMapRegs :: MapF (ArchReg arch) (InitInferValue arch)
locMapRegs = [Pair (ArchReg arch) (InitInferValue arch)]
-> MapF (ArchReg arch) (InitInferValue arch)
forall {v} (k :: v -> Type) (a :: v -> Type).
OrdF k =>
[Pair k a] -> MapF k a
MapF.fromList [Pair (ArchReg arch) (InitInferValue arch)]
savedRegs
                       , locMapStack :: MemMap (MemInt (RegAddrWidth (ArchReg arch))) (InitInferValue arch)
locMapStack = MemMap (MemInt (RegAddrWidth (ArchReg arch))) (InitInferValue arch)
forall o (v :: Type -> Type). MemMap o v
emptyMemMap
                       }
  RegisterUseContext arch
-> Map (ArchSegmentOff arch) (ParsedBlock arch ids)
-> Map (ArchSegmentOff arch) (StartInferInfo arch ids)
-> FrontierMap arch
-> Except
     (RegisterUseError arch)
     (Map (ArchSegmentOff arch) (StartInferInfo arch ids))
forall arch ids.
ArchConstraints arch =>
RegisterUseContext arch
-> Map (ArchSegmentOff arch) (ParsedBlock arch ids)
-> Map (ArchSegmentOff arch) (StartInferInfo arch ids)
-> FrontierMap arch
-> Except
     (RegisterUseError arch)
     (Map (ArchSegmentOff arch) (StartInferInfo arch ids))
propStartConstraints RegisterUseContext arch
rctx Map (ArchSegmentOff arch) (ParsedBlock arch ids)
blockMap Map (ArchSegmentOff arch) (StartInferInfo arch ids)
forall k a. Map k a
Map.empty (ArchSegmentOff arch
-> BlockStartConstraints arch -> FrontierMap arch
forall k a. k -> a -> Map k a
Map.singleton ArchSegmentOff arch
addr BlockStartConstraints arch
cns)

-- | Pretty print start constraints for debugging purposes.
ppStartConstraints :: forall arch ids ann
                   .  (MemWidth (ArchAddrWidth arch), ShowF (ArchReg arch))
                   => Map (ArchSegmentOff arch) (StartInferInfo arch ids)
                   -> Doc ann
ppStartConstraints :: forall arch ids ann.
(MemWidth (ArchAddrWidth arch), ShowF (ArchReg arch)) =>
Map (ArchSegmentOff arch) (StartInferInfo arch ids) -> Doc ann
ppStartConstraints Map (MemSegmentOff (ArchAddrWidth arch)) (StartInferInfo arch ids)
m = [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vcat ((MemSegmentOff (ArchAddrWidth arch), StartInferInfo arch ids)
-> Doc ann
pp ((MemSegmentOff (ArchAddrWidth arch), StartInferInfo arch ids)
 -> Doc ann)
-> [(MemSegmentOff (ArchAddrWidth arch), StartInferInfo arch ids)]
-> [Doc ann]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Map (MemSegmentOff (ArchAddrWidth arch)) (StartInferInfo arch ids)
-> [(MemSegmentOff (ArchAddrWidth arch), StartInferInfo arch ids)]
forall k a. Map k a -> [(k, a)]
Map.toList Map (MemSegmentOff (ArchAddrWidth arch)) (StartInferInfo arch ids)
m)
  where pp :: (ArchSegmentOff arch, StartInferInfo arch ids) -> Doc ann
        pp :: (MemSegmentOff (ArchAddrWidth arch), StartInferInfo arch ids)
-> Doc ann
pp (MemSegmentOff (ArchAddrWidth arch)
addr, (ParsedBlock arch ids
_,BlockStartConstraints arch
_,InferState arch ids
_,Map (MemSegmentOff (ArchAddrWidth arch)) (PostValueMap arch ids)
pvm)) =
          let pvmEntries :: Doc ann
pvmEntries = [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vcat ((MemSegmentOff (ArchAddrWidth arch), PostValueMap arch ids)
-> Doc ann
ppPVMPair ((MemSegmentOff (ArchAddrWidth arch), PostValueMap arch ids)
 -> Doc ann)
-> [(MemSegmentOff (ArchAddrWidth arch), PostValueMap arch ids)]
-> [Doc ann]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Map (MemSegmentOff (ArchAddrWidth arch)) (PostValueMap arch ids)
-> [(MemSegmentOff (ArchAddrWidth arch), PostValueMap arch ids)]
forall k a. Map k a -> [(k, a)]
Map.toList Map (MemSegmentOff (ArchAddrWidth arch)) (PostValueMap arch ids)
pvm)
           in [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vcat [ MemSegmentOff (ArchAddrWidth arch) -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. MemSegmentOff (ArchAddrWidth arch) -> Doc ann
pretty MemSegmentOff (ArchAddrWidth arch)
addr
                   , Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 (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
"post-values:", Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 Doc ann
pvmEntries] ]
        ppPVMPair :: (ArchSegmentOff arch, PostValueMap arch ids) -> Doc ann
        ppPVMPair :: (MemSegmentOff (ArchAddrWidth arch), PostValueMap arch ids)
-> Doc ann
ppPVMPair (MemSegmentOff (ArchAddrWidth arch)
preaddr, PostValueMap arch ids
pvm) =
          [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vcat
          [ Doc ann
"to" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> MemSegmentOff (ArchAddrWidth arch) -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. MemSegmentOff (ArchAddrWidth arch) -> Doc ann
pretty MemSegmentOff (ArchAddrWidth arch)
preaddr Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
":"
          , Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 (PostValueMap arch ids -> Doc ann
forall arch ids ann.
ShowF (ArchReg arch) =>
PostValueMap arch ids -> Doc ann
ppPVM PostValueMap arch ids
pvm) ]

_ppStartConstraints :: forall arch ids ann
                   .  (MemWidth (ArchAddrWidth arch), ShowF (ArchReg arch))
                   => Map (ArchSegmentOff arch) (StartInferInfo arch ids)
                   -> Doc ann
_ppStartConstraints :: forall arch ids ann.
(MemWidth (ArchAddrWidth arch), ShowF (ArchReg arch)) =>
Map (ArchSegmentOff arch) (StartInferInfo arch ids) -> Doc ann
_ppStartConstraints = Map (ArchSegmentOff arch) (StartInferInfo arch ids) -> Doc ann
forall arch ids ann.
(MemWidth (ArchAddrWidth arch), ShowF (ArchReg arch)) =>
Map (ArchSegmentOff arch) (StartInferInfo arch ids) -> Doc ann
ppStartConstraints

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

-- | This maps each location that could be accessed after a block
-- terminates to the set of values needed to compute the value of the
-- location.
type LocDependencyMap r ids = LocMap r (Const (DependencySet r ids))

-- | Get dependency set for location.
--
-- Note. This code is currently buggy in that it will back propagate
-- stack reads that are partially overwritten.
getLocDependencySet :: (MapF.OrdF r, MemWidth (RegAddrWidth r))
                    => LocDependencyMap r ids
                    -> BoundLoc r tp
                    -> DependencySet r ids
getLocDependencySet :: forall (r :: Type -> Type) ids (tp :: Type).
(OrdF r, MemWidth (RegAddrWidth r)) =>
LocDependencyMap r ids -> BoundLoc r tp -> DependencySet r ids
getLocDependencySet LocDependencyMap r ids
srcDepMap BoundLoc r tp
l =
  case BoundLoc r tp
-> LocDependencyMap r ids -> Maybe (Const (DependencySet r ids) tp)
forall (r :: Type -> Type) (tp :: Type) (v :: Type -> Type).
(MemWidth (RegAddrWidth r), OrdF r) =>
BoundLoc r tp -> LocMap r v -> Maybe (v tp)
locLookup BoundLoc r tp
l LocDependencyMap r ids
srcDepMap of
    Maybe (Const (DependencySet r ids) tp)
Nothing -> BoundLoc r tp -> DependencySet r ids
forall (r :: Type -> Type) (tp :: Type) ids.
BoundLoc r tp -> DependencySet r ids
locDepSet BoundLoc r tp
l
    Just (Const DependencySet r ids
s) -> DependencySet r ids
s

------------------------------------------------------------------------
-- RegisterUseM

type RegisterUseM arch ids =
  ReaderT (RegisterUseContext arch)
          (StateT (BlockUsageSummary arch ids)
                  (Except (RegisterUseError arch)))

-- ----------------------------------------------------------------------------------------
-- Phase one functions
-- ----------------------------------------------------------------------------------------

domainDeps :: InitInferValue arch tp -> DependencySet (ArchReg arch) ids
domainDeps :: forall arch (tp :: Type) ids.
InitInferValue arch tp -> DependencySet (ArchReg arch) ids
domainDeps (InferredStackOffset MemInt (ArchAddrWidth arch)
_) = DependencySet (ArchReg arch) ids
forall (r :: Type -> Type) ids. DependencySet r ids
emptyDeps
domainDeps (FnStartRegister ArchReg arch tp
_)    = DependencySet (ArchReg arch) ids
forall (r :: Type -> Type) ids. DependencySet r ids
emptyDeps
domainDeps (RegEqualLoc BoundLoc (ArchReg arch) tp
l)        = BoundLoc (ArchReg arch) tp -> DependencySet (ArchReg arch) ids
forall (r :: Type -> Type) (tp :: Type) ids.
BoundLoc r tp -> DependencySet r ids
locDepSet BoundLoc (ArchReg arch) tp
l

-- | Return the register and assignment dependencies needed to
valueDeps :: (HasCallStack, MemWidth (ArchAddrWidth arch), OrdF (ArchReg arch))
          => BlockStartConstraints arch
          -> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
          -> Value arch ids tp
          -> DependencySet (ArchReg arch) ids
valueDeps :: forall arch ids (tp :: Type).
(HasCallStack, MemWidth (ArchAddrWidth arch),
 OrdF (ArchReg arch)) =>
BlockStartConstraints arch
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
-> Value arch ids tp
-> DependencySet (ArchReg arch) ids
valueDeps BlockStartConstraints arch
_ Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
_ (CValue CValue arch tp
_) = DependencySet (ArchReg arch) ids
forall (r :: Type -> Type) ids. DependencySet r ids
emptyDeps
valueDeps BlockStartConstraints arch
cns Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
_ (Initial ArchReg arch tp
r) = InitInferValue arch tp -> DependencySet (ArchReg arch) ids
forall arch (tp :: Type) ids.
InitInferValue arch tp -> DependencySet (ArchReg arch) ids
domainDeps (BlockStartConstraints arch
-> BoundLoc (ArchReg arch) tp -> InitInferValue arch tp
forall arch (tp :: Type).
(MemWidth (ArchAddrWidth arch), OrdF (ArchReg arch)) =>
BlockStartConstraints arch
-> BoundLoc (ArchReg arch) tp -> InitInferValue arch tp
locDomain BlockStartConstraints arch
cns (ArchReg arch tp -> BoundLoc (ArchReg arch) tp
forall (r :: Type -> Type) (tp :: Type). r tp -> BoundLoc r tp
RegLoc ArchReg arch tp
r))
valueDeps BlockStartConstraints arch
_ Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
m (AssignedValue (Assignment AssignId ids tp
a AssignRhs arch (Value arch ids) tp
_)) =
  case Some (AssignId ids)
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
-> Maybe (DependencySet (ArchReg arch) ids)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (AssignId ids tp -> Some (AssignId ids)
forall k (f :: k -> Type) (x :: k). f x -> Some f
Some AssignId ids tp
a) Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
m of
    Maybe (DependencySet (ArchReg arch) ids)
Nothing -> String -> DependencySet (ArchReg arch) ids
forall a. HasCallStack => String -> a
error (String -> DependencySet (ArchReg arch) ids)
-> String -> DependencySet (ArchReg arch) ids
forall a b. (a -> b) -> a -> b
$ String
"Assignment " String -> ShowS
forall a. [a] -> [a] -> [a]
++ AssignId ids tp -> String
forall a. Show a => a -> String
show AssignId ids tp
a String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" is not defined."
    Just DependencySet (ArchReg arch) ids
r -> DependencySet (ArchReg arch) ids
r

-- | Record the given dependencies are needed to execute this block.
addDeps :: (HasCallStack, OrdF (ArchReg arch))
        => DependencySet (ArchReg arch) ids
        -> RegisterUseM arch ids ()
addDeps :: forall arch ids.
(HasCallStack, OrdF (ArchReg arch)) =>
DependencySet (ArchReg arch) ids -> RegisterUseM arch ids ()
addDeps DependencySet (ArchReg arch) ids
deps = (DependencySet (ArchReg arch) ids
 -> Identity (DependencySet (ArchReg arch) ids))
-> BlockUsageSummary arch ids
-> Identity (BlockUsageSummary arch ids)
forall arch ids (f :: Type -> Type).
Functor f =>
(DependencySet (ArchReg arch) ids
 -> f (DependencySet (ArchReg arch) ids))
-> BlockUsageSummary arch ids -> f (BlockUsageSummary arch ids)
blockExecDemands ((DependencySet (ArchReg arch) ids
  -> Identity (DependencySet (ArchReg arch) ids))
 -> BlockUsageSummary arch ids
 -> Identity (BlockUsageSummary arch ids))
-> (DependencySet (ArchReg arch) ids
    -> DependencySet (ArchReg arch) ids)
-> ReaderT
     (RegisterUseContext arch)
     (StateT
        (BlockUsageSummary arch ids) (Except (RegisterUseError arch)))
     ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= DependencySet (ArchReg arch) ids
-> DependencySet (ArchReg arch) ids
-> DependencySet (ArchReg arch) ids
forall a. Monoid a => a -> a -> a
mappend DependencySet (ArchReg arch) ids
deps

-- | Record the values needed to compute the given value.
demandValue :: (HasCallStack, MemWidth (ArchAddrWidth arch), OrdF (ArchReg arch))
            => Value arch ids tp
            -> RegisterUseM arch ids ()
demandValue :: forall arch ids (tp :: Type).
(HasCallStack, MemWidth (ArchAddrWidth arch),
 OrdF (ArchReg arch)) =>
Value arch ids tp -> RegisterUseM arch ids ()
demandValue Value arch ids tp
v = do
  BlockStartConstraints arch
cns <- (BlockUsageSummary arch ids -> BlockStartConstraints arch)
-> ReaderT
     (RegisterUseContext arch)
     (StateT
        (BlockUsageSummary arch ids) (Except (RegisterUseError arch)))
     (BlockStartConstraints arch)
forall s (m :: Type -> Type) a. MonadState s m => (s -> a) -> m a
gets BlockUsageSummary arch ids -> BlockStartConstraints arch
forall arch ids.
BlockUsageSummary arch ids -> BlockStartConstraints arch
blockUsageStartConstraints
  Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
cache <- (BlockUsageSummary arch ids
 -> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids))
-> ReaderT
     (RegisterUseContext arch)
     (StateT
        (BlockUsageSummary arch ids) (Except (RegisterUseError arch)))
     (Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids))
forall s (m :: Type -> Type) a. MonadState s m => (s -> a) -> m a
gets BlockUsageSummary arch ids
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
forall arch ids.
BlockUsageSummary arch ids
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
assignDeps
  DependencySet (ArchReg arch) ids -> RegisterUseM arch ids ()
forall arch ids.
(HasCallStack, OrdF (ArchReg arch)) =>
DependencySet (ArchReg arch) ids -> RegisterUseM arch ids ()
addDeps (BlockStartConstraints arch
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
-> Value arch ids tp
-> DependencySet (ArchReg arch) ids
forall arch ids (tp :: Type).
(HasCallStack, MemWidth (ArchAddrWidth arch),
 OrdF (ArchReg arch)) =>
BlockStartConstraints arch
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
-> Value arch ids tp
-> DependencySet (ArchReg arch) ids
valueDeps BlockStartConstraints arch
cns Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
cache Value arch ids tp
v)

-- | Mark the given register has no dependencies
clearDependencySet :: (MemWidth (ArchAddrWidth arch), OrdF (ArchReg arch))
                   => ArchReg arch tp
                   -> BlockUsageSummary arch ids
                   -> BlockUsageSummary arch ids
clearDependencySet :: forall arch (tp :: Type) ids.
(MemWidth (ArchAddrWidth arch), OrdF (ArchReg arch)) =>
ArchReg arch tp
-> BlockUsageSummary arch ids -> BlockUsageSummary arch ids
clearDependencySet ArchReg arch tp
r BlockUsageSummary arch ids
s =
  BlockUsageSummary arch ids
s BlockUsageSummary arch ids
-> (BlockUsageSummary arch ids -> BlockUsageSummary arch ids)
-> BlockUsageSummary arch ids
forall a b. a -> (a -> b) -> b
& (RegDependencyMap arch ids -> Identity (RegDependencyMap arch ids))
-> BlockUsageSummary arch ids
-> Identity (BlockUsageSummary arch ids)
forall arch ids (f :: Type -> Type).
Functor f =>
(RegDependencyMap arch ids -> f (RegDependencyMap arch ids))
-> BlockUsageSummary arch ids -> f (BlockUsageSummary arch ids)
blockRegDependenciesLens ((RegDependencyMap arch ids
  -> Identity (RegDependencyMap arch ids))
 -> BlockUsageSummary arch ids
 -> Identity (BlockUsageSummary arch ids))
-> (RegDependencyMap arch ids -> RegDependencyMap arch ids)
-> BlockUsageSummary arch ids
-> BlockUsageSummary arch ids
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ ArchReg arch tp
-> DependencySet (ArchReg arch) ids
-> RegDependencyMap arch ids
-> RegDependencyMap arch ids
forall arch (tp :: Type) ids.
OrdF (ArchReg arch) =>
ArchReg arch tp
-> DependencySet (ArchReg arch) ids
-> RegDependencyMap arch ids
-> RegDependencyMap arch ids
setRegDep ArchReg arch tp
r DependencySet (ArchReg arch) ids
forall a. Monoid a => a
mempty

-- | @recordRegMap m@ record that the values in @regs@ are
-- used to initial registers in the next block and the registers in
-- @l@ can be depended upon.
recordRegMap :: forall arch ids
                    .  (MemWidth (ArchAddrWidth arch), OrdF (ArchReg arch))
                    => MapF (ArchReg arch) (Value arch ids)
                    -- ^ Register and assigned values available when block terminates.
                    -> RegisterUseM arch ids ()
recordRegMap :: forall arch ids.
(MemWidth (ArchAddrWidth arch), OrdF (ArchReg arch)) =>
MapF (ArchReg arch) (Value arch ids) -> RegisterUseM arch ids ()
recordRegMap MapF (ArchReg arch) (Value arch ids)
m = do
  BlockStartConstraints arch
cns <- (BlockUsageSummary arch ids -> BlockStartConstraints arch)
-> ReaderT
     (RegisterUseContext arch)
     (StateT
        (BlockUsageSummary arch ids) (Except (RegisterUseError arch)))
     (BlockStartConstraints arch)
forall s (m :: Type -> Type) a. MonadState s m => (s -> a) -> m a
gets BlockUsageSummary arch ids -> BlockStartConstraints arch
forall arch ids.
BlockUsageSummary arch ids -> BlockStartConstraints arch
blockUsageStartConstraints
  Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
cache <- (BlockUsageSummary arch ids
 -> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids))
-> ReaderT
     (RegisterUseContext arch)
     (StateT
        (BlockUsageSummary arch ids) (Except (RegisterUseError arch)))
     (Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids))
forall s (m :: Type -> Type) a. MonadState s m => (s -> a) -> m a
gets BlockUsageSummary arch ids
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
forall arch ids.
BlockUsageSummary arch ids
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
assignDeps
  (RegDependencyMap arch ids -> Identity (RegDependencyMap arch ids))
-> BlockUsageSummary arch ids
-> Identity (BlockUsageSummary arch ids)
forall arch ids (f :: Type -> Type).
Functor f =>
(RegDependencyMap arch ids -> f (RegDependencyMap arch ids))
-> BlockUsageSummary arch ids -> f (BlockUsageSummary arch ids)
blockRegDependenciesLens ((RegDependencyMap arch ids
  -> Identity (RegDependencyMap arch ids))
 -> BlockUsageSummary arch ids
 -> Identity (BlockUsageSummary arch ids))
-> RegDependencyMap arch ids -> RegisterUseM arch ids ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= (forall (tp :: Type).
 Value arch ids tp -> DependencySet (ArchReg arch) ids)
-> MapF (ArchReg arch) (Value arch ids)
-> RegDependencyMap arch ids
forall (a :: Type -> Type) arch ids.
(forall (tp :: Type). a tp -> DependencySet (ArchReg arch) ids)
-> MapF (ArchReg arch) a -> RegDependencyMap arch ids
regDepsFromMap (BlockStartConstraints arch
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
-> Value arch ids tp
-> DependencySet (ArchReg arch) ids
forall arch ids (tp :: Type).
(HasCallStack, MemWidth (ArchAddrWidth arch),
 OrdF (ArchReg arch)) =>
BlockStartConstraints arch
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
-> Value arch ids tp
-> DependencySet (ArchReg arch) ids
valueDeps BlockStartConstraints arch
cns Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
cache) MapF (ArchReg arch) (Value arch ids)
m

-- | Set dependencies for an assignment whose right-hand-side must be
-- evaluated for side effects.
requiredAssignDeps :: OrdF (ArchReg arch)
                   => AssignId ids tp
                   -> DependencySet (ArchReg arch) ids
                   -> RegisterUseM arch ids ()
requiredAssignDeps :: forall arch ids (tp :: Type).
OrdF (ArchReg arch) =>
AssignId ids tp
-> DependencySet (ArchReg arch) ids -> RegisterUseM arch ids ()
requiredAssignDeps AssignId ids tp
aid DependencySet (ArchReg arch) ids
deps = do
  DependencySet (ArchReg arch) ids -> RegisterUseM arch ids ()
forall arch ids.
(HasCallStack, OrdF (ArchReg arch)) =>
DependencySet (ArchReg arch) ids -> RegisterUseM arch ids ()
addDeps DependencySet (ArchReg arch) ids
deps
  (Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
 -> Identity
      (Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)))
-> BlockUsageSummary arch ids
-> Identity (BlockUsageSummary arch ids)
forall arch ids (f :: Type -> Type).
Functor f =>
(Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
 -> f (Map
         (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)))
-> BlockUsageSummary arch ids -> f (BlockUsageSummary arch ids)
assignmentCache ((Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
  -> Identity
       (Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)))
 -> BlockUsageSummary arch ids
 -> Identity (BlockUsageSummary arch ids))
-> (Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
    -> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids))
-> RegisterUseM arch ids ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= Some (AssignId ids)
-> DependencySet (ArchReg arch) ids
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (AssignId ids tp -> Some (AssignId ids)
forall k (f :: k -> Type) (x :: k). f x -> Some f
Some AssignId ids tp
aid) DependencySet (ArchReg arch) ids
forall a. Monoid a => a
mempty

popAccessInfo :: StmtIndex -> RegisterUseM arch ids (MemAccessInfo arch ids)
popAccessInfo :: forall arch ids.
Int -> RegisterUseM arch ids (MemAccessInfo arch ids)
popAccessInfo Int
n = do
  BlockUsageSummary arch ids
s <- ReaderT
  (RegisterUseContext arch)
  (StateT
     (BlockUsageSummary arch ids) (Except (RegisterUseError arch)))
  (BlockUsageSummary arch ids)
forall s (m :: Type -> Type). MonadState s m => m s
get
  case BlockUsageSummary arch ids -> [(Int, MemAccessInfo arch ids)]
forall arch ids.
BlockUsageSummary arch ids -> [(Int, MemAccessInfo arch ids)]
pendingMemAccesses BlockUsageSummary arch ids
s of
    [] -> String -> RegisterUseM arch ids (MemAccessInfo arch ids)
forall a. HasCallStack => String -> a
error String
"popAccessInfo invalid"
    ((Int
i,MemAccessInfo arch ids
a):[(Int, MemAccessInfo arch ids)]
r) -> do
      BlockUsageSummary arch ids
-> ReaderT
     (RegisterUseContext arch)
     (StateT
        (BlockUsageSummary arch ids) (Except (RegisterUseError arch)))
     ()
forall s (m :: Type -> Type). MonadState s m => s -> m ()
put (BlockUsageSummary arch ids
 -> ReaderT
      (RegisterUseContext arch)
      (StateT
         (BlockUsageSummary arch ids) (Except (RegisterUseError arch)))
      ())
-> BlockUsageSummary arch ids
-> ReaderT
     (RegisterUseContext arch)
     (StateT
        (BlockUsageSummary arch ids) (Except (RegisterUseError arch)))
     ()
forall a b. (a -> b) -> a -> b
$! BlockUsageSummary arch ids
s { pendingMemAccesses = r }
      if Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
n then
        Int -> RegisterUseM arch ids (MemAccessInfo arch ids)
forall arch ids.
Int -> RegisterUseM arch ids (MemAccessInfo arch ids)
popAccessInfo Int
n
       else if Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
n then
        String -> RegisterUseM arch ids (MemAccessInfo arch ids)
forall a. HasCallStack => String -> a
error String
"popAccessInfo missing index."
      else
        MemAccessInfo arch ids
-> RegisterUseM arch ids (MemAccessInfo arch ids)
forall a.
a
-> ReaderT
     (RegisterUseContext arch)
     (StateT
        (BlockUsageSummary arch ids) (Except (RegisterUseError arch)))
     a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure MemAccessInfo arch ids
a

demandReadMem :: (MemWidth (ArchAddrWidth arch), OrdF (ArchReg arch))
              => StmtIndex
              -> AssignId ids tp
              -> Value arch ids (BVType (ArchAddrWidth arch))
              -> MemRepr tp
              -> RegisterUseM arch ids ()
demandReadMem :: forall arch ids (tp :: Type).
(MemWidth (ArchAddrWidth arch), OrdF (ArchReg arch)) =>
Int
-> AssignId ids tp
-> Value arch ids (BVType (ArchAddrWidth arch))
-> MemRepr tp
-> RegisterUseM arch ids ()
demandReadMem Int
stmtIdx AssignId ids tp
aid Value arch ids (BVType (ArchAddrWidth arch))
addr MemRepr tp
_repr = do
  MemAccessInfo arch ids
accessInfo <- Int -> RegisterUseM arch ids (MemAccessInfo arch ids)
forall arch ids.
Int -> RegisterUseM arch ids (MemAccessInfo arch ids)
popAccessInfo Int
stmtIdx
  case MemAccessInfo arch ids
accessInfo of
    MemAccessInfo arch ids
NotFrameAccess -> do
      -- Mark that this value depends on both aid and any
      -- dependencies needed to compute the address.
      BlockStartConstraints arch
cns <- (BlockUsageSummary arch ids -> BlockStartConstraints arch)
-> ReaderT
     (RegisterUseContext arch)
     (StateT
        (BlockUsageSummary arch ids) (Except (RegisterUseError arch)))
     (BlockStartConstraints arch)
forall s (m :: Type -> Type) a. MonadState s m => (s -> a) -> m a
gets BlockUsageSummary arch ids -> BlockStartConstraints arch
forall arch ids.
BlockUsageSummary arch ids -> BlockStartConstraints arch
blockUsageStartConstraints
      Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
cache <- (BlockUsageSummary arch ids
 -> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids))
-> ReaderT
     (RegisterUseContext arch)
     (StateT
        (BlockUsageSummary arch ids) (Except (RegisterUseError arch)))
     (Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids))
forall s (m :: Type -> Type) a. MonadState s m => (s -> a) -> m a
gets BlockUsageSummary arch ids
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
forall arch ids.
BlockUsageSummary arch ids
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
assignDeps
      let deps :: DependencySet (ArchReg arch) ids
deps = AssignId ids tp -> DependencySet (ArchReg arch) ids
forall ids (tp :: Type) (r :: Type -> Type).
AssignId ids tp -> DependencySet r ids
assignSet AssignId ids tp
aid DependencySet (ArchReg arch) ids
-> DependencySet (ArchReg arch) ids
-> DependencySet (ArchReg arch) ids
forall a. Semigroup a => a -> a -> a
<> BlockStartConstraints arch
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
-> Value arch ids (BVType (ArchAddrWidth arch))
-> DependencySet (ArchReg arch) ids
forall arch ids (tp :: Type).
(HasCallStack, MemWidth (ArchAddrWidth arch),
 OrdF (ArchReg arch)) =>
BlockStartConstraints arch
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
-> Value arch ids tp
-> DependencySet (ArchReg arch) ids
valueDeps BlockStartConstraints arch
cns Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
cache Value arch ids (BVType (ArchAddrWidth arch))
addr
      AssignId ids tp
-> DependencySet (ArchReg arch) ids -> RegisterUseM arch ids ()
forall arch ids (tp :: Type).
OrdF (ArchReg arch) =>
AssignId ids tp
-> DependencySet (ArchReg arch) ids -> RegisterUseM arch ids ()
requiredAssignDeps AssignId ids tp
aid DependencySet (ArchReg arch) ids
deps
    FrameReadInitAccess MemInt (ArchAddrWidth arch)
_o InitInferValue arch tp
d -> do
      let deps :: DependencySet (ArchReg arch) ids
deps = AssignId ids tp -> DependencySet (ArchReg arch) ids
forall ids (tp :: Type) (r :: Type -> Type).
AssignId ids tp -> DependencySet r ids
assignSet AssignId ids tp
aid DependencySet (ArchReg arch) ids
-> DependencySet (ArchReg arch) ids
-> DependencySet (ArchReg arch) ids
forall a. Semigroup a => a -> a -> a
<> InitInferValue arch tp -> DependencySet (ArchReg arch) ids
forall arch (tp :: Type) ids.
InitInferValue arch tp -> DependencySet (ArchReg arch) ids
domainDeps InitInferValue arch tp
d
      (Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
 -> Identity
      (Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)))
-> BlockUsageSummary arch ids
-> Identity (BlockUsageSummary arch ids)
forall arch ids (f :: Type -> Type).
Functor f =>
(Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
 -> f (Map
         (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)))
-> BlockUsageSummary arch ids -> f (BlockUsageSummary arch ids)
assignmentCache ((Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
  -> Identity
       (Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)))
 -> BlockUsageSummary arch ids
 -> Identity (BlockUsageSummary arch ids))
-> (Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
    -> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids))
-> RegisterUseM arch ids ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= Some (AssignId ids)
-> DependencySet (ArchReg arch) ids
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (AssignId ids tp -> Some (AssignId ids)
forall k (f :: k -> Type) (x :: k). f x -> Some f
Some AssignId ids tp
aid) DependencySet (ArchReg arch) ids
deps
    FrameReadWriteAccess Int
writeIdx -> do
      -- Mark that this value depends on aid and any
      -- dependencies needed to compute the value stored at o.
      Map Int (DependencySet (ArchReg arch) ids)
m <- (BlockUsageSummary arch ids
 -> Map Int (DependencySet (ArchReg arch) ids))
-> ReaderT
     (RegisterUseContext arch)
     (StateT
        (BlockUsageSummary arch ids) (Except (RegisterUseError arch)))
     (Map Int (DependencySet (ArchReg arch) ids))
forall s (m :: Type -> Type) a. MonadState s m => (s -> a) -> m a
gets BlockUsageSummary arch ids
-> Map Int (DependencySet (ArchReg arch) ids)
forall arch ids.
BlockUsageSummary arch ids
-> Map Int (DependencySet (ArchReg arch) ids)
blockWriteDependencies
      let deps :: DependencySet (ArchReg arch) ids
deps = DependencySet (ArchReg arch) ids
-> Int
-> Map Int (DependencySet (ArchReg arch) ids)
-> DependencySet (ArchReg arch) ids
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault (String -> DependencySet (ArchReg arch) ids
forall a. HasCallStack => String -> a
error String
"Could not find write index.") Int
writeIdx Map Int (DependencySet (ArchReg arch) ids)
m
      let allDeps :: DependencySet (ArchReg arch) ids
allDeps = Int
-> DependencySet (ArchReg arch) ids
-> DependencySet (ArchReg arch) ids
forall (r :: Type -> Type) ids.
Int -> DependencySet r ids -> DependencySet r ids
addWriteDep Int
writeIdx (AssignId ids tp -> DependencySet (ArchReg arch) ids
forall ids (tp :: Type) (r :: Type -> Type).
AssignId ids tp -> DependencySet r ids
assignSet AssignId ids tp
aid DependencySet (ArchReg arch) ids
-> DependencySet (ArchReg arch) ids
-> DependencySet (ArchReg arch) ids
forall a. Semigroup a => a -> a -> a
<> DependencySet (ArchReg arch) ids
deps)
      (Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
 -> Identity
      (Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)))
-> BlockUsageSummary arch ids
-> Identity (BlockUsageSummary arch ids)
forall arch ids (f :: Type -> Type).
Functor f =>
(Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
 -> f (Map
         (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)))
-> BlockUsageSummary arch ids -> f (BlockUsageSummary arch ids)
assignmentCache ((Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
  -> Identity
       (Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)))
 -> BlockUsageSummary arch ids
 -> Identity (BlockUsageSummary arch ids))
-> (Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
    -> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids))
-> RegisterUseM arch ids ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= Some (AssignId ids)
-> DependencySet (ArchReg arch) ids
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (AssignId ids tp -> Some (AssignId ids)
forall k (f :: k -> Type) (x :: k). f x -> Some f
Some AssignId ids tp
aid) DependencySet (ArchReg arch) ids
allDeps
    FrameReadOverlapAccess MemInt (ArchAddrWidth arch)
_ -> do
      (Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
 -> Identity
      (Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)))
-> BlockUsageSummary arch ids
-> Identity (BlockUsageSummary arch ids)
forall arch ids (f :: Type -> Type).
Functor f =>
(Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
 -> f (Map
         (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)))
-> BlockUsageSummary arch ids -> f (BlockUsageSummary arch ids)
assignmentCache ((Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
  -> Identity
       (Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)))
 -> BlockUsageSummary arch ids
 -> Identity (BlockUsageSummary arch ids))
-> (Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
    -> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids))
-> RegisterUseM arch ids ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= Some (AssignId ids)
-> DependencySet (ArchReg arch) ids
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (AssignId ids tp -> Some (AssignId ids)
forall k (f :: k -> Type) (x :: k). f x -> Some f
Some AssignId ids tp
aid) (AssignId ids tp -> DependencySet (ArchReg arch) ids
forall ids (tp :: Type) (r :: Type -> Type).
AssignId ids tp -> DependencySet r ids
assignSet AssignId ids tp
aid)
    FrameWriteAccess{} ->
      String -> RegisterUseM arch ids ()
forall a. HasCallStack => String -> a
error String
"Expected read access."
    FrameCondWriteAccess{} ->
      String -> RegisterUseM arch ids ()
forall a. HasCallStack => String -> a
error String
"Expected read access."
    FrameCondWriteOverlapAccess MemInt (ArchAddrWidth arch)
_ ->
      String -> RegisterUseM arch ids ()
forall a. HasCallStack => String -> a
error String
"Expected read access."

demandCondReadMem ::
  (MemWidth (ArchAddrWidth arch), OrdF (ArchReg arch)) =>
  StmtIndex ->
  AssignId ids tp ->
  Value arch ids BoolType ->
  Value arch ids (BVType (ArchAddrWidth arch)) ->
  MemRepr tp ->
  Value arch ids tp ->
  RegisterUseM arch ids ()
demandCondReadMem :: forall arch ids (tp :: Type).
(MemWidth (ArchAddrWidth arch), OrdF (ArchReg arch)) =>
Int
-> AssignId ids tp
-> Value arch ids BoolType
-> Value arch ids (BVType (ArchAddrWidth arch))
-> MemRepr tp
-> Value arch ids tp
-> RegisterUseM arch ids ()
demandCondReadMem Int
stmtIdx AssignId ids tp
aid Value arch ids BoolType
cond Value arch ids (BVType (ArchAddrWidth arch))
addr MemRepr tp
_repr Value arch ids tp
val = do
  MemAccessInfo arch ids
accessInfo <- Int -> RegisterUseM arch ids (MemAccessInfo arch ids)
forall arch ids.
Int -> RegisterUseM arch ids (MemAccessInfo arch ids)
popAccessInfo Int
stmtIdx
  case MemAccessInfo arch ids
accessInfo of
    MemAccessInfo arch ids
NotFrameAccess -> do
      BlockStartConstraints arch
cns   <- (BlockUsageSummary arch ids -> BlockStartConstraints arch)
-> ReaderT
     (RegisterUseContext arch)
     (StateT
        (BlockUsageSummary arch ids) (Except (RegisterUseError arch)))
     (BlockStartConstraints arch)
forall s (m :: Type -> Type) a. MonadState s m => (s -> a) -> m a
gets BlockUsageSummary arch ids -> BlockStartConstraints arch
forall arch ids.
BlockUsageSummary arch ids -> BlockStartConstraints arch
blockUsageStartConstraints
      Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
cache <- (BlockUsageSummary arch ids
 -> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids))
-> ReaderT
     (RegisterUseContext arch)
     (StateT
        (BlockUsageSummary arch ids) (Except (RegisterUseError arch)))
     (Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids))
forall s (m :: Type -> Type) a. MonadState s m => (s -> a) -> m a
gets BlockUsageSummary arch ids
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
forall arch ids.
BlockUsageSummary arch ids
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
assignDeps
      let deps :: DependencySet (ArchReg arch) ids
deps = [DependencySet (ArchReg arch) ids]
-> DependencySet (ArchReg arch) ids
forall a. Monoid a => [a] -> a
mconcat
                    [ AssignId ids tp -> DependencySet (ArchReg arch) ids
forall ids (tp :: Type) (r :: Type -> Type).
AssignId ids tp -> DependencySet r ids
assignSet AssignId ids tp
aid
                    , BlockStartConstraints arch
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
-> Value arch ids BoolType
-> DependencySet (ArchReg arch) ids
forall arch ids (tp :: Type).
(HasCallStack, MemWidth (ArchAddrWidth arch),
 OrdF (ArchReg arch)) =>
BlockStartConstraints arch
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
-> Value arch ids tp
-> DependencySet (ArchReg arch) ids
valueDeps BlockStartConstraints arch
cns Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
cache Value arch ids BoolType
cond
                    , BlockStartConstraints arch
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
-> Value arch ids (BVType (ArchAddrWidth arch))
-> DependencySet (ArchReg arch) ids
forall arch ids (tp :: Type).
(HasCallStack, MemWidth (ArchAddrWidth arch),
 OrdF (ArchReg arch)) =>
BlockStartConstraints arch
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
-> Value arch ids tp
-> DependencySet (ArchReg arch) ids
valueDeps BlockStartConstraints arch
cns Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
cache Value arch ids (BVType (ArchAddrWidth arch))
addr
                    , BlockStartConstraints arch
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
-> Value arch ids tp
-> DependencySet (ArchReg arch) ids
forall arch ids (tp :: Type).
(HasCallStack, MemWidth (ArchAddrWidth arch),
 OrdF (ArchReg arch)) =>
BlockStartConstraints arch
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
-> Value arch ids tp
-> DependencySet (ArchReg arch) ids
valueDeps BlockStartConstraints arch
cns Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
cache Value arch ids tp
val
                    ]
      AssignId ids tp
-> DependencySet (ArchReg arch) ids -> RegisterUseM arch ids ()
forall arch ids (tp :: Type).
OrdF (ArchReg arch) =>
AssignId ids tp
-> DependencySet (ArchReg arch) ids -> RegisterUseM arch ids ()
requiredAssignDeps AssignId ids tp
aid DependencySet (ArchReg arch) ids
deps
      DependencySet (ArchReg arch) ids -> RegisterUseM arch ids ()
forall arch ids.
(HasCallStack, OrdF (ArchReg arch)) =>
DependencySet (ArchReg arch) ids -> RegisterUseM arch ids ()
addDeps (DependencySet (ArchReg arch) ids -> RegisterUseM arch ids ())
-> DependencySet (ArchReg arch) ids -> RegisterUseM arch ids ()
forall a b. (a -> b) -> a -> b
$ AssignId ids tp -> DependencySet (ArchReg arch) ids
forall ids (tp :: Type) (r :: Type -> Type).
AssignId ids tp -> DependencySet r ids
assignSet AssignId ids tp
aid
    FrameReadInitAccess MemInt (ArchAddrWidth arch)
_o InitInferValue arch tp
d -> do
      BlockStartConstraints arch
cns   <- (BlockUsageSummary arch ids -> BlockStartConstraints arch)
-> ReaderT
     (RegisterUseContext arch)
     (StateT
        (BlockUsageSummary arch ids) (Except (RegisterUseError arch)))
     (BlockStartConstraints arch)
forall s (m :: Type -> Type) a. MonadState s m => (s -> a) -> m a
gets BlockUsageSummary arch ids -> BlockStartConstraints arch
forall arch ids.
BlockUsageSummary arch ids -> BlockStartConstraints arch
blockUsageStartConstraints
      Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
cache <- (BlockUsageSummary arch ids
 -> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids))
-> ReaderT
     (RegisterUseContext arch)
     (StateT
        (BlockUsageSummary arch ids) (Except (RegisterUseError arch)))
     (Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids))
forall s (m :: Type -> Type) a. MonadState s m => (s -> a) -> m a
gets BlockUsageSummary arch ids
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
forall arch ids.
BlockUsageSummary arch ids
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
assignDeps
      let deps :: DependencySet (ArchReg arch) ids
deps = [DependencySet (ArchReg arch) ids]
-> DependencySet (ArchReg arch) ids
forall a. Monoid a => [a] -> a
mconcat
                 [ AssignId ids tp -> DependencySet (ArchReg arch) ids
forall ids (tp :: Type) (r :: Type -> Type).
AssignId ids tp -> DependencySet r ids
assignSet AssignId ids tp
aid
                 , BlockStartConstraints arch
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
-> Value arch ids BoolType
-> DependencySet (ArchReg arch) ids
forall arch ids (tp :: Type).
(HasCallStack, MemWidth (ArchAddrWidth arch),
 OrdF (ArchReg arch)) =>
BlockStartConstraints arch
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
-> Value arch ids tp
-> DependencySet (ArchReg arch) ids
valueDeps BlockStartConstraints arch
cns Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
cache Value arch ids BoolType
cond
                 , InitInferValue arch tp -> DependencySet (ArchReg arch) ids
forall arch (tp :: Type) ids.
InitInferValue arch tp -> DependencySet (ArchReg arch) ids
domainDeps InitInferValue arch tp
d
                 , BlockStartConstraints arch
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
-> Value arch ids tp
-> DependencySet (ArchReg arch) ids
forall arch ids (tp :: Type).
(HasCallStack, MemWidth (ArchAddrWidth arch),
 OrdF (ArchReg arch)) =>
BlockStartConstraints arch
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
-> Value arch ids tp
-> DependencySet (ArchReg arch) ids
valueDeps BlockStartConstraints arch
cns Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
cache Value arch ids tp
val
                 ]
      (Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
 -> Identity
      (Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)))
-> BlockUsageSummary arch ids
-> Identity (BlockUsageSummary arch ids)
forall arch ids (f :: Type -> Type).
Functor f =>
(Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
 -> f (Map
         (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)))
-> BlockUsageSummary arch ids -> f (BlockUsageSummary arch ids)
assignmentCache ((Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
  -> Identity
       (Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)))
 -> BlockUsageSummary arch ids
 -> Identity (BlockUsageSummary arch ids))
-> (Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
    -> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids))
-> RegisterUseM arch ids ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= Some (AssignId ids)
-> DependencySet (ArchReg arch) ids
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (AssignId ids tp -> Some (AssignId ids)
forall k (f :: k -> Type) (x :: k). f x -> Some f
Some AssignId ids tp
aid) DependencySet (ArchReg arch) ids
deps
    FrameReadWriteAccess Int
writeIdx -> do
      BlockStartConstraints arch
cns <- (BlockUsageSummary arch ids -> BlockStartConstraints arch)
-> ReaderT
     (RegisterUseContext arch)
     (StateT
        (BlockUsageSummary arch ids) (Except (RegisterUseError arch)))
     (BlockStartConstraints arch)
forall s (m :: Type -> Type) a. MonadState s m => (s -> a) -> m a
gets BlockUsageSummary arch ids -> BlockStartConstraints arch
forall arch ids.
BlockUsageSummary arch ids -> BlockStartConstraints arch
blockUsageStartConstraints
      Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
cache <- (BlockUsageSummary arch ids
 -> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids))
-> ReaderT
     (RegisterUseContext arch)
     (StateT
        (BlockUsageSummary arch ids) (Except (RegisterUseError arch)))
     (Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids))
forall s (m :: Type -> Type) a. MonadState s m => (s -> a) -> m a
gets BlockUsageSummary arch ids
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
forall arch ids.
BlockUsageSummary arch ids
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
assignDeps
      -- Mark that this value depends on aid and any dependencies
      -- needed to compute the value stored at o.
      Map Int (DependencySet (ArchReg arch) ids)
m <- (BlockUsageSummary arch ids
 -> Map Int (DependencySet (ArchReg arch) ids))
-> ReaderT
     (RegisterUseContext arch)
     (StateT
        (BlockUsageSummary arch ids) (Except (RegisterUseError arch)))
     (Map Int (DependencySet (ArchReg arch) ids))
forall s (m :: Type -> Type) a. MonadState s m => (s -> a) -> m a
gets BlockUsageSummary arch ids
-> Map Int (DependencySet (ArchReg arch) ids)
forall arch ids.
BlockUsageSummary arch ids
-> Map Int (DependencySet (ArchReg arch) ids)
blockWriteDependencies
      let deps :: DependencySet (ArchReg arch) ids
deps = DependencySet (ArchReg arch) ids
-> Int
-> Map Int (DependencySet (ArchReg arch) ids)
-> DependencySet (ArchReg arch) ids
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault (String -> DependencySet (ArchReg arch) ids
forall a. HasCallStack => String -> a
error String
"Could not find write index.") Int
writeIdx Map Int (DependencySet (ArchReg arch) ids)
m
      let allDeps :: DependencySet (ArchReg arch) ids
allDeps = Int
-> DependencySet (ArchReg arch) ids
-> DependencySet (ArchReg arch) ids
forall (r :: Type -> Type) ids.
Int -> DependencySet r ids -> DependencySet r ids
addWriteDep Int
writeIdx (DependencySet (ArchReg arch) ids
 -> DependencySet (ArchReg arch) ids)
-> DependencySet (ArchReg arch) ids
-> DependencySet (ArchReg arch) ids
forall a b. (a -> b) -> a -> b
$
                    [DependencySet (ArchReg arch) ids]
-> DependencySet (ArchReg arch) ids
forall a. Monoid a => [a] -> a
mconcat [ AssignId ids tp -> DependencySet (ArchReg arch) ids
forall ids (tp :: Type) (r :: Type -> Type).
AssignId ids tp -> DependencySet r ids
assignSet AssignId ids tp
aid
                            , BlockStartConstraints arch
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
-> Value arch ids BoolType
-> DependencySet (ArchReg arch) ids
forall arch ids (tp :: Type).
(HasCallStack, MemWidth (ArchAddrWidth arch),
 OrdF (ArchReg arch)) =>
BlockStartConstraints arch
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
-> Value arch ids tp
-> DependencySet (ArchReg arch) ids
valueDeps BlockStartConstraints arch
cns Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
cache Value arch ids BoolType
cond
                            , DependencySet (ArchReg arch) ids
deps
                            , BlockStartConstraints arch
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
-> Value arch ids tp
-> DependencySet (ArchReg arch) ids
forall arch ids (tp :: Type).
(HasCallStack, MemWidth (ArchAddrWidth arch),
 OrdF (ArchReg arch)) =>
BlockStartConstraints arch
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
-> Value arch ids tp
-> DependencySet (ArchReg arch) ids
valueDeps BlockStartConstraints arch
cns Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
cache Value arch ids tp
val
                            ]
      (Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
 -> Identity
      (Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)))
-> BlockUsageSummary arch ids
-> Identity (BlockUsageSummary arch ids)
forall arch ids (f :: Type -> Type).
Functor f =>
(Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
 -> f (Map
         (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)))
-> BlockUsageSummary arch ids -> f (BlockUsageSummary arch ids)
assignmentCache ((Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
  -> Identity
       (Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)))
 -> BlockUsageSummary arch ids
 -> Identity (BlockUsageSummary arch ids))
-> (Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
    -> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids))
-> RegisterUseM arch ids ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= Some (AssignId ids)
-> DependencySet (ArchReg arch) ids
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (AssignId ids tp -> Some (AssignId ids)
forall k (f :: k -> Type) (x :: k). f x -> Some f
Some AssignId ids tp
aid) DependencySet (ArchReg arch) ids
allDeps
    FrameReadOverlapAccess MemInt (ArchAddrWidth arch)
_ -> do
      (Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
 -> Identity
      (Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)))
-> BlockUsageSummary arch ids
-> Identity (BlockUsageSummary arch ids)
forall arch ids (f :: Type -> Type).
Functor f =>
(Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
 -> f (Map
         (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)))
-> BlockUsageSummary arch ids -> f (BlockUsageSummary arch ids)
assignmentCache ((Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
  -> Identity
       (Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)))
 -> BlockUsageSummary arch ids
 -> Identity (BlockUsageSummary arch ids))
-> (Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
    -> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids))
-> RegisterUseM arch ids ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= Some (AssignId ids)
-> DependencySet (ArchReg arch) ids
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (AssignId ids tp -> Some (AssignId ids)
forall k (f :: k -> Type) (x :: k). f x -> Some f
Some AssignId ids tp
aid) (AssignId ids tp -> DependencySet (ArchReg arch) ids
forall ids (tp :: Type) (r :: Type -> Type).
AssignId ids tp -> DependencySet r ids
assignSet AssignId ids tp
aid)
    FrameWriteAccess{} ->
      String -> RegisterUseM arch ids ()
forall a. HasCallStack => String -> a
error String
"Expected read access."
    FrameCondWriteAccess{} ->
      String -> RegisterUseM arch ids ()
forall a. HasCallStack => String -> a
error String
"Expected read access."
    FrameCondWriteOverlapAccess{} ->
      String -> RegisterUseM arch ids ()
forall a. HasCallStack => String -> a
error String
"Expected read access."

inferStackValueDeps :: (HasCallStack, MemWidth (ArchAddrWidth arch), OrdF (ArchReg arch))
                    => BlockStartConstraints arch
                    -> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
                    -> InferStackValue arch ids tp
                    -> DependencySet (ArchReg arch) ids
inferStackValueDeps :: forall arch ids (tp :: Type).
(HasCallStack, MemWidth (ArchAddrWidth arch),
 OrdF (ArchReg arch)) =>
BlockStartConstraints arch
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
-> InferStackValue arch ids tp
-> DependencySet (ArchReg arch) ids
inferStackValueDeps BlockStartConstraints arch
cns Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
amap InferStackValue arch ids tp
isv =
  case InferStackValue arch ids tp
isv of
    ISVInitValue InitInferValue arch tp
d -> InitInferValue arch tp -> DependencySet (ArchReg arch) ids
forall arch (tp :: Type) ids.
InitInferValue arch tp -> DependencySet (ArchReg arch) ids
domainDeps InitInferValue arch tp
d
    ISVWrite Int
idx Value arch ids tp
v -> Int
-> DependencySet (ArchReg arch) ids
-> DependencySet (ArchReg arch) ids
forall (r :: Type -> Type) ids.
Int -> DependencySet r ids -> DependencySet r ids
addWriteDep Int
idx (BlockStartConstraints arch
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
-> Value arch ids tp
-> DependencySet (ArchReg arch) ids
forall arch ids (tp :: Type).
(HasCallStack, MemWidth (ArchAddrWidth arch),
 OrdF (ArchReg arch)) =>
BlockStartConstraints arch
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
-> Value arch ids tp
-> DependencySet (ArchReg arch) ids
valueDeps BlockStartConstraints arch
cns Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
amap Value arch ids tp
v)
    ISVCondWrite Int
idx Value arch ids BoolType
c Value arch ids tp
v InferStackValue arch ids tp
prevVal -> Int
-> DependencySet (ArchReg arch) ids
-> DependencySet (ArchReg arch) ids
forall (r :: Type -> Type) ids.
Int -> DependencySet r ids -> DependencySet r ids
addWriteDep Int
idx (DependencySet (ArchReg arch) ids
 -> DependencySet (ArchReg arch) ids)
-> DependencySet (ArchReg arch) ids
-> DependencySet (ArchReg arch) ids
forall a b. (a -> b) -> a -> b
$
      [DependencySet (ArchReg arch) ids]
-> DependencySet (ArchReg arch) ids
forall a. Monoid a => [a] -> a
mconcat [ BlockStartConstraints arch
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
-> Value arch ids BoolType
-> DependencySet (ArchReg arch) ids
forall arch ids (tp :: Type).
(HasCallStack, MemWidth (ArchAddrWidth arch),
 OrdF (ArchReg arch)) =>
BlockStartConstraints arch
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
-> Value arch ids tp
-> DependencySet (ArchReg arch) ids
valueDeps BlockStartConstraints arch
cns Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
amap Value arch ids BoolType
c
              , BlockStartConstraints arch
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
-> Value arch ids tp
-> DependencySet (ArchReg arch) ids
forall arch ids (tp :: Type).
(HasCallStack, MemWidth (ArchAddrWidth arch),
 OrdF (ArchReg arch)) =>
BlockStartConstraints arch
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
-> Value arch ids tp
-> DependencySet (ArchReg arch) ids
valueDeps BlockStartConstraints arch
cns Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
amap Value arch ids tp
v
              , BlockStartConstraints arch
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
-> InferStackValue arch ids tp
-> DependencySet (ArchReg arch) ids
forall arch ids (tp :: Type).
(HasCallStack, MemWidth (ArchAddrWidth arch),
 OrdF (ArchReg arch)) =>
BlockStartConstraints arch
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
-> InferStackValue arch ids tp
-> DependencySet (ArchReg arch) ids
inferStackValueDeps BlockStartConstraints arch
cns Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
amap InferStackValue arch ids tp
prevVal
              ]

demandAssign ::
  ( MemWidth (ArchAddrWidth arch),
    OrdF (ArchReg arch),
    FoldableFC (ArchFn arch)
  ) =>
  StmtIndex ->
  Assignment arch ids tp ->
  RegisterUseM arch ids ()
demandAssign :: forall arch ids (tp :: Type).
(MemWidth (ArchAddrWidth arch), OrdF (ArchReg arch),
 FoldableFC (ArchFn arch)) =>
Int -> Assignment arch ids tp -> RegisterUseM arch ids ()
demandAssign Int
stmtIdx (Assignment AssignId ids tp
aid AssignRhs arch (Value arch ids) tp
arhs) = do
  InferState arch ids
sis <- (BlockUsageSummary arch ids -> InferState arch ids)
-> ReaderT
     (RegisterUseContext arch)
     (StateT
        (BlockUsageSummary arch ids) (Except (RegisterUseError arch)))
     (InferState arch ids)
forall s (m :: Type -> Type) a. MonadState s m => (s -> a) -> m a
gets BlockUsageSummary arch ids -> InferState arch ids
forall arch ids. BlockUsageSummary arch ids -> InferState arch ids
blockInferState
  case AssignId ids tp
-> MapF (AssignId ids) (BlockInferValue arch ids)
-> Maybe (BlockInferValue arch ids tp)
forall {v} (k :: v -> Type) (tp :: v) (a :: v -> Type).
OrdF k =>
k tp -> MapF k a -> Maybe (a tp)
MapF.lookup AssignId ids tp
aid (InferState arch ids
-> MapF (AssignId ids) (BlockInferValue arch ids)
forall arch ids.
InferState arch ids
-> MapF (AssignId ids) (BlockInferValue arch ids)
sisAssignMap InferState arch ids
sis) of
    Just (IVDomain InitInferValue arch wtp
d MemSlice wtp tp
_) -> do
      (Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
 -> Identity
      (Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)))
-> BlockUsageSummary arch ids
-> Identity (BlockUsageSummary arch ids)
forall arch ids (f :: Type -> Type).
Functor f =>
(Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
 -> f (Map
         (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)))
-> BlockUsageSummary arch ids -> f (BlockUsageSummary arch ids)
assignmentCache ((Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
  -> Identity
       (Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)))
 -> BlockUsageSummary arch ids
 -> Identity (BlockUsageSummary arch ids))
-> (Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
    -> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids))
-> RegisterUseM arch ids ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= Some (AssignId ids)
-> DependencySet (ArchReg arch) ids
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (AssignId ids tp -> Some (AssignId ids)
forall k (f :: k -> Type) (x :: k). f x -> Some f
Some AssignId ids tp
aid) (InitInferValue arch wtp -> DependencySet (ArchReg arch) ids
forall arch (tp :: Type) ids.
InitInferValue arch tp -> DependencySet (ArchReg arch) ids
domainDeps InitInferValue arch wtp
d)
    Just (IVAssignValue AssignId ids tp
a) -> do
      Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
dm <- (BlockUsageSummary arch ids
 -> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids))
-> ReaderT
     (RegisterUseContext arch)
     (StateT
        (BlockUsageSummary arch ids) (Except (RegisterUseError arch)))
     (Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids))
forall s (m :: Type -> Type) a. MonadState s m => (s -> a) -> m a
gets BlockUsageSummary arch ids
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
forall arch ids.
BlockUsageSummary arch ids
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
assignDeps
      case Some (AssignId ids)
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
-> Maybe (DependencySet (ArchReg arch) ids)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (AssignId ids tp -> Some (AssignId ids)
forall k (f :: k -> Type) (x :: k). f x -> Some f
Some AssignId ids tp
a) Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
dm of
        Maybe (DependencySet (ArchReg arch) ids)
Nothing -> String -> RegisterUseM arch ids ()
forall a. HasCallStack => String -> a
error (String -> RegisterUseM arch ids ())
-> String -> RegisterUseM arch ids ()
forall a b. (a -> b) -> a -> b
$ String
"Assignment " String -> ShowS
forall a. [a] -> [a] -> [a]
++ AssignId ids tp -> String
forall a. Show a => a -> String
show AssignId ids tp
a String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" is not defined."
        Just DependencySet (ArchReg arch) ids
deps -> (Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
 -> Identity
      (Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)))
-> BlockUsageSummary arch ids
-> Identity (BlockUsageSummary arch ids)
forall arch ids (f :: Type -> Type).
Functor f =>
(Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
 -> f (Map
         (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)))
-> BlockUsageSummary arch ids -> f (BlockUsageSummary arch ids)
assignmentCache ((Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
  -> Identity
       (Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)))
 -> BlockUsageSummary arch ids
 -> Identity (BlockUsageSummary arch ids))
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
-> RegisterUseM arch ids ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Some (AssignId ids)
-> DependencySet (ArchReg arch) ids
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (AssignId ids tp -> Some (AssignId ids)
forall k (f :: k -> Type) (x :: k). f x -> Some f
Some AssignId ids tp
aid) DependencySet (ArchReg arch) ids
deps Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
dm
    Just (IVCValue CValue arch tp
_) -> do
      (Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
 -> Identity
      (Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)))
-> BlockUsageSummary arch ids
-> Identity (BlockUsageSummary arch ids)
forall arch ids (f :: Type -> Type).
Functor f =>
(Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
 -> f (Map
         (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)))
-> BlockUsageSummary arch ids -> f (BlockUsageSummary arch ids)
assignmentCache ((Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
  -> Identity
       (Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)))
 -> BlockUsageSummary arch ids
 -> Identity (BlockUsageSummary arch ids))
-> (Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
    -> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids))
-> RegisterUseM arch ids ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= Some (AssignId ids)
-> DependencySet (ArchReg arch) ids
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (AssignId ids tp -> Some (AssignId ids)
forall k (f :: k -> Type) (x :: k). f x -> Some f
Some AssignId ids tp
aid) DependencySet (ArchReg arch) ids
forall (r :: Type -> Type) ids. DependencySet r ids
emptyDeps
    Maybe (BlockInferValue arch ids tp)
_ -> do
      case AssignRhs arch (Value arch ids) tp
arhs of
        EvalApp App (Value arch ids) tp
app -> do
          BlockStartConstraints arch
cns <- (BlockUsageSummary arch ids -> BlockStartConstraints arch)
-> ReaderT
     (RegisterUseContext arch)
     (StateT
        (BlockUsageSummary arch ids) (Except (RegisterUseError arch)))
     (BlockStartConstraints arch)
forall s (m :: Type -> Type) a. MonadState s m => (s -> a) -> m a
gets BlockUsageSummary arch ids -> BlockStartConstraints arch
forall arch ids.
BlockUsageSummary arch ids -> BlockStartConstraints arch
blockUsageStartConstraints
          Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
cache <- (BlockUsageSummary arch ids
 -> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids))
-> ReaderT
     (RegisterUseContext arch)
     (StateT
        (BlockUsageSummary arch ids) (Except (RegisterUseError arch)))
     (Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids))
forall s (m :: Type -> Type) a. MonadState s m => (s -> a) -> m a
gets BlockUsageSummary arch ids
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
forall arch ids.
BlockUsageSummary arch ids
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
assignDeps
          let deps :: DependencySet (ArchReg arch) ids
deps = (forall (x :: Type).
 DependencySet (ArchReg arch) ids
 -> Value arch ids x -> DependencySet (ArchReg arch) ids)
-> forall (x :: Type).
   DependencySet (ArchReg arch) ids
   -> App (Value arch ids) x -> DependencySet (ArchReg arch) ids
forall k l (t :: (k -> Type) -> l -> Type) (f :: k -> Type) b.
FoldableFC t =>
(forall (x :: k). b -> f x -> b)
-> forall (x :: l). b -> t f x -> b
forall (f :: Type -> Type) b.
(forall (x :: Type). b -> f x -> b)
-> forall (x :: Type). b -> App f x -> b
foldlFC' (\DependencySet (ArchReg arch) ids
s Value arch ids x
v -> DependencySet (ArchReg arch) ids
-> DependencySet (ArchReg arch) ids
-> DependencySet (ArchReg arch) ids
forall a. Monoid a => a -> a -> a
mappend DependencySet (ArchReg arch) ids
s (BlockStartConstraints arch
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
-> Value arch ids x
-> DependencySet (ArchReg arch) ids
forall arch ids (tp :: Type).
(HasCallStack, MemWidth (ArchAddrWidth arch),
 OrdF (ArchReg arch)) =>
BlockStartConstraints arch
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
-> Value arch ids tp
-> DependencySet (ArchReg arch) ids
valueDeps BlockStartConstraints arch
cns Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
cache Value arch ids x
v)) (AssignId ids tp -> DependencySet (ArchReg arch) ids
forall ids (tp :: Type) (r :: Type -> Type).
AssignId ids tp -> DependencySet r ids
assignSet AssignId ids tp
aid) App (Value arch ids) tp
app
          (Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
 -> Identity
      (Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)))
-> BlockUsageSummary arch ids
-> Identity (BlockUsageSummary arch ids)
forall arch ids (f :: Type -> Type).
Functor f =>
(Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
 -> f (Map
         (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)))
-> BlockUsageSummary arch ids -> f (BlockUsageSummary arch ids)
assignmentCache ((Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
  -> Identity
       (Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)))
 -> BlockUsageSummary arch ids
 -> Identity (BlockUsageSummary arch ids))
-> (Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
    -> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids))
-> RegisterUseM arch ids ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= Some (AssignId ids)
-> DependencySet (ArchReg arch) ids
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (AssignId ids tp -> Some (AssignId ids)
forall k (f :: k -> Type) (x :: k). f x -> Some f
Some AssignId ids tp
aid) DependencySet (ArchReg arch) ids
deps
        SetUndefined{} -> do
          (Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
 -> Identity
      (Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)))
-> BlockUsageSummary arch ids
-> Identity (BlockUsageSummary arch ids)
forall arch ids (f :: Type -> Type).
Functor f =>
(Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
 -> f (Map
         (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)))
-> BlockUsageSummary arch ids -> f (BlockUsageSummary arch ids)
assignmentCache ((Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
  -> Identity
       (Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)))
 -> BlockUsageSummary arch ids
 -> Identity (BlockUsageSummary arch ids))
-> (Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
    -> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids))
-> RegisterUseM arch ids ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= Some (AssignId ids)
-> DependencySet (ArchReg arch) ids
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (AssignId ids tp -> Some (AssignId ids)
forall k (f :: k -> Type) (x :: k). f x -> Some f
Some AssignId ids tp
aid) (AssignId ids tp -> DependencySet (ArchReg arch) ids
forall ids (tp :: Type) (r :: Type -> Type).
AssignId ids tp -> DependencySet r ids
assignSet AssignId ids tp
aid)
        ReadMem Value arch ids (BVType (ArchAddrWidth arch))
addr MemRepr tp
repr -> do
          Int
-> AssignId ids tp
-> Value arch ids (BVType (ArchAddrWidth arch))
-> MemRepr tp
-> RegisterUseM arch ids ()
forall arch ids (tp :: Type).
(MemWidth (ArchAddrWidth arch), OrdF (ArchReg arch)) =>
Int
-> AssignId ids tp
-> Value arch ids (BVType (ArchAddrWidth arch))
-> MemRepr tp
-> RegisterUseM arch ids ()
demandReadMem Int
stmtIdx AssignId ids tp
aid Value arch ids (BVType (ArchAddrWidth arch))
addr MemRepr tp
repr
        CondReadMem MemRepr tp
repr Value arch ids BoolType
c Value arch ids (BVType (ArchAddrWidth arch))
addr Value arch ids tp
val -> do
          Int
-> AssignId ids tp
-> Value arch ids BoolType
-> Value arch ids (BVType (ArchAddrWidth arch))
-> MemRepr tp
-> Value arch ids tp
-> RegisterUseM arch ids ()
forall arch ids (tp :: Type).
(MemWidth (ArchAddrWidth arch), OrdF (ArchReg arch)) =>
Int
-> AssignId ids tp
-> Value arch ids BoolType
-> Value arch ids (BVType (ArchAddrWidth arch))
-> MemRepr tp
-> Value arch ids tp
-> RegisterUseM arch ids ()
demandCondReadMem Int
stmtIdx AssignId ids tp
aid Value arch ids BoolType
c Value arch ids (BVType (ArchAddrWidth arch))
addr MemRepr tp
repr Value arch ids tp
val
        EvalArchFn ArchFn arch (Value arch ids) tp
fn TypeRepr tp
_ -> do
          DemandContext arch
ctx <- (RegisterUseContext arch -> DemandContext arch)
-> ReaderT
     (RegisterUseContext arch)
     (StateT
        (BlockUsageSummary arch ids) (Except (RegisterUseError arch)))
     (DemandContext arch)
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks RegisterUseContext arch -> DemandContext arch
forall arch. RegisterUseContext arch -> DemandContext arch
demandContext
          BlockStartConstraints arch
cns <- (BlockUsageSummary arch ids -> BlockStartConstraints arch)
-> ReaderT
     (RegisterUseContext arch)
     (StateT
        (BlockUsageSummary arch ids) (Except (RegisterUseError arch)))
     (BlockStartConstraints arch)
forall s (m :: Type -> Type) a. MonadState s m => (s -> a) -> m a
gets BlockUsageSummary arch ids -> BlockStartConstraints arch
forall arch ids.
BlockUsageSummary arch ids -> BlockStartConstraints arch
blockUsageStartConstraints
          Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
cache <- (BlockUsageSummary arch ids
 -> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids))
-> ReaderT
     (RegisterUseContext arch)
     (StateT
        (BlockUsageSummary arch ids) (Except (RegisterUseError arch)))
     (Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids))
forall s (m :: Type -> Type) a. MonadState s m => (s -> a) -> m a
gets BlockUsageSummary arch ids
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
forall arch ids.
BlockUsageSummary arch ids
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
assignDeps
          let deps :: DependencySet (ArchReg arch) ids
deps = (forall (x :: Type).
 DependencySet (ArchReg arch) ids
 -> Value arch ids x -> DependencySet (ArchReg arch) ids)
-> forall (x :: Type).
   DependencySet (ArchReg arch) ids
   -> ArchFn arch (Value arch ids) x
   -> DependencySet (ArchReg arch) ids
forall k l (t :: (k -> Type) -> l -> Type) (f :: k -> Type) b.
FoldableFC t =>
(forall (x :: k). b -> f x -> b)
-> forall (x :: l). b -> t f x -> b
forall (f :: Type -> Type) b.
(forall (x :: Type). b -> f x -> b)
-> forall (x :: Type). b -> ArchFn arch f x -> b
foldlFC' (\DependencySet (ArchReg arch) ids
s Value arch ids x
v -> DependencySet (ArchReg arch) ids
-> DependencySet (ArchReg arch) ids
-> DependencySet (ArchReg arch) ids
forall a. Monoid a => a -> a -> a
mappend DependencySet (ArchReg arch) ids
s (BlockStartConstraints arch
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
-> Value arch ids x
-> DependencySet (ArchReg arch) ids
forall arch ids (tp :: Type).
(HasCallStack, MemWidth (ArchAddrWidth arch),
 OrdF (ArchReg arch)) =>
BlockStartConstraints arch
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
-> Value arch ids tp
-> DependencySet (ArchReg arch) ids
valueDeps BlockStartConstraints arch
cns Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
cache Value arch ids x
v)) (AssignId ids tp -> DependencySet (ArchReg arch) ids
forall ids (tp :: Type) (r :: Type -> Type).
AssignId ids tp -> DependencySet r ids
assignSet AssignId ids tp
aid) ArchFn arch (Value arch ids) tp
fn
          if DemandContext arch
-> forall (v :: Type -> Type) (tp :: Type).
   ArchFn arch v tp -> Bool
forall arch.
DemandContext arch
-> forall (v :: Type -> Type) (tp :: Type).
   ArchFn arch v tp -> Bool
archFnHasSideEffects DemandContext arch
ctx ArchFn arch (Value arch ids) tp
fn then do
            AssignId ids tp
-> DependencySet (ArchReg arch) ids -> RegisterUseM arch ids ()
forall arch ids (tp :: Type).
OrdF (ArchReg arch) =>
AssignId ids tp
-> DependencySet (ArchReg arch) ids -> RegisterUseM arch ids ()
requiredAssignDeps AssignId ids tp
aid DependencySet (ArchReg arch) ids
deps
           else
            (Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
 -> Identity
      (Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)))
-> BlockUsageSummary arch ids
-> Identity (BlockUsageSummary arch ids)
forall arch ids (f :: Type -> Type).
Functor f =>
(Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
 -> f (Map
         (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)))
-> BlockUsageSummary arch ids -> f (BlockUsageSummary arch ids)
assignmentCache ((Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
  -> Identity
       (Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)))
 -> BlockUsageSummary arch ids
 -> Identity (BlockUsageSummary arch ids))
-> (Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
    -> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids))
-> RegisterUseM arch ids ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= Some (AssignId ids)
-> DependencySet (ArchReg arch) ids
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (AssignId ids tp -> Some (AssignId ids)
forall k (f :: k -> Type) (x :: k). f x -> Some f
Some AssignId ids tp
aid) DependencySet (ArchReg arch) ids
deps

-- | Return values that must be evaluated to execute side effects.
demandStmtValues ::
  ( HasCallStack,
    OrdF (ArchReg arch),
    MemWidth (ArchAddrWidth arch),
    ShowF (ArchReg arch),
    FoldableFC (ArchFn arch),
    FoldableF (ArchStmt arch)
  ) =>
  -- | Index of statement we are processing.
  StmtIndex ->
  -- | Statement we want to demand.
  Stmt arch ids ->
  RegisterUseM arch ids ()
demandStmtValues :: forall arch ids.
(HasCallStack, OrdF (ArchReg arch), MemWidth (ArchAddrWidth arch),
 ShowF (ArchReg arch), FoldableFC (ArchFn arch),
 FoldableF (ArchStmt arch)) =>
Int -> Stmt arch ids -> RegisterUseM arch ids ()
demandStmtValues Int
stmtIdx Stmt arch ids
stmt = do
  case Stmt arch ids
stmt of
   AssignStmt Assignment arch ids tp
a -> Int -> Assignment arch ids tp -> RegisterUseM arch ids ()
forall arch ids (tp :: Type).
(MemWidth (ArchAddrWidth arch), OrdF (ArchReg arch),
 FoldableFC (ArchFn arch)) =>
Int -> Assignment arch ids tp -> RegisterUseM arch ids ()
demandAssign Int
stmtIdx Assignment arch ids tp
a
   WriteMem ArchAddrValue arch ids
addr MemRepr tp
_repr Value arch ids tp
val -> do
     MemAccessInfo arch ids
accessInfo <- Int -> RegisterUseM arch ids (MemAccessInfo arch ids)
forall arch ids.
Int -> RegisterUseM arch ids (MemAccessInfo arch ids)
popAccessInfo Int
stmtIdx
     case MemAccessInfo arch ids
accessInfo of
       MemAccessInfo arch ids
NotFrameAccess -> do
         ArchAddrValue arch ids -> RegisterUseM arch ids ()
forall arch ids (tp :: Type).
(HasCallStack, MemWidth (ArchAddrWidth arch),
 OrdF (ArchReg arch)) =>
Value arch ids tp -> RegisterUseM arch ids ()
demandValue ArchAddrValue arch ids
addr
         Value arch ids tp -> RegisterUseM arch ids ()
forall arch ids (tp :: Type).
(HasCallStack, MemWidth (ArchAddrWidth arch),
 OrdF (ArchReg arch)) =>
Value arch ids tp -> RegisterUseM arch ids ()
demandValue Value arch ids tp
val
       FrameReadInitAccess{}    -> String -> RegisterUseM arch ids ()
forall a. HasCallStack => String -> a
error String
"Expected write access"
       FrameReadWriteAccess{}   -> String -> RegisterUseM arch ids ()
forall a. HasCallStack => String -> a
error String
"Expected write access"
       FrameReadOverlapAccess{} -> String -> RegisterUseM arch ids ()
forall a. HasCallStack => String -> a
error String
"Expected write access"
       FrameWriteAccess MemInt (ArchAddrWidth arch)
_o -> do
         BlockStartConstraints arch
cns <- (BlockUsageSummary arch ids -> BlockStartConstraints arch)
-> ReaderT
     (RegisterUseContext arch)
     (StateT
        (BlockUsageSummary arch ids) (Except (RegisterUseError arch)))
     (BlockStartConstraints arch)
forall s (m :: Type -> Type) a. MonadState s m => (s -> a) -> m a
gets BlockUsageSummary arch ids -> BlockStartConstraints arch
forall arch ids.
BlockUsageSummary arch ids -> BlockStartConstraints arch
blockUsageStartConstraints
         Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
cache <- (BlockUsageSummary arch ids
 -> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids))
-> ReaderT
     (RegisterUseContext arch)
     (StateT
        (BlockUsageSummary arch ids) (Except (RegisterUseError arch)))
     (Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids))
forall s (m :: Type -> Type) a. MonadState s m => (s -> a) -> m a
gets BlockUsageSummary arch ids
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
forall arch ids.
BlockUsageSummary arch ids
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
assignDeps
         let valDeps :: DependencySet (ArchReg arch) ids
valDeps = Int
-> DependencySet (ArchReg arch) ids
-> DependencySet (ArchReg arch) ids
forall (r :: Type -> Type) ids.
Int -> DependencySet r ids -> DependencySet r ids
addWriteDep Int
stmtIdx (BlockStartConstraints arch
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
-> Value arch ids tp
-> DependencySet (ArchReg arch) ids
forall arch ids (tp :: Type).
(HasCallStack, MemWidth (ArchAddrWidth arch),
 OrdF (ArchReg arch)) =>
BlockStartConstraints arch
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
-> Value arch ids tp
-> DependencySet (ArchReg arch) ids
valueDeps BlockStartConstraints arch
cns Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
cache Value arch ids tp
val)
         (Map Int (DependencySet (ArchReg arch) ids)
 -> Identity (Map Int (DependencySet (ArchReg arch) ids)))
-> BlockUsageSummary arch ids
-> Identity (BlockUsageSummary arch ids)
forall arch ids (f :: Type -> Type).
Functor f =>
(Map Int (DependencySet (ArchReg arch) ids)
 -> f (Map Int (DependencySet (ArchReg arch) ids)))
-> BlockUsageSummary arch ids -> f (BlockUsageSummary arch ids)
blockWriteDependencyLens ((Map Int (DependencySet (ArchReg arch) ids)
  -> Identity (Map Int (DependencySet (ArchReg arch) ids)))
 -> BlockUsageSummary arch ids
 -> Identity (BlockUsageSummary arch ids))
-> (Map Int (DependencySet (ArchReg arch) ids)
    -> Map Int (DependencySet (ArchReg arch) ids))
-> RegisterUseM arch ids ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= Int
-> DependencySet (ArchReg arch) ids
-> Map Int (DependencySet (ArchReg arch) ids)
-> Map Int (DependencySet (ArchReg arch) ids)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Int
stmtIdx DependencySet (ArchReg arch) ids
valDeps
       FrameCondWriteAccess{} -> String -> RegisterUseM arch ids ()
forall a. HasCallStack => String -> a
error String
"Expected write access."
       FrameCondWriteOverlapAccess{} -> String -> RegisterUseM arch ids ()
forall a. HasCallStack => String -> a
error String
"Expected write access."
   CondWriteMem Value arch ids BoolType
c ArchAddrValue arch ids
addr MemRepr tp
_repr Value arch ids tp
val -> do
     MemAccessInfo arch ids
accessInfo <- Int -> RegisterUseM arch ids (MemAccessInfo arch ids)
forall arch ids.
Int -> RegisterUseM arch ids (MemAccessInfo arch ids)
popAccessInfo Int
stmtIdx
     case MemAccessInfo arch ids
accessInfo of
       MemAccessInfo arch ids
NotFrameAccess -> do
         Value arch ids BoolType -> RegisterUseM arch ids ()
forall arch ids (tp :: Type).
(HasCallStack, MemWidth (ArchAddrWidth arch),
 OrdF (ArchReg arch)) =>
Value arch ids tp -> RegisterUseM arch ids ()
demandValue Value arch ids BoolType
c
         ArchAddrValue arch ids -> RegisterUseM arch ids ()
forall arch ids (tp :: Type).
(HasCallStack, MemWidth (ArchAddrWidth arch),
 OrdF (ArchReg arch)) =>
Value arch ids tp -> RegisterUseM arch ids ()
demandValue ArchAddrValue arch ids
addr
         Value arch ids tp -> RegisterUseM arch ids ()
forall arch ids (tp :: Type).
(HasCallStack, MemWidth (ArchAddrWidth arch),
 OrdF (ArchReg arch)) =>
Value arch ids tp -> RegisterUseM arch ids ()
demandValue Value arch ids tp
val
       FrameReadInitAccess{} -> String -> RegisterUseM arch ids ()
forall a. HasCallStack => String -> a
error String
"Expected conditional write access"
       FrameReadWriteAccess{} -> String -> RegisterUseM arch ids ()
forall a. HasCallStack => String -> a
error String
"Expected conditional write access"
       FrameReadOverlapAccess{} -> String -> RegisterUseM arch ids ()
forall a. HasCallStack => String -> a
error String
"Expected conditional write access"
       FrameWriteAccess{} -> String -> RegisterUseM arch ids ()
forall a. HasCallStack => String -> a
error String
"Expectedf1 conditional write access"
       FrameCondWriteAccess MemInt (ArchAddrWidth arch)
_o MemRepr tp
_repr InferStackValue arch ids tp
sv -> do
         BlockStartConstraints arch
cns <- (BlockUsageSummary arch ids -> BlockStartConstraints arch)
-> ReaderT
     (RegisterUseContext arch)
     (StateT
        (BlockUsageSummary arch ids) (Except (RegisterUseError arch)))
     (BlockStartConstraints arch)
forall s (m :: Type -> Type) a. MonadState s m => (s -> a) -> m a
gets BlockUsageSummary arch ids -> BlockStartConstraints arch
forall arch ids.
BlockUsageSummary arch ids -> BlockStartConstraints arch
blockUsageStartConstraints
         Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
cache <- (BlockUsageSummary arch ids
 -> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids))
-> ReaderT
     (RegisterUseContext arch)
     (StateT
        (BlockUsageSummary arch ids) (Except (RegisterUseError arch)))
     (Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids))
forall s (m :: Type -> Type) a. MonadState s m => (s -> a) -> m a
gets BlockUsageSummary arch ids
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
forall arch ids.
BlockUsageSummary arch ids
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
assignDeps
         let deps :: DependencySet (ArchReg arch) ids
deps = Int
-> DependencySet (ArchReg arch) ids
-> DependencySet (ArchReg arch) ids
forall (r :: Type -> Type) ids.
Int -> DependencySet r ids -> DependencySet r ids
addWriteDep Int
stmtIdx
                      (DependencySet (ArchReg arch) ids
 -> DependencySet (ArchReg arch) ids)
-> DependencySet (ArchReg arch) ids
-> DependencySet (ArchReg arch) ids
forall a b. (a -> b) -> a -> b
$  BlockStartConstraints arch
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
-> Value arch ids BoolType
-> DependencySet (ArchReg arch) ids
forall arch ids (tp :: Type).
(HasCallStack, MemWidth (ArchAddrWidth arch),
 OrdF (ArchReg arch)) =>
BlockStartConstraints arch
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
-> Value arch ids tp
-> DependencySet (ArchReg arch) ids
valueDeps BlockStartConstraints arch
cns Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
cache Value arch ids BoolType
c
                      DependencySet (ArchReg arch) ids
-> DependencySet (ArchReg arch) ids
-> DependencySet (ArchReg arch) ids
forall a. Semigroup a => a -> a -> a
<> BlockStartConstraints arch
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
-> InferStackValue arch ids tp
-> DependencySet (ArchReg arch) ids
forall arch ids (tp :: Type).
(HasCallStack, MemWidth (ArchAddrWidth arch),
 OrdF (ArchReg arch)) =>
BlockStartConstraints arch
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
-> InferStackValue arch ids tp
-> DependencySet (ArchReg arch) ids
inferStackValueDeps BlockStartConstraints arch
cns Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
cache InferStackValue arch ids tp
sv
                      DependencySet (ArchReg arch) ids
-> DependencySet (ArchReg arch) ids
-> DependencySet (ArchReg arch) ids
forall a. Semigroup a => a -> a -> a
<> BlockStartConstraints arch
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
-> Value arch ids tp
-> DependencySet (ArchReg arch) ids
forall arch ids (tp :: Type).
(HasCallStack, MemWidth (ArchAddrWidth arch),
 OrdF (ArchReg arch)) =>
BlockStartConstraints arch
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
-> Value arch ids tp
-> DependencySet (ArchReg arch) ids
valueDeps BlockStartConstraints arch
cns Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
cache Value arch ids tp
val
         (Map Int (DependencySet (ArchReg arch) ids)
 -> Identity (Map Int (DependencySet (ArchReg arch) ids)))
-> BlockUsageSummary arch ids
-> Identity (BlockUsageSummary arch ids)
forall arch ids (f :: Type -> Type).
Functor f =>
(Map Int (DependencySet (ArchReg arch) ids)
 -> f (Map Int (DependencySet (ArchReg arch) ids)))
-> BlockUsageSummary arch ids -> f (BlockUsageSummary arch ids)
blockWriteDependencyLens ((Map Int (DependencySet (ArchReg arch) ids)
  -> Identity (Map Int (DependencySet (ArchReg arch) ids)))
 -> BlockUsageSummary arch ids
 -> Identity (BlockUsageSummary arch ids))
-> (Map Int (DependencySet (ArchReg arch) ids)
    -> Map Int (DependencySet (ArchReg arch) ids))
-> RegisterUseM arch ids ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= Int
-> DependencySet (ArchReg arch) ids
-> Map Int (DependencySet (ArchReg arch) ids)
-> Map Int (DependencySet (ArchReg arch) ids)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Int
stmtIdx DependencySet (ArchReg arch) ids
deps
       FrameCondWriteOverlapAccess MemInt (ArchAddrWidth arch)
_ -> do
         BlockStartConstraints arch
cns <- (BlockUsageSummary arch ids -> BlockStartConstraints arch)
-> ReaderT
     (RegisterUseContext arch)
     (StateT
        (BlockUsageSummary arch ids) (Except (RegisterUseError arch)))
     (BlockStartConstraints arch)
forall s (m :: Type -> Type) a. MonadState s m => (s -> a) -> m a
gets BlockUsageSummary arch ids -> BlockStartConstraints arch
forall arch ids.
BlockUsageSummary arch ids -> BlockStartConstraints arch
blockUsageStartConstraints
         Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
cache <- (BlockUsageSummary arch ids
 -> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids))
-> ReaderT
     (RegisterUseContext arch)
     (StateT
        (BlockUsageSummary arch ids) (Except (RegisterUseError arch)))
     (Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids))
forall s (m :: Type -> Type) a. MonadState s m => (s -> a) -> m a
gets BlockUsageSummary arch ids
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
forall arch ids.
BlockUsageSummary arch ids
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
assignDeps
         let valDeps :: DependencySet (ArchReg arch) ids
valDeps =
                Int
-> DependencySet (ArchReg arch) ids
-> DependencySet (ArchReg arch) ids
forall (r :: Type -> Type) ids.
Int -> DependencySet r ids -> DependencySet r ids
addWriteDep Int
stmtIdx (DependencySet (ArchReg arch) ids
 -> DependencySet (ArchReg arch) ids)
-> DependencySet (ArchReg arch) ids
-> DependencySet (ArchReg arch) ids
forall a b. (a -> b) -> a -> b
$
                  BlockStartConstraints arch
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
-> Value arch ids BoolType
-> DependencySet (ArchReg arch) ids
forall arch ids (tp :: Type).
(HasCallStack, MemWidth (ArchAddrWidth arch),
 OrdF (ArchReg arch)) =>
BlockStartConstraints arch
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
-> Value arch ids tp
-> DependencySet (ArchReg arch) ids
valueDeps BlockStartConstraints arch
cns Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
cache Value arch ids BoolType
c DependencySet (ArchReg arch) ids
-> DependencySet (ArchReg arch) ids
-> DependencySet (ArchReg arch) ids
forall a. Semigroup a => a -> a -> a
<> BlockStartConstraints arch
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
-> Value arch ids tp
-> DependencySet (ArchReg arch) ids
forall arch ids (tp :: Type).
(HasCallStack, MemWidth (ArchAddrWidth arch),
 OrdF (ArchReg arch)) =>
BlockStartConstraints arch
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
-> Value arch ids tp
-> DependencySet (ArchReg arch) ids
valueDeps BlockStartConstraints arch
cns Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
cache Value arch ids tp
val
         (Map Int (DependencySet (ArchReg arch) ids)
 -> Identity (Map Int (DependencySet (ArchReg arch) ids)))
-> BlockUsageSummary arch ids
-> Identity (BlockUsageSummary arch ids)
forall arch ids (f :: Type -> Type).
Functor f =>
(Map Int (DependencySet (ArchReg arch) ids)
 -> f (Map Int (DependencySet (ArchReg arch) ids)))
-> BlockUsageSummary arch ids -> f (BlockUsageSummary arch ids)
blockWriteDependencyLens ((Map Int (DependencySet (ArchReg arch) ids)
  -> Identity (Map Int (DependencySet (ArchReg arch) ids)))
 -> BlockUsageSummary arch ids
 -> Identity (BlockUsageSummary arch ids))
-> (Map Int (DependencySet (ArchReg arch) ids)
    -> Map Int (DependencySet (ArchReg arch) ids))
-> RegisterUseM arch ids ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= Int
-> DependencySet (ArchReg arch) ids
-> Map Int (DependencySet (ArchReg arch) ids)
-> Map Int (DependencySet (ArchReg arch) ids)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Int
stmtIdx DependencySet (ArchReg arch) ids
valDeps
   InstructionStart ArchAddrWord arch
off Text
_ -> do
     (BlockUsageSummary arch ids -> BlockUsageSummary arch ids)
-> RegisterUseM arch ids ()
forall s (m :: Type -> Type). MonadState s m => (s -> s) -> m ()
modify ((BlockUsageSummary arch ids -> BlockUsageSummary arch ids)
 -> RegisterUseM arch ids ())
-> (BlockUsageSummary arch ids -> BlockUsageSummary arch ids)
-> RegisterUseM arch ids ()
forall a b. (a -> b) -> a -> b
$ \BlockUsageSummary arch ids
s -> BlockUsageSummary arch ids
s { blockCurOff = off }
    -- Comment statements have no specific value.
   Comment Text
_ ->
     () -> RegisterUseM arch ids ()
forall a.
a
-> ReaderT
     (RegisterUseContext arch)
     (StateT
        (BlockUsageSummary arch ids) (Except (RegisterUseError arch)))
     a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ()
   ExecArchStmt ArchStmt arch (Value arch ids)
astmt -> do
     (forall (s :: Type). Value arch ids s -> RegisterUseM arch ids ())
-> ArchStmt arch (Value arch ids) -> RegisterUseM arch ids ()
forall {k} (t :: (k -> Type) -> Type) (f :: Type -> Type)
       (e :: k -> Type) a.
(FoldableF t, Applicative f) =>
(forall (s :: k). e s -> f a) -> t e -> f ()
traverseF_ Value arch ids s -> RegisterUseM arch ids ()
forall arch ids (tp :: Type).
(HasCallStack, MemWidth (ArchAddrWidth arch),
 OrdF (ArchReg arch)) =>
Value arch ids tp -> RegisterUseM arch ids ()
forall (s :: Type). Value arch ids s -> RegisterUseM arch ids ()
demandValue ArchStmt arch (Value arch ids)
astmt
   ArchState ArchMemAddr arch
_addr MapF (ArchReg arch) (Value arch ids)
_assn -> do
     () -> RegisterUseM arch ids ()
forall a.
a
-> ReaderT
     (RegisterUseContext arch)
     (StateT
        (BlockUsageSummary arch ids) (Except (RegisterUseError arch)))
     a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ()

-- | This function figures out what the block requires (i.e.,
-- addresses that are stored to, and the value stored), along with a
-- map of how demands by successor blocks map back to assignments and
-- registers.
--
-- It returns a summary along with start constraints inferred by
-- blocks that follow this one.
mkBlockUsageSummary :: forall arch ids
               .  ( RegisterInfo (ArchReg arch)
                  , FoldableF (ArchStmt arch)
                  , FoldableFC (ArchFn arch)
                  )
               => RegisterUseContext arch
               -> BlockStartConstraints arch
                  -- ^ Inferred state at start of block
               -> InferState arch ids
                  -- ^ Information inferred from executed block.
               -> ParsedBlock arch ids
                  -- ^ Block
               -> Except (RegisterUseError arch) (BlockUsageSummary arch ids)
mkBlockUsageSummary :: forall arch ids.
(RegisterInfo (ArchReg arch), FoldableF (ArchStmt arch),
 FoldableFC (ArchFn arch)) =>
RegisterUseContext arch
-> BlockStartConstraints arch
-> InferState arch ids
-> ParsedBlock arch ids
-> Except (RegisterUseError arch) (BlockUsageSummary arch ids)
mkBlockUsageSummary RegisterUseContext arch
ctx BlockStartConstraints arch
cns InferState arch ids
sis ParsedBlock arch ids
blk = do
  (StateT
   (BlockUsageSummary arch ids)
   (ExceptT (RegisterUseError arch) Identity)
   ()
 -> BlockUsageSummary arch ids
 -> Except (RegisterUseError arch) (BlockUsageSummary arch ids))
-> BlockUsageSummary arch ids
-> StateT
     (BlockUsageSummary arch ids)
     (ExceptT (RegisterUseError arch) Identity)
     ()
-> Except (RegisterUseError arch) (BlockUsageSummary arch ids)
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT
  (BlockUsageSummary arch ids)
  (ExceptT (RegisterUseError arch) Identity)
  ()
-> BlockUsageSummary arch ids
-> Except (RegisterUseError arch) (BlockUsageSummary arch ids)
forall (m :: Type -> Type) s a. Monad m => StateT s m a -> s -> m s
execStateT (BlockStartConstraints arch
-> InferState arch ids -> BlockUsageSummary arch ids
forall arch ids.
BlockStartConstraints arch
-> InferState arch ids -> BlockUsageSummary arch ids
initBlockUsageSummary BlockStartConstraints arch
cns InferState arch ids
sis) (StateT
   (BlockUsageSummary arch ids)
   (ExceptT (RegisterUseError arch) Identity)
   ()
 -> Except (RegisterUseError arch) (BlockUsageSummary arch ids))
-> StateT
     (BlockUsageSummary arch ids)
     (ExceptT (RegisterUseError arch) Identity)
     ()
-> Except (RegisterUseError arch) (BlockUsageSummary arch ids)
forall a b. (a -> b) -> a -> b
$ (ReaderT
   (RegisterUseContext arch)
   (StateT
      (BlockUsageSummary arch ids)
      (ExceptT (RegisterUseError arch) Identity))
   ()
 -> RegisterUseContext arch
 -> StateT
      (BlockUsageSummary arch ids)
      (ExceptT (RegisterUseError arch) Identity)
      ())
-> RegisterUseContext arch
-> ReaderT
     (RegisterUseContext arch)
     (StateT
        (BlockUsageSummary arch ids)
        (ExceptT (RegisterUseError arch) Identity))
     ()
-> StateT
     (BlockUsageSummary arch ids)
     (ExceptT (RegisterUseError arch) Identity)
     ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT
  (RegisterUseContext arch)
  (StateT
     (BlockUsageSummary arch ids)
     (ExceptT (RegisterUseError arch) Identity))
  ()
-> RegisterUseContext arch
-> StateT
     (BlockUsageSummary arch ids)
     (ExceptT (RegisterUseError arch) Identity)
     ()
forall r (m :: Type -> Type) a. ReaderT r m a -> r -> m a
runReaderT RegisterUseContext arch
ctx (ReaderT
   (RegisterUseContext arch)
   (StateT
      (BlockUsageSummary arch ids)
      (ExceptT (RegisterUseError arch) Identity))
   ()
 -> StateT
      (BlockUsageSummary arch ids)
      (ExceptT (RegisterUseError arch) Identity)
      ())
-> ReaderT
     (RegisterUseContext arch)
     (StateT
        (BlockUsageSummary arch ids)
        (ExceptT (RegisterUseError arch) Identity))
     ()
-> StateT
     (BlockUsageSummary arch ids)
     (ExceptT (RegisterUseError arch) Identity)
     ()
forall a b. (a -> b) -> a -> b
$ do
    let addr :: MemSegmentOff (RegAddrWidth (ArchReg arch))
addr = ParsedBlock arch ids -> MemSegmentOff (RegAddrWidth (ArchReg arch))
forall arch ids. ParsedBlock arch ids -> ArchSegmentOff arch
pblockAddr ParsedBlock arch ids
blk
    -- Add demanded values for terminal
    (Int
 -> Stmt arch ids
 -> ReaderT
      (RegisterUseContext arch)
      (StateT
         (BlockUsageSummary arch ids)
         (ExceptT (RegisterUseError arch) Identity))
      ())
-> [Int]
-> [Stmt arch ids]
-> ReaderT
     (RegisterUseContext arch)
     (StateT
        (BlockUsageSummary arch ids)
        (ExceptT (RegisterUseError arch) Identity))
     ()
forall (m :: Type -> Type) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ Int
-> Stmt arch ids
-> ReaderT
     (RegisterUseContext arch)
     (StateT
        (BlockUsageSummary arch ids)
        (ExceptT (RegisterUseError arch) Identity))
     ()
forall arch ids.
(HasCallStack, OrdF (ArchReg arch), MemWidth (ArchAddrWidth arch),
 ShowF (ArchReg arch), FoldableFC (ArchFn arch),
 FoldableF (ArchStmt arch)) =>
Int -> Stmt arch ids -> RegisterUseM arch ids ()
demandStmtValues [Int
0..] (ParsedBlock arch ids -> [Stmt arch ids]
forall arch ids. ParsedBlock arch ids -> [Stmt arch ids]
pblockStmts ParsedBlock arch ids
blk)
    let tidx :: Int
tidx = [Stmt arch ids] -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length (ParsedBlock arch ids -> [Stmt arch ids]
forall arch ids. ParsedBlock arch ids -> [Stmt arch ids]
pblockStmts ParsedBlock arch ids
blk)
    case ParsedBlock arch ids -> ParsedTermStmt arch ids
forall arch ids. ParsedBlock arch ids -> ParsedTermStmt arch ids
pblockTermStmt ParsedBlock arch ids
blk of
      ParsedJump RegState (ArchReg arch) (Value arch ids)
regs MemSegmentOff (RegAddrWidth (ArchReg arch))
_tgt -> do
        MapF (ArchReg arch) (Value arch ids)
-> ReaderT
     (RegisterUseContext arch)
     (StateT
        (BlockUsageSummary arch ids)
        (ExceptT (RegisterUseError arch) Identity))
     ()
forall arch ids.
(MemWidth (ArchAddrWidth arch), OrdF (ArchReg arch)) =>
MapF (ArchReg arch) (Value arch ids) -> RegisterUseM arch ids ()
recordRegMap (RegState (ArchReg arch) (Value arch ids)
-> MapF (ArchReg arch) (Value arch ids)
forall {v} (r :: v -> Type) (f :: v -> Type).
RegState r f -> MapF r f
regStateMap RegState (ArchReg arch) (Value arch ids)
regs)
      ParsedBranch RegState (ArchReg arch) (Value arch ids)
regs Value arch ids BoolType
cond MemSegmentOff (RegAddrWidth (ArchReg arch))
_t MemSegmentOff (RegAddrWidth (ArchReg arch))
_f  -> do
        Value arch ids BoolType
-> ReaderT
     (RegisterUseContext arch)
     (StateT
        (BlockUsageSummary arch ids)
        (ExceptT (RegisterUseError arch) Identity))
     ()
forall arch ids (tp :: Type).
(HasCallStack, MemWidth (ArchAddrWidth arch),
 OrdF (ArchReg arch)) =>
Value arch ids tp -> RegisterUseM arch ids ()
demandValue Value arch ids BoolType
cond
        MapF (ArchReg arch) (Value arch ids)
-> ReaderT
     (RegisterUseContext arch)
     (StateT
        (BlockUsageSummary arch ids)
        (ExceptT (RegisterUseError arch) Identity))
     ()
forall arch ids.
(MemWidth (ArchAddrWidth arch), OrdF (ArchReg arch)) =>
MapF (ArchReg arch) (Value arch ids) -> RegisterUseM arch ids ()
recordRegMap (RegState (ArchReg arch) (Value arch ids)
-> MapF (ArchReg arch) (Value arch ids)
forall {v} (r :: v -> Type) (f :: v -> Type).
RegState r f -> MapF r f
regStateMap RegState (ArchReg arch) (Value arch ids)
regs)
      ParsedLookupTable JumpTableLayout arch
_layout RegState (ArchReg arch) (Value arch ids)
regs Value arch ids (BVType (RegAddrWidth (ArchReg arch)))
idx Vector (MemSegmentOff (RegAddrWidth (ArchReg arch)))
_tgts -> do
        Value arch ids (BVType (RegAddrWidth (ArchReg arch)))
-> ReaderT
     (RegisterUseContext arch)
     (StateT
        (BlockUsageSummary arch ids)
        (ExceptT (RegisterUseError arch) Identity))
     ()
forall arch ids (tp :: Type).
(HasCallStack, MemWidth (ArchAddrWidth arch),
 OrdF (ArchReg arch)) =>
Value arch ids tp -> RegisterUseM arch ids ()
demandValue Value arch ids (BVType (RegAddrWidth (ArchReg arch)))
idx
        MapF (ArchReg arch) (Value arch ids)
-> ReaderT
     (RegisterUseContext arch)
     (StateT
        (BlockUsageSummary arch ids)
        (ExceptT (RegisterUseError arch) Identity))
     ()
forall arch ids.
(MemWidth (ArchAddrWidth arch), OrdF (ArchReg arch)) =>
MapF (ArchReg arch) (Value arch ids) -> RegisterUseM arch ids ()
recordRegMap (RegState (ArchReg arch) (Value arch ids)
-> MapF (ArchReg arch) (Value arch ids)
forall {v} (r :: v -> Type) (f :: v -> Type).
RegState r f -> MapF r f
regStateMap RegState (ArchReg arch) (Value arch ids)
regs)
      ParsedCall RegState (ArchReg arch) (Value arch ids)
regs Maybe (MemSegmentOff (RegAddrWidth (ArchReg arch)))
_mret -> do
        MemSegmentOff (RegAddrWidth (ArchReg arch))
-> RegState (ArchReg arch) (Value arch ids)
-> Either RegisterUseErrorReason (CallRegs arch ids)
callFn <- (RegisterUseContext arch
 -> MemSegmentOff (RegAddrWidth (ArchReg arch))
 -> RegState (ArchReg arch) (Value arch ids)
 -> Either RegisterUseErrorReason (CallRegs arch ids))
-> ReaderT
     (RegisterUseContext arch)
     (StateT
        (BlockUsageSummary arch ids)
        (ExceptT (RegisterUseError arch) Identity))
     (MemSegmentOff (RegAddrWidth (ArchReg arch))
      -> RegState (ArchReg arch) (Value arch ids)
      -> Either RegisterUseErrorReason (CallRegs arch ids))
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks ((RegisterUseContext arch
  -> MemSegmentOff (RegAddrWidth (ArchReg arch))
  -> RegState (ArchReg arch) (Value arch ids)
  -> Either RegisterUseErrorReason (CallRegs arch ids))
 -> ReaderT
      (RegisterUseContext arch)
      (StateT
         (BlockUsageSummary arch ids)
         (ExceptT (RegisterUseError arch) Identity))
      (MemSegmentOff (RegAddrWidth (ArchReg arch))
       -> RegState (ArchReg arch) (Value arch ids)
       -> Either RegisterUseErrorReason (CallRegs arch ids)))
-> (RegisterUseContext arch
    -> MemSegmentOff (RegAddrWidth (ArchReg arch))
    -> RegState (ArchReg arch) (Value arch ids)
    -> Either RegisterUseErrorReason (CallRegs arch ids))
-> ReaderT
     (RegisterUseContext arch)
     (StateT
        (BlockUsageSummary arch ids)
        (ExceptT (RegisterUseError arch) Identity))
     (MemSegmentOff (RegAddrWidth (ArchReg arch))
      -> RegState (ArchReg arch) (Value arch ids)
      -> Either RegisterUseErrorReason (CallRegs arch ids))
forall a b. (a -> b) -> a -> b
$ \RegisterUseContext arch
x -> RegisterUseContext arch
-> forall ids.
   MemSegmentOff (RegAddrWidth (ArchReg arch))
   -> RegState (ArchReg arch) (Value arch ids)
   -> Either RegisterUseErrorReason (CallRegs arch ids)
forall arch.
RegisterUseContext arch
-> forall ids.
   ArchSegmentOff arch
   -> RegState (ArchReg arch) (Value arch ids)
   -> Either RegisterUseErrorReason (CallRegs arch ids)
callDemandFn RegisterUseContext arch
x
        -- Get function type associated with function
        MemWord (RegAddrWidth (ArchReg arch))
off <- (BlockUsageSummary arch ids
 -> MemWord (RegAddrWidth (ArchReg arch)))
-> ReaderT
     (RegisterUseContext arch)
     (StateT
        (BlockUsageSummary arch ids)
        (ExceptT (RegisterUseError arch) Identity))
     (MemWord (RegAddrWidth (ArchReg arch)))
forall s (m :: Type -> Type) a. MonadState s m => (s -> a) -> m a
gets BlockUsageSummary arch ids -> MemWord (RegAddrWidth (ArchReg arch))
forall arch ids. BlockUsageSummary arch ids -> ArchAddrWord arch
blockCurOff
        let insnAddr :: MemSegmentOff (RegAddrWidth (ArchReg arch))
insnAddr =
              let msg :: String
msg = String
"internal: Expected valid instruction address."
               in MemSegmentOff (RegAddrWidth (ArchReg arch))
-> Maybe (MemSegmentOff (RegAddrWidth (ArchReg arch)))
-> MemSegmentOff (RegAddrWidth (ArchReg arch))
forall a. a -> Maybe a -> a
fromMaybe (String -> MemSegmentOff (RegAddrWidth (ArchReg arch))
forall a. HasCallStack => String -> a
error String
msg) (MemSegmentOff (RegAddrWidth (ArchReg arch))
-> Integer -> Maybe (MemSegmentOff (RegAddrWidth (ArchReg arch)))
forall (w :: Nat).
MemWidth w =>
MemSegmentOff w -> Integer -> Maybe (MemSegmentOff w)
incSegmentOff MemSegmentOff (RegAddrWidth (ArchReg arch))
addr (MemWord (RegAddrWidth (ArchReg arch)) -> Integer
forall a. Integral a => a -> Integer
toInteger MemWord (RegAddrWidth (ArchReg arch))
off))
        Value arch ids (BVType (RegAddrWidth (ArchReg arch)))
-> ReaderT
     (RegisterUseContext arch)
     (StateT
        (BlockUsageSummary arch ids)
        (ExceptT (RegisterUseError arch) Identity))
     ()
forall arch ids (tp :: Type).
(HasCallStack, MemWidth (ArchAddrWidth arch),
 OrdF (ArchReg arch)) =>
Value arch ids tp -> RegisterUseM arch ids ()
demandValue (RegState (ArchReg arch) (Value arch ids)
regsRegState (ArchReg arch) (Value arch ids)
-> Getting
     (Value arch ids (BVType (RegAddrWidth (ArchReg arch))))
     (RegState (ArchReg arch) (Value arch ids))
     (Value arch ids (BVType (RegAddrWidth (ArchReg arch))))
-> Value arch ids (BVType (RegAddrWidth (ArchReg arch)))
forall s a. s -> Getting a s a -> a
^.ArchReg arch (BVType (RegAddrWidth (ArchReg arch)))
-> Lens'
     (RegState (ArchReg arch) (Value arch ids))
     (Value arch ids (BVType (RegAddrWidth (ArchReg arch))))
forall {k} (r :: k -> Type) (f :: k -> Type) (tp :: k).
OrdF r =>
r tp -> Lens' (RegState r f) (f tp)
boundValue ArchReg arch (BVType (RegAddrWidth (ArchReg arch)))
forall (r :: Type -> Type).
RegisterInfo r =>
r (BVType (RegAddrWidth r))
ip_reg)
        CallRegs arch ids
ftr <-
          case MemSegmentOff (RegAddrWidth (ArchReg arch))
-> RegState (ArchReg arch) (Value arch ids)
-> Either RegisterUseErrorReason (CallRegs arch ids)
callFn MemSegmentOff (RegAddrWidth (ArchReg arch))
insnAddr RegState (ArchReg arch) (Value arch ids)
regs of
            Right CallRegs arch ids
v -> CallRegs arch ids
-> ReaderT
     (RegisterUseContext arch)
     (StateT
        (BlockUsageSummary arch ids)
        (ExceptT (RegisterUseError arch) Identity))
     (CallRegs arch ids)
forall a.
a
-> ReaderT
     (RegisterUseContext arch)
     (StateT
        (BlockUsageSummary arch ids)
        (ExceptT (RegisterUseError arch) Identity))
     a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure CallRegs arch ids
v
            Left RegisterUseErrorReason
rsn -> do
              RegisterUseError arch
-> ReaderT
     (RegisterUseContext arch)
     (StateT
        (BlockUsageSummary arch ids)
        (ExceptT (RegisterUseError arch) Identity))
     (CallRegs arch ids)
forall a.
RegisterUseError arch
-> ReaderT
     (RegisterUseContext arch)
     (StateT
        (BlockUsageSummary arch ids)
        (ExceptT (RegisterUseError arch) Identity))
     a
forall e (m :: Type -> Type) a. MonadError e m => e -> m a
throwError (RegisterUseError arch
 -> ReaderT
      (RegisterUseContext arch)
      (StateT
         (BlockUsageSummary arch ids)
         (ExceptT (RegisterUseError arch) Identity))
      (CallRegs arch ids))
-> RegisterUseError arch
-> ReaderT
     (RegisterUseContext arch)
     (StateT
        (BlockUsageSummary arch ids)
        (ExceptT (RegisterUseError arch) Identity))
     (CallRegs arch ids)
forall a b. (a -> b) -> a -> b
$
                RegisterUseError
                  { ruBlock :: MemSegmentOff (RegAddrWidth (ArchReg arch))
ruBlock = MemSegmentOff (RegAddrWidth (ArchReg arch))
addr,
                    ruStmt :: Int
ruStmt = Int
tidx,
                    ruReason :: RegisterUseErrorReason
ruReason = RegisterUseErrorReason
rsn
                  }
        -- Demand argument registers
        do
          [Some (Value arch ids)]
-> (Some (Value arch ids)
    -> ReaderT
         (RegisterUseContext arch)
         (StateT
            (BlockUsageSummary arch ids)
            (ExceptT (RegisterUseError arch) Identity))
         ())
-> ReaderT
     (RegisterUseContext arch)
     (StateT
        (BlockUsageSummary arch ids)
        (ExceptT (RegisterUseError arch) Identity))
     ()
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (CallRegs arch ids -> [Some (Value arch ids)]
forall arch ids. CallRegs arch ids -> [Some (Value arch ids)]
callArgValues CallRegs arch ids
ftr) ((Some (Value arch ids)
  -> ReaderT
       (RegisterUseContext arch)
       (StateT
          (BlockUsageSummary arch ids)
          (ExceptT (RegisterUseError arch) Identity))
       ())
 -> ReaderT
      (RegisterUseContext arch)
      (StateT
         (BlockUsageSummary arch ids)
         (ExceptT (RegisterUseError arch) Identity))
      ())
-> (Some (Value arch ids)
    -> ReaderT
         (RegisterUseContext arch)
         (StateT
            (BlockUsageSummary arch ids)
            (ExceptT (RegisterUseError arch) Identity))
         ())
-> ReaderT
     (RegisterUseContext arch)
     (StateT
        (BlockUsageSummary arch ids)
        (ExceptT (RegisterUseError arch) Identity))
     ()
forall a b. (a -> b) -> a -> b
$ \(Some Value arch ids x
v) -> do
            case Value arch ids x
v of
              -- No dependencies
              CValue CValue arch x
_ -> do
                ()
-> ReaderT
     (RegisterUseContext arch)
     (StateT
        (BlockUsageSummary arch ids)
        (ExceptT (RegisterUseError arch) Identity))
     ()
forall a.
a
-> ReaderT
     (RegisterUseContext arch)
     (StateT
        (BlockUsageSummary arch ids)
        (ExceptT (RegisterUseError arch) Identity))
     a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ()
              Initial ArchReg arch x
r -> do
                DependencySet (ArchReg arch) ids
-> ReaderT
     (RegisterUseContext arch)
     (StateT
        (BlockUsageSummary arch ids)
        (ExceptT (RegisterUseError arch) Identity))
     ()
forall arch ids.
(HasCallStack, OrdF (ArchReg arch)) =>
DependencySet (ArchReg arch) ids -> RegisterUseM arch ids ()
addDeps (InitInferValue arch x -> DependencySet (ArchReg arch) ids
forall arch (tp :: Type) ids.
InitInferValue arch tp -> DependencySet (ArchReg arch) ids
domainDeps (BlockStartConstraints arch
-> BoundLoc (ArchReg arch) x -> InitInferValue arch x
forall arch (tp :: Type).
(MemWidth (ArchAddrWidth arch), OrdF (ArchReg arch)) =>
BlockStartConstraints arch
-> BoundLoc (ArchReg arch) tp -> InitInferValue arch tp
locDomain BlockStartConstraints arch
cns (ArchReg arch x -> BoundLoc (ArchReg arch) x
forall (r :: Type -> Type) (tp :: Type). r tp -> BoundLoc r tp
RegLoc ArchReg arch x
r)))
              AssignedValue (Assignment AssignId ids x
a AssignRhs arch (Value arch ids) x
_) -> do
                Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
cache <- (BlockUsageSummary arch ids
 -> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids))
-> ReaderT
     (RegisterUseContext arch)
     (StateT
        (BlockUsageSummary arch ids)
        (ExceptT (RegisterUseError arch) Identity))
     (Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids))
forall s (m :: Type -> Type) a. MonadState s m => (s -> a) -> m a
gets BlockUsageSummary arch ids
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
forall arch ids.
BlockUsageSummary arch ids
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
assignDeps
                case Some (AssignId ids)
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
-> Maybe (DependencySet (ArchReg arch) ids)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (AssignId ids x -> Some (AssignId ids)
forall k (f :: k -> Type) (x :: k). f x -> Some f
Some AssignId ids x
a) Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
cache of
                  Maybe (DependencySet (ArchReg arch) ids)
Nothing -> String
-> ReaderT
     (RegisterUseContext arch)
     (StateT
        (BlockUsageSummary arch ids)
        (ExceptT (RegisterUseError arch) Identity))
     ()
forall a. HasCallStack => String -> a
error (String
 -> ReaderT
      (RegisterUseContext arch)
      (StateT
         (BlockUsageSummary arch ids)
         (ExceptT (RegisterUseError arch) Identity))
      ())
-> String
-> ReaderT
     (RegisterUseContext arch)
     (StateT
        (BlockUsageSummary arch ids)
        (ExceptT (RegisterUseError arch) Identity))
     ()
forall a b. (a -> b) -> a -> b
$ String
"Assignment " String -> ShowS
forall a. [a] -> [a] -> [a]
++ AssignId ids x -> String
forall a. Show a => a -> String
show AssignId ids x
a String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" is not defined."

                  Just DependencySet (ArchReg arch) ids
r -> DependencySet (ArchReg arch) ids
-> ReaderT
     (RegisterUseContext arch)
     (StateT
        (BlockUsageSummary arch ids)
        (ExceptT (RegisterUseError arch) Identity))
     ()
forall arch ids.
(HasCallStack, OrdF (ArchReg arch)) =>
DependencySet (ArchReg arch) ids -> RegisterUseM arch ids ()
addDeps DependencySet (ArchReg arch) ids
r
        -- Store call register type information
        (BlockUsageSummary arch ids -> BlockUsageSummary arch ids)
-> ReaderT
     (RegisterUseContext arch)
     (StateT
        (BlockUsageSummary arch ids)
        (ExceptT (RegisterUseError arch) Identity))
     ()
forall s (m :: Type -> Type). MonadState s m => (s -> s) -> m ()
modify ((BlockUsageSummary arch ids -> BlockUsageSummary arch ids)
 -> ReaderT
      (RegisterUseContext arch)
      (StateT
         (BlockUsageSummary arch ids)
         (ExceptT (RegisterUseError arch) Identity))
      ())
-> (BlockUsageSummary arch ids -> BlockUsageSummary arch ids)
-> ReaderT
     (RegisterUseContext arch)
     (StateT
        (BlockUsageSummary arch ids)
        (ExceptT (RegisterUseError arch) Identity))
     ()
forall a b. (a -> b) -> a -> b
$ \BlockUsageSummary arch ids
s -> BlockUsageSummary arch ids
s { blockCallFunType = Just (callRegsFnType ftr) }
        -- Get other things
        Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
cache <- (BlockUsageSummary arch ids
 -> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids))
-> ReaderT
     (RegisterUseContext arch)
     (StateT
        (BlockUsageSummary arch ids)
        (ExceptT (RegisterUseError arch) Identity))
     (Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids))
forall s (m :: Type -> Type) a. MonadState s m => (s -> a) -> m a
gets BlockUsageSummary arch ids
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
forall arch ids.
BlockUsageSummary arch ids
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
assignDeps
        [Some (ArchReg arch)]
savedRegs <- (RegisterUseContext arch -> [Some (ArchReg arch)])
-> ReaderT
     (RegisterUseContext arch)
     (StateT
        (BlockUsageSummary arch ids)
        (ExceptT (RegisterUseError arch) Identity))
     [Some (ArchReg arch)]
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks RegisterUseContext arch -> [Some (ArchReg arch)]
forall arch. RegisterUseContext arch -> [Some (ArchReg arch)]
calleeSavedRegisters
        let insReg :: RegDependencyMap arch ids
-> Some (ArchReg arch) -> RegDependencyMap arch ids
insReg RegDependencyMap arch ids
m (Some ArchReg arch x
r) = ArchReg arch x
-> DependencySet (ArchReg arch) ids
-> RegDependencyMap arch ids
-> RegDependencyMap arch ids
forall arch (tp :: Type) ids.
OrdF (ArchReg arch) =>
ArchReg arch tp
-> DependencySet (ArchReg arch) ids
-> RegDependencyMap arch ids
-> RegDependencyMap arch ids
setRegDep ArchReg arch x
r (BlockStartConstraints arch
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
-> Value arch ids x
-> DependencySet (ArchReg arch) ids
forall arch ids (tp :: Type).
(HasCallStack, MemWidth (ArchAddrWidth arch),
 OrdF (ArchReg arch)) =>
BlockStartConstraints arch
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
-> Value arch ids tp
-> DependencySet (ArchReg arch) ids
valueDeps BlockStartConstraints arch
cns Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
cache (RegState (ArchReg arch) (Value arch ids)
regsRegState (ArchReg arch) (Value arch ids)
-> Getting
     (Value arch ids x)
     (RegState (ArchReg arch) (Value arch ids))
     (Value arch ids x)
-> Value arch ids x
forall s a. s -> Getting a s a -> a
^.ArchReg arch x
-> Lens'
     (RegState (ArchReg arch) (Value arch ids)) (Value arch ids x)
forall {k} (r :: k -> Type) (f :: k -> Type) (tp :: k).
OrdF r =>
r tp -> Lens' (RegState r f) (f tp)
boundValue ArchReg arch x
r)) RegDependencyMap arch ids
m
        (RegDependencyMap arch ids -> Identity (RegDependencyMap arch ids))
-> BlockUsageSummary arch ids
-> Identity (BlockUsageSummary arch ids)
forall arch ids (f :: Type -> Type).
Functor f =>
(RegDependencyMap arch ids -> f (RegDependencyMap arch ids))
-> BlockUsageSummary arch ids -> f (BlockUsageSummary arch ids)
blockRegDependenciesLens ((RegDependencyMap arch ids
  -> Identity (RegDependencyMap arch ids))
 -> BlockUsageSummary arch ids
 -> Identity (BlockUsageSummary arch ids))
-> (RegDependencyMap arch ids -> RegDependencyMap arch ids)
-> ReaderT
     (RegisterUseContext arch)
     (StateT
        (BlockUsageSummary arch ids)
        (ExceptT (RegisterUseError arch) Identity))
     ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= \RegDependencyMap arch ids
m -> (RegDependencyMap arch ids
 -> Some (ArchReg arch) -> RegDependencyMap arch ids)
-> RegDependencyMap arch ids
-> [Some (ArchReg arch)]
-> RegDependencyMap arch ids
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' RegDependencyMap arch ids
-> Some (ArchReg arch) -> RegDependencyMap arch ids
insReg RegDependencyMap arch ids
m (ArchReg arch (BVType (RegAddrWidth (ArchReg arch)))
-> Some (ArchReg arch)
forall k (f :: k -> Type) (x :: k). f x -> Some f
Some ArchReg arch (BVType (RegAddrWidth (ArchReg arch)))
forall (r :: Type -> Type).
RegisterInfo r =>
r (BVType (RegAddrWidth r))
sp_reg Some (ArchReg arch)
-> [Some (ArchReg arch)] -> [Some (ArchReg arch)]
forall a. a -> [a] -> [a]
: [Some (ArchReg arch)]
savedRegs)
        [Some (ArchReg arch)]
clearedRegs <- (RegisterUseContext arch -> [Some (ArchReg arch)])
-> ReaderT
     (RegisterUseContext arch)
     (StateT
        (BlockUsageSummary arch ids)
        (ExceptT (RegisterUseError arch) Identity))
     [Some (ArchReg arch)]
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks RegisterUseContext arch -> [Some (ArchReg arch)]
forall arch. RegisterUseContext arch -> [Some (ArchReg arch)]
callScratchRegisters
        let clearReg :: RegDependencyMap arch ids
-> Some (ArchReg arch) -> RegDependencyMap arch ids
clearReg RegDependencyMap arch ids
m (Some ArchReg arch x
r) = ArchReg arch x
-> DependencySet (ArchReg arch) ids
-> RegDependencyMap arch ids
-> RegDependencyMap arch ids
forall arch (tp :: Type) ids.
OrdF (ArchReg arch) =>
ArchReg arch tp
-> DependencySet (ArchReg arch) ids
-> RegDependencyMap arch ids
-> RegDependencyMap arch ids
setRegDep ArchReg arch x
r DependencySet (ArchReg arch) ids
forall a. Monoid a => a
mempty RegDependencyMap arch ids
m
        (RegDependencyMap arch ids -> Identity (RegDependencyMap arch ids))
-> BlockUsageSummary arch ids
-> Identity (BlockUsageSummary arch ids)
forall arch ids (f :: Type -> Type).
Functor f =>
(RegDependencyMap arch ids -> f (RegDependencyMap arch ids))
-> BlockUsageSummary arch ids -> f (BlockUsageSummary arch ids)
blockRegDependenciesLens ((RegDependencyMap arch ids
  -> Identity (RegDependencyMap arch ids))
 -> BlockUsageSummary arch ids
 -> Identity (BlockUsageSummary arch ids))
-> (RegDependencyMap arch ids -> RegDependencyMap arch ids)
-> ReaderT
     (RegisterUseContext arch)
     (StateT
        (BlockUsageSummary arch ids)
        (ExceptT (RegisterUseError arch) Identity))
     ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= \RegDependencyMap arch ids
m -> (RegDependencyMap arch ids
 -> Some (ArchReg arch) -> RegDependencyMap arch ids)
-> RegDependencyMap arch ids
-> [Some (ArchReg arch)]
-> RegDependencyMap arch ids
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' RegDependencyMap arch ids
-> Some (ArchReg arch) -> RegDependencyMap arch ids
forall {arch} {ids}.
OrdF (ArchReg arch) =>
RegDependencyMap arch ids
-> Some (ArchReg arch) -> RegDependencyMap arch ids
clearReg RegDependencyMap arch ids
m [Some (ArchReg arch)]
clearedRegs
        (RegDependencyMap arch ids -> Identity (RegDependencyMap arch ids))
-> BlockUsageSummary arch ids
-> Identity (BlockUsageSummary arch ids)
forall arch ids (f :: Type -> Type).
Functor f =>
(RegDependencyMap arch ids -> f (RegDependencyMap arch ids))
-> BlockUsageSummary arch ids -> f (BlockUsageSummary arch ids)
blockRegDependenciesLens ((RegDependencyMap arch ids
  -> Identity (RegDependencyMap arch ids))
 -> BlockUsageSummary arch ids
 -> Identity (BlockUsageSummary arch ids))
-> (RegDependencyMap arch ids -> RegDependencyMap arch ids)
-> ReaderT
     (RegisterUseContext arch)
     (StateT
        (BlockUsageSummary arch ids)
        (ExceptT (RegisterUseError arch) Identity))
     ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= \RegDependencyMap arch ids
m -> (RegDependencyMap arch ids
 -> Some (ArchReg arch) -> RegDependencyMap arch ids)
-> RegDependencyMap arch ids
-> [Some (ArchReg arch)]
-> RegDependencyMap arch ids
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' RegDependencyMap arch ids
-> Some (ArchReg arch) -> RegDependencyMap arch ids
forall {arch} {ids}.
OrdF (ArchReg arch) =>
RegDependencyMap arch ids
-> Some (ArchReg arch) -> RegDependencyMap arch ids
clearReg RegDependencyMap arch ids
m (CallRegs arch ids -> [Some (ArchReg arch)]
forall arch ids. CallRegs arch ids -> [Some (ArchReg arch)]
callReturnRegs CallRegs arch ids
ftr)
      PLTStub MapF (ArchReg arch) (Value arch ids)
regs MemSegmentOff (RegAddrWidth (ArchReg arch))
_ VersionedSymbol
_ -> do
        (forall (s :: Type).
 Value arch ids s
 -> ReaderT
      (RegisterUseContext arch)
      (StateT
         (BlockUsageSummary arch ids)
         (ExceptT (RegisterUseError arch) Identity))
      ())
-> MapF (ArchReg arch) (Value arch ids)
-> ReaderT
     (RegisterUseContext arch)
     (StateT
        (BlockUsageSummary arch ids)
        (ExceptT (RegisterUseError arch) Identity))
     ()
forall {k} (t :: (k -> Type) -> Type) (f :: Type -> Type)
       (e :: k -> Type) a.
(FoldableF t, Applicative f) =>
(forall (s :: k). e s -> f a) -> t e -> f ()
traverseF_ Value arch ids s
-> ReaderT
     (RegisterUseContext arch)
     (StateT
        (BlockUsageSummary arch ids)
        (ExceptT (RegisterUseError arch) Identity))
     ()
forall arch ids (tp :: Type).
(HasCallStack, MemWidth (ArchAddrWidth arch),
 OrdF (ArchReg arch)) =>
Value arch ids tp -> RegisterUseM arch ids ()
forall (s :: Type).
Value arch ids s
-> ReaderT
     (RegisterUseContext arch)
     (StateT
        (BlockUsageSummary arch ids)
        (ExceptT (RegisterUseError arch) Identity))
     ()
demandValue MapF (ArchReg arch) (Value arch ids)
regs
        (forall (tp :: Type).
 ArchReg arch tp
 -> Value arch ids tp
 -> ReaderT
      (RegisterUseContext arch)
      (StateT
         (BlockUsageSummary arch ids)
         (ExceptT (RegisterUseError arch) Identity))
      ())
-> MapF (ArchReg arch) (Value arch ids)
-> ReaderT
     (RegisterUseContext arch)
     (StateT
        (BlockUsageSummary arch ids)
        (ExceptT (RegisterUseError arch) Identity))
     ()
forall {v} (m :: Type -> Type) (ktp :: v -> Type) (f :: v -> Type).
Applicative m =>
(forall (tp :: v). ktp tp -> f tp -> m ()) -> MapF ktp f -> m ()
MapF.traverseWithKey_ (\ArchReg arch tp
r Value arch ids tp
_ -> (BlockUsageSummary arch ids -> BlockUsageSummary arch ids)
-> ReaderT
     (RegisterUseContext arch)
     (StateT
        (BlockUsageSummary arch ids)
        (ExceptT (RegisterUseError arch) Identity))
     ()
forall s (m :: Type -> Type). MonadState s m => (s -> s) -> m ()
modify ((BlockUsageSummary arch ids -> BlockUsageSummary arch ids)
 -> ReaderT
      (RegisterUseContext arch)
      (StateT
         (BlockUsageSummary arch ids)
         (ExceptT (RegisterUseError arch) Identity))
      ())
-> (BlockUsageSummary arch ids -> BlockUsageSummary arch ids)
-> ReaderT
     (RegisterUseContext arch)
     (StateT
        (BlockUsageSummary arch ids)
        (ExceptT (RegisterUseError arch) Identity))
     ()
forall a b. (a -> b) -> a -> b
$ ArchReg arch tp
-> BlockUsageSummary arch ids -> BlockUsageSummary arch ids
forall arch (tp :: Type) ids.
(MemWidth (ArchAddrWidth arch), OrdF (ArchReg arch)) =>
ArchReg arch tp
-> BlockUsageSummary arch ids -> BlockUsageSummary arch ids
clearDependencySet ArchReg arch tp
r) MapF (ArchReg arch) (Value arch ids)
regs
      ParsedReturn RegState (ArchReg arch) (Value arch ids)
regs -> do
        [Some (ArchReg arch)]
retRegs <- (RegisterUseContext arch -> [Some (ArchReg arch)])
-> ReaderT
     (RegisterUseContext arch)
     (StateT
        (BlockUsageSummary arch ids)
        (ExceptT (RegisterUseError arch) Identity))
     [Some (ArchReg arch)]
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks RegisterUseContext arch -> [Some (ArchReg arch)]
forall arch. RegisterUseContext arch -> [Some (ArchReg arch)]
returnRegisters
        (Some (ArchReg arch)
 -> ReaderT
      (RegisterUseContext arch)
      (StateT
         (BlockUsageSummary arch ids)
         (ExceptT (RegisterUseError arch) Identity))
      ())
-> [Some (ArchReg arch)]
-> ReaderT
     (RegisterUseContext arch)
     (StateT
        (BlockUsageSummary arch ids)
        (ExceptT (RegisterUseError arch) Identity))
     ()
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (\(Some ArchReg arch x
r) -> Value arch ids x
-> ReaderT
     (RegisterUseContext arch)
     (StateT
        (BlockUsageSummary arch ids)
        (ExceptT (RegisterUseError arch) Identity))
     ()
forall arch ids (tp :: Type).
(HasCallStack, MemWidth (ArchAddrWidth arch),
 OrdF (ArchReg arch)) =>
Value arch ids tp -> RegisterUseM arch ids ()
demandValue (RegState (ArchReg arch) (Value arch ids)
regsRegState (ArchReg arch) (Value arch ids)
-> Getting
     (Value arch ids x)
     (RegState (ArchReg arch) (Value arch ids))
     (Value arch ids x)
-> Value arch ids x
forall s a. s -> Getting a s a -> a
^.ArchReg arch x
-> Lens'
     (RegState (ArchReg arch) (Value arch ids)) (Value arch ids x)
forall {k} (r :: k -> Type) (f :: k -> Type) (tp :: k).
OrdF r =>
r tp -> Lens' (RegState r f) (f tp)
boundValue ArchReg arch x
r)) [Some (ArchReg arch)]
retRegs
      ParsedArchTermStmt ArchTermStmt arch (Value arch ids)
tstmt RegState (ArchReg arch) (Value arch ids)
regs Maybe (MemSegmentOff (RegAddrWidth (ArchReg arch)))
_mnext -> do
        ArchTermStmt arch (Value arch ids)
-> RegState (ArchReg arch) (Value arch ids)
-> BlockUsageSummary arch ids
-> Either (RegisterUseError arch) (RegDependencyMap arch ids)
summaryFn <- (RegisterUseContext arch
 -> ArchTermStmt arch (Value arch ids)
 -> RegState (ArchReg arch) (Value arch ids)
 -> BlockUsageSummary arch ids
 -> Either (RegisterUseError arch) (RegDependencyMap arch ids))
-> ReaderT
     (RegisterUseContext arch)
     (StateT
        (BlockUsageSummary arch ids)
        (ExceptT (RegisterUseError arch) Identity))
     (ArchTermStmt arch (Value arch ids)
      -> RegState (ArchReg arch) (Value arch ids)
      -> BlockUsageSummary arch ids
      -> Either (RegisterUseError arch) (RegDependencyMap arch ids))
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks ((RegisterUseContext arch
  -> ArchTermStmt arch (Value arch ids)
  -> RegState (ArchReg arch) (Value arch ids)
  -> BlockUsageSummary arch ids
  -> Either (RegisterUseError arch) (RegDependencyMap arch ids))
 -> ReaderT
      (RegisterUseContext arch)
      (StateT
         (BlockUsageSummary arch ids)
         (ExceptT (RegisterUseError arch) Identity))
      (ArchTermStmt arch (Value arch ids)
       -> RegState (ArchReg arch) (Value arch ids)
       -> BlockUsageSummary arch ids
       -> Either (RegisterUseError arch) (RegDependencyMap arch ids)))
-> (RegisterUseContext arch
    -> ArchTermStmt arch (Value arch ids)
    -> RegState (ArchReg arch) (Value arch ids)
    -> BlockUsageSummary arch ids
    -> Either (RegisterUseError arch) (RegDependencyMap arch ids))
-> ReaderT
     (RegisterUseContext arch)
     (StateT
        (BlockUsageSummary arch ids)
        (ExceptT (RegisterUseError arch) Identity))
     (ArchTermStmt arch (Value arch ids)
      -> RegState (ArchReg arch) (Value arch ids)
      -> BlockUsageSummary arch ids
      -> Either (RegisterUseError arch) (RegDependencyMap arch ids))
forall a b. (a -> b) -> a -> b
$ \RegisterUseContext arch
x -> RegisterUseContext arch -> forall ids. ArchTermStmtUsageFn arch ids
forall arch.
RegisterUseContext arch -> forall ids. ArchTermStmtUsageFn arch ids
reguseTermFn RegisterUseContext arch
x
        BlockUsageSummary arch ids
s <- ReaderT
  (RegisterUseContext arch)
  (StateT
     (BlockUsageSummary arch ids)
     (ExceptT (RegisterUseError arch) Identity))
  (BlockUsageSummary arch ids)
forall s (m :: Type -> Type). MonadState s m => m s
get
        case ArchTermStmt arch (Value arch ids)
-> RegState (ArchReg arch) (Value arch ids)
-> BlockUsageSummary arch ids
-> Either (RegisterUseError arch) (RegDependencyMap arch ids)
summaryFn ArchTermStmt arch (Value arch ids)
tstmt RegState (ArchReg arch) (Value arch ids)
regs BlockUsageSummary arch ids
s of
          Left RegisterUseError arch
emsg -> RegisterUseError arch
-> ReaderT
     (RegisterUseContext arch)
     (StateT
        (BlockUsageSummary arch ids)
        (ExceptT (RegisterUseError arch) Identity))
     ()
forall a.
RegisterUseError arch
-> ReaderT
     (RegisterUseContext arch)
     (StateT
        (BlockUsageSummary arch ids)
        (ExceptT (RegisterUseError arch) Identity))
     a
forall e (m :: Type -> Type) a. MonadError e m => e -> m a
throwError RegisterUseError arch
emsg
          Right RegDependencyMap arch ids
rDeps -> (RegDependencyMap arch ids -> Identity (RegDependencyMap arch ids))
-> BlockUsageSummary arch ids
-> Identity (BlockUsageSummary arch ids)
forall arch ids (f :: Type -> Type).
Functor f =>
(RegDependencyMap arch ids -> f (RegDependencyMap arch ids))
-> BlockUsageSummary arch ids -> f (BlockUsageSummary arch ids)
blockRegDependenciesLens ((RegDependencyMap arch ids
  -> Identity (RegDependencyMap arch ids))
 -> BlockUsageSummary arch ids
 -> Identity (BlockUsageSummary arch ids))
-> RegDependencyMap arch ids
-> ReaderT
     (RegisterUseContext arch)
     (StateT
        (BlockUsageSummary arch ids)
        (ExceptT (RegisterUseError arch) Identity))
     ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= RegDependencyMap arch ids
rDeps
      ParsedTranslateError Text
_ ->
        String
-> ReaderT
     (RegisterUseContext arch)
     (StateT
        (BlockUsageSummary arch ids)
        (ExceptT (RegisterUseError arch) Identity))
     ()
forall a. HasCallStack => String -> a
error String
"Cannot identify register use in code where translation error occurs"
      ClassifyFailure RegState (ArchReg arch) (Value arch ids)
_ [String]
_ ->
        String
-> ReaderT
     (RegisterUseContext arch)
     (StateT
        (BlockUsageSummary arch ids)
        (ExceptT (RegisterUseError arch) Identity))
     ()
forall a. HasCallStack => String -> a
error (String
 -> ReaderT
      (RegisterUseContext arch)
      (StateT
         (BlockUsageSummary arch ids)
         (ExceptT (RegisterUseError arch) Identity))
      ())
-> String
-> ReaderT
     (RegisterUseContext arch)
     (StateT
        (BlockUsageSummary arch ids)
        (ExceptT (RegisterUseError arch) Identity))
     ()
forall a b. (a -> b) -> a -> b
$ String
"Classification failed: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ MemSegmentOff (RegAddrWidth (ArchReg arch)) -> String
forall a. Show a => a -> String
show MemSegmentOff (RegAddrWidth (ArchReg arch))
addr

-- | Maps the starting address of a block with the given register type to the value.
type BlockAddrMap r v = Map (MemSegmentOff (RegAddrWidth r)) v

-- | A list of blocks starting addresses and their final location
-- dependency map.
type SrcDependencies r ids =
  [(MemSegmentOff (RegAddrWidth r), LocDependencyMap r ids)]

-- | Maps each block start address to the complete list of blocks that may transition to that block
-- along with the @LocDependencyMap@ for that block.
--
-- This data structure is used to reduce lookups in back-propagation
-- of demands.
type PredProvideMap r ids =
   Map (MemSegmentOff (RegAddrWidth r)) (SrcDependencies r ids)

type NewDemandMap r = BlockAddrMap r (Set (Some (BoundLoc r)))

-- | This takes a list of registers that a block demands that have not
-- been back-propogated, and infers new demands for predecessor
-- registers.
backPropagateOne :: forall r ids
                 .  (MapF.OrdF r, MemWidth (RegAddrWidth r))
                 => BlockAddrMap r (DependencySet r ids)
                 -- ^ State that we are computing fixpoint for.
                 -> NewDemandMap r
                 -- ^ Maps block addresses to the set of register demands we
                 -- have not yet back propagated.
                 -> Set (Some (BoundLoc r))
                 -- ^ Set of new locations the target block depends on
                 -- that we have not yet backpropagate demands to the
                 -- previous block for.

                 -> [( MemSegmentOff (RegAddrWidth r)
                     , LocDependencyMap r ids
                     )]
                 -- ^ Predecessors for the target block and the map from locations
                 -- they provide to the dependency set.
                 -> ( Map (MemSegmentOff (RegAddrWidth r)) (DependencySet r ids)
                    , NewDemandMap r
                    )
backPropagateOne :: forall (r :: Type -> Type) ids.
(OrdF r, MemWidth (RegAddrWidth r)) =>
BlockAddrMap r (DependencySet r ids)
-> NewDemandMap r
-> Set (Some (BoundLoc r))
-> [(MemSegmentOff (RegAddrWidth r), LocDependencyMap r ids)]
-> (BlockAddrMap r (DependencySet r ids), NewDemandMap r)
backPropagateOne BlockAddrMap r (DependencySet r ids)
s NewDemandMap r
rest Set (Some (BoundLoc r))
_ [] = (BlockAddrMap r (DependencySet r ids)
s, NewDemandMap r
rest)
backPropagateOne BlockAddrMap r (DependencySet r ids)
s NewDemandMap r
rest Set (Some (BoundLoc r))
newLocs ((MemSegmentOff (RegAddrWidth r)
srcAddr,LocDependencyMap r ids
srcDepMap):[(MemSegmentOff (RegAddrWidth r), LocDependencyMap r ids)]
predRest) = do
  -- Get dependencies for all new locations that are demanded.
  let allDeps :: DependencySet r ids
      allDeps :: DependencySet r ids
allDeps = [DependencySet r ids] -> DependencySet r ids
forall a. Monoid a => [a] -> a
mconcat [ LocDependencyMap r ids -> BoundLoc r x -> DependencySet r ids
forall (r :: Type -> Type) ids (tp :: Type).
(OrdF r, MemWidth (RegAddrWidth r)) =>
LocDependencyMap r ids -> BoundLoc r tp -> DependencySet r ids
getLocDependencySet LocDependencyMap r ids
srcDepMap BoundLoc r x
l | Some BoundLoc r x
l <- Set (Some (BoundLoc r)) -> [Some (BoundLoc r)]
forall a. Set a -> [a]
Set.toList Set (Some (BoundLoc r))
newLocs ]
  -- Add demands for srcAddr and get existing demands.
  let (Maybe (DependencySet r ids)
mseenRegs, BlockAddrMap r (DependencySet r ids)
s') =
        (MemSegmentOff (RegAddrWidth r)
 -> DependencySet r ids
 -> DependencySet r ids
 -> DependencySet r ids)
-> MemSegmentOff (RegAddrWidth r)
-> DependencySet r ids
-> BlockAddrMap r (DependencySet r ids)
-> (Maybe (DependencySet r ids),
    BlockAddrMap r (DependencySet r ids))
forall k a.
Ord k =>
(k -> a -> a -> a) -> k -> a -> Map k a -> (Maybe a, Map k a)
Map.insertLookupWithKey (\MemSegmentOff (RegAddrWidth r)
_ DependencySet r ids
x DependencySet r ids
y -> DependencySet r ids
x DependencySet r ids -> DependencySet r ids -> DependencySet r ids
forall a. Semigroup a => a -> a -> a
<> DependencySet r ids
y) MemSegmentOff (RegAddrWidth r)
srcAddr DependencySet r ids
allDeps BlockAddrMap r (DependencySet r ids)
s
  -- Get the difference in demands so that we can propagate further.
  let d :: Set (Some (BoundLoc r))
d = case Maybe (DependencySet r ids)
mseenRegs of
            Maybe (DependencySet r ids)
Nothing -> DependencySet r ids -> Set (Some (BoundLoc r))
forall (r :: Type -> Type) ids.
DependencySet r ids -> Set (Some (BoundLoc r))
dsLocSet DependencySet r ids
allDeps
            Just DependencySet r ids
oldDems -> DependencySet r ids -> Set (Some (BoundLoc r))
forall (r :: Type -> Type) ids.
DependencySet r ids -> Set (Some (BoundLoc r))
dsLocSet DependencySet r ids
allDeps Set (Some (BoundLoc r))
-> Set (Some (BoundLoc r)) -> Set (Some (BoundLoc r))
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` DependencySet r ids -> Set (Some (BoundLoc r))
forall (r :: Type -> Type) ids.
DependencySet r ids -> Set (Some (BoundLoc r))
dsLocSet DependencySet r ids
oldDems
  -- Update list of additional propagations.
  let rest' :: NewDemandMap r
rest' | Set (Some (BoundLoc r)) -> Bool
forall a. Set a -> Bool
Set.null Set (Some (BoundLoc r))
d = NewDemandMap r
rest
            | Bool
otherwise = (Set (Some (BoundLoc r))
 -> Set (Some (BoundLoc r)) -> Set (Some (BoundLoc r)))
-> MemSegmentOff (RegAddrWidth r)
-> Set (Some (BoundLoc r))
-> NewDemandMap r
-> NewDemandMap r
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith Set (Some (BoundLoc r))
-> Set (Some (BoundLoc r)) -> Set (Some (BoundLoc r))
forall a. Ord a => Set a -> Set a -> Set a
Set.union MemSegmentOff (RegAddrWidth r)
srcAddr Set (Some (BoundLoc r))
d NewDemandMap r
rest
  BlockAddrMap r (DependencySet r ids)
-> (BlockAddrMap r (DependencySet r ids), NewDemandMap r)
-> (BlockAddrMap r (DependencySet r ids), NewDemandMap r)
forall a b. a -> b -> b
seq BlockAddrMap r (DependencySet r ids)
s' ((BlockAddrMap r (DependencySet r ids), NewDemandMap r)
 -> (BlockAddrMap r (DependencySet r ids), NewDemandMap r))
-> (BlockAddrMap r (DependencySet r ids), NewDemandMap r)
-> (BlockAddrMap r (DependencySet r ids), NewDemandMap r)
forall a b. (a -> b) -> a -> b
$ NewDemandMap r
-> (BlockAddrMap r (DependencySet r ids), NewDemandMap r)
-> (BlockAddrMap r (DependencySet r ids), NewDemandMap r)
forall a b. a -> b -> b
seq NewDemandMap r
rest' ((BlockAddrMap r (DependencySet r ids), NewDemandMap r)
 -> (BlockAddrMap r (DependencySet r ids), NewDemandMap r))
-> (BlockAddrMap r (DependencySet r ids), NewDemandMap r)
-> (BlockAddrMap r (DependencySet r ids), NewDemandMap r)
forall a b. (a -> b) -> a -> b
$ BlockAddrMap r (DependencySet r ids)
-> NewDemandMap r
-> Set (Some (BoundLoc r))
-> [(MemSegmentOff (RegAddrWidth r), LocDependencyMap r ids)]
-> (BlockAddrMap r (DependencySet r ids), NewDemandMap r)
forall (r :: Type -> Type) ids.
(OrdF r, MemWidth (RegAddrWidth r)) =>
BlockAddrMap r (DependencySet r ids)
-> NewDemandMap r
-> Set (Some (BoundLoc r))
-> [(MemSegmentOff (RegAddrWidth r), LocDependencyMap r ids)]
-> (BlockAddrMap r (DependencySet r ids), NewDemandMap r)
backPropagateOne BlockAddrMap r (DependencySet r ids)
s' NewDemandMap r
rest' Set (Some (BoundLoc r))
newLocs [(MemSegmentOff (RegAddrWidth r), LocDependencyMap r ids)]
predRest

------------------------------------------------------------------------
-- BlockInvariants

newtype LocList r tp = LL { forall (r :: Type -> Type) (tp :: Type).
LocList r tp -> [BoundLoc r tp]
llValues :: [BoundLoc r tp] }

instance Semigroup (LocList r tp) where
  LL [BoundLoc r tp]
x <> :: LocList r tp -> LocList r tp -> LocList r tp
<> LL [BoundLoc r tp]
y = [BoundLoc r tp] -> LocList r tp
forall (r :: Type -> Type) (tp :: Type).
[BoundLoc r tp] -> LocList r tp
LL ([BoundLoc r tp]
x[BoundLoc r tp] -> [BoundLoc r tp] -> [BoundLoc r tp]
forall a. [a] -> [a] -> [a]
++[BoundLoc r tp]
y)

-- | This describes information about a block inferred by
-- register-use.
data BlockInvariants arch ids = BI
    -- | Subset of assignments that are actually needed to execute the block,
    -- i.e. **not dead** assignments.
  { forall arch ids.
BlockInvariants arch ids -> Set (Some (AssignId ids))
biUsedAssignSet :: !(Set (Some (AssignId ids)))
    -- | Indices of write and cond-write statements that write to stack
    -- and whose value is later needed to execute the program.
  , forall arch ids. BlockInvariants arch ids -> Set Int
biUsedWriteSet  :: !(Set StmtIndex)
    -- | In-order list of memory accesses in block.
  , forall arch ids.
BlockInvariants arch ids -> [(Int, MemAccessInfo arch ids)]
biMemAccessList :: ![(StmtIndex, MemAccessInfo arch ids)]
    -- | Map from locations to the non-representative locations that are
    -- equal to them.
  , forall arch ids.
BlockInvariants arch ids
-> MapF (BoundLoc (ArchReg arch)) (LocList (ArchReg arch))
biLocMap :: !(MapF (BoundLoc (ArchReg arch)) (LocList (ArchReg arch)))
    -- | Map predecessors for this block along with map from locations
    -- to phi value
  , forall arch ids.
BlockInvariants arch ids
-> Map (ArchSegmentOff arch) (PostValueMap arch ids)
biPredPostValues :: !(Map (ArchSegmentOff arch) (PostValueMap arch ids))
    -- | Locations from previous block used to initial phi variables.
  , forall arch ids.
BlockInvariants arch ids -> [Some (BoundLoc (ArchReg arch))]
biPhiLocs :: ![Some (BoundLoc (ArchReg arch))]
    -- | Start constraints for block
  , forall arch ids.
BlockInvariants arch ids -> BlockStartConstraints arch
biStartConstraints :: !(BlockStartConstraints arch)
    -- | If this block ends with a call, this has the type of the function called.
    -- Otherwise, the value should be @Nothing@.
  , forall arch ids.
BlockInvariants arch ids -> Maybe (ArchFunType arch)
biCallFunType :: !(Maybe (ArchFunType arch))
    -- | Maps assignment identifiers to the associated value.
    --
    -- If an assignment id @aid@ is not in this map, then we assume it
    -- is equal to @SAVEqualAssign aid@
  , forall arch ids.
BlockInvariants arch ids
-> MapF (AssignId ids) (BlockInferValue arch ids)
biAssignMap :: !(MapF (AssignId ids) (BlockInferValue arch ids))
  }

-- | Return true if assignment is needed to execute block.
biAssignIdUsed :: AssignId ids tp -> BlockInvariants arch ids -> Bool
biAssignIdUsed :: forall ids (tp :: Type) arch.
AssignId ids tp -> BlockInvariants arch ids -> Bool
biAssignIdUsed AssignId ids tp
aid BlockInvariants arch ids
inv = Some (AssignId ids) -> Set (Some (AssignId ids)) -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member (AssignId ids tp -> Some (AssignId ids)
forall k (f :: k -> Type) (x :: k). f x -> Some f
Some AssignId ids tp
aid) (BlockInvariants arch ids -> Set (Some (AssignId ids))
forall arch ids.
BlockInvariants arch ids -> Set (Some (AssignId ids))
biUsedAssignSet BlockInvariants arch ids
inv)

-- | Return true if index corresponds to a write of the current stack
-- frame.
biWriteUsed :: StmtIndex -> BlockInvariants arch ids -> Bool
biWriteUsed :: forall arch ids. Int -> BlockInvariants arch ids -> Bool
biWriteUsed Int
idx BlockInvariants arch ids
inv = Int -> Set Int -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Int
idx (BlockInvariants arch ids -> Set Int
forall arch ids. BlockInvariants arch ids -> Set Int
biUsedWriteSet BlockInvariants arch ids
inv)

-- | This transitively back propagates blocks across
backPropagate :: forall arch ids
              .  (OrdF (ArchReg arch), MemWidth (ArchAddrWidth arch))
              => PredProvideMap (ArchReg arch) ids
              -- ^ Pred provide map computed during summarization.
              -> Map (ArchSegmentOff arch)  (DependencySet (ArchReg arch) ids)
              -> Map (ArchSegmentOff arch) (Set (Some (BoundLoc (ArchReg arch))))
              -- ^ Maps block addresses to the set of locations that
              -- we still need to back propagate demands for.
              -> Map (ArchSegmentOff arch)  (DependencySet (ArchReg arch) ids)
backPropagate :: forall arch ids.
(OrdF (ArchReg arch), MemWidth (ArchAddrWidth arch)) =>
PredProvideMap (ArchReg arch) ids
-> Map (ArchSegmentOff arch) (DependencySet (ArchReg arch) ids)
-> Map (ArchSegmentOff arch) (Set (Some (BoundLoc (ArchReg arch))))
-> Map (ArchSegmentOff arch) (DependencySet (ArchReg arch) ids)
backPropagate PredProvideMap (ArchReg arch) ids
predMap Map
  (MemSegmentOff (ArchAddrWidth arch))
  (DependencySet (ArchReg arch) ids)
depMap Map
  (MemSegmentOff (ArchAddrWidth arch))
  (Set (Some (BoundLoc (ArchReg arch))))
new =
  case Map
  (MemSegmentOff (ArchAddrWidth arch))
  (Set (Some (BoundLoc (ArchReg arch))))
-> Maybe
     ((MemSegmentOff (ArchAddrWidth arch),
       Set (Some (BoundLoc (ArchReg arch)))),
      Map
        (MemSegmentOff (ArchAddrWidth arch))
        (Set (Some (BoundLoc (ArchReg arch)))))
forall k a. Map k a -> Maybe ((k, a), Map k a)
Map.maxViewWithKey Map
  (MemSegmentOff (ArchAddrWidth arch))
  (Set (Some (BoundLoc (ArchReg arch))))
new of
    Maybe
  ((MemSegmentOff (ArchAddrWidth arch),
    Set (Some (BoundLoc (ArchReg arch)))),
   Map
     (MemSegmentOff (ArchAddrWidth arch))
     (Set (Some (BoundLoc (ArchReg arch)))))
Nothing -> Map
  (MemSegmentOff (ArchAddrWidth arch))
  (DependencySet (ArchReg arch) ids)
depMap
    Just ((MemSegmentOff (ArchAddrWidth arch)
currAddr, Set (Some (BoundLoc (ArchReg arch)))
newRegs), Map
  (MemSegmentOff (ArchAddrWidth arch))
  (Set (Some (BoundLoc (ArchReg arch))))
rest) ->
      let predAddrs :: [(MemSegmentOff (ArchAddrWidth arch),
  LocDependencyMap (ArchReg arch) ids)]
predAddrs = [(MemSegmentOff (ArchAddrWidth arch),
  LocDependencyMap (ArchReg arch) ids)]
-> MemSegmentOff (ArchAddrWidth arch)
-> PredProvideMap (ArchReg arch) ids
-> [(MemSegmentOff (ArchAddrWidth arch),
     LocDependencyMap (ArchReg arch) ids)]
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault [] MemSegmentOff (ArchAddrWidth arch)
currAddr PredProvideMap (ArchReg arch) ids
predMap
          (Map
  (MemSegmentOff (ArchAddrWidth arch))
  (DependencySet (ArchReg arch) ids)
s', Map
  (MemSegmentOff (ArchAddrWidth arch))
  (Set (Some (BoundLoc (ArchReg arch))))
rest') = Map
  (MemSegmentOff (ArchAddrWidth arch))
  (DependencySet (ArchReg arch) ids)
-> Map
     (MemSegmentOff (ArchAddrWidth arch))
     (Set (Some (BoundLoc (ArchReg arch))))
-> Set (Some (BoundLoc (ArchReg arch)))
-> [(MemSegmentOff (ArchAddrWidth arch),
     LocDependencyMap (ArchReg arch) ids)]
-> (Map
      (MemSegmentOff (ArchAddrWidth arch))
      (DependencySet (ArchReg arch) ids),
    Map
      (MemSegmentOff (ArchAddrWidth arch))
      (Set (Some (BoundLoc (ArchReg arch)))))
forall (r :: Type -> Type) ids.
(OrdF r, MemWidth (RegAddrWidth r)) =>
BlockAddrMap r (DependencySet r ids)
-> NewDemandMap r
-> Set (Some (BoundLoc r))
-> [(MemSegmentOff (RegAddrWidth r), LocDependencyMap r ids)]
-> (BlockAddrMap r (DependencySet r ids), NewDemandMap r)
backPropagateOne Map
  (MemSegmentOff (ArchAddrWidth arch))
  (DependencySet (ArchReg arch) ids)
depMap Map
  (MemSegmentOff (ArchAddrWidth arch))
  (Set (Some (BoundLoc (ArchReg arch))))
rest Set (Some (BoundLoc (ArchReg arch)))
newRegs [(MemSegmentOff (ArchAddrWidth arch),
  LocDependencyMap (ArchReg arch) ids)]
predAddrs
       in PredProvideMap (ArchReg arch) ids
-> Map
     (MemSegmentOff (ArchAddrWidth arch))
     (DependencySet (ArchReg arch) ids)
-> Map
     (MemSegmentOff (ArchAddrWidth arch))
     (Set (Some (BoundLoc (ArchReg arch))))
-> Map
     (MemSegmentOff (ArchAddrWidth arch))
     (DependencySet (ArchReg arch) ids)
forall arch ids.
(OrdF (ArchReg arch), MemWidth (ArchAddrWidth arch)) =>
PredProvideMap (ArchReg arch) ids
-> Map (ArchSegmentOff arch) (DependencySet (ArchReg arch) ids)
-> Map (ArchSegmentOff arch) (Set (Some (BoundLoc (ArchReg arch))))
-> Map (ArchSegmentOff arch) (DependencySet (ArchReg arch) ids)
backPropagate PredProvideMap (ArchReg arch) ids
predMap Map
  (MemSegmentOff (ArchAddrWidth arch))
  (DependencySet (ArchReg arch) ids)
s' Map
  (MemSegmentOff (ArchAddrWidth arch))
  (Set (Some (BoundLoc (ArchReg arch))))
rest'

------------------------------------------------------------------------
-- registerUse

-- | Create map from locations to the non-representative locations
-- that are equal to them.
mkDepLocMap :: forall arch
            .  OrdF (ArchReg arch)
            => BlockStartConstraints arch
            -> MapF (BoundLoc (ArchReg arch)) (LocList (ArchReg arch))
mkDepLocMap :: forall arch.
OrdF (ArchReg arch) =>
BlockStartConstraints arch
-> MapF (BoundLoc (ArchReg arch)) (LocList (ArchReg arch))
mkDepLocMap BlockStartConstraints arch
cns =
  let addNonRep :: MapF (BoundLoc (ArchReg arch)) (LocList (ArchReg arch))
                -> BoundLoc (ArchReg arch) tp
                -> InitInferValue arch tp
                -> MapF (BoundLoc (ArchReg arch)) (LocList (ArchReg arch))
      addNonRep :: forall (tp :: Type).
MapF (BoundLoc (ArchReg arch)) (LocList (ArchReg arch))
-> BoundLoc (ArchReg arch) tp
-> InitInferValue arch tp
-> MapF (BoundLoc (ArchReg arch)) (LocList (ArchReg arch))
addNonRep MapF (BoundLoc (ArchReg arch)) (LocList (ArchReg arch))
m BoundLoc (ArchReg arch) tp
l (RegEqualLoc BoundLoc (ArchReg arch) tp
r) = (LocList (ArchReg arch) tp
 -> LocList (ArchReg arch) tp -> LocList (ArchReg arch) tp)
-> BoundLoc (ArchReg arch) tp
-> LocList (ArchReg arch) tp
-> MapF (BoundLoc (ArchReg arch)) (LocList (ArchReg arch))
-> MapF (BoundLoc (ArchReg arch)) (LocList (ArchReg arch))
forall {v} (k :: v -> Type) (a :: v -> Type) (tp :: v).
OrdF k =>
(a tp -> a tp -> a tp) -> k tp -> a tp -> MapF k a -> MapF k a
MapF.insertWith LocList (ArchReg arch) tp
-> LocList (ArchReg arch) tp -> LocList (ArchReg arch) tp
forall a. Semigroup a => a -> a -> a
(<>) BoundLoc (ArchReg arch) tp
r ([BoundLoc (ArchReg arch) tp] -> LocList (ArchReg arch) tp
forall (r :: Type -> Type) (tp :: Type).
[BoundLoc r tp] -> LocList r tp
LL [BoundLoc (ArchReg arch) tp
l]) MapF (BoundLoc (ArchReg arch)) (LocList (ArchReg arch))
m
      addNonRep MapF (BoundLoc (ArchReg arch)) (LocList (ArchReg arch))
m BoundLoc (ArchReg arch) tp
_ InitInferValue arch tp
_ = MapF (BoundLoc (ArchReg arch)) (LocList (ArchReg arch))
m
   in (forall (tp :: Type).
 MapF (BoundLoc (ArchReg arch)) (LocList (ArchReg arch))
 -> BoundLoc (ArchReg arch) tp
 -> InitInferValue arch tp
 -> MapF (BoundLoc (ArchReg arch)) (LocList (ArchReg arch)))
-> MapF (BoundLoc (ArchReg arch)) (LocList (ArchReg arch))
-> LocMap (ArchReg arch) (InitInferValue arch)
-> MapF (BoundLoc (ArchReg arch)) (LocList (ArchReg arch))
forall a (r :: Type -> Type) (v :: Type -> Type).
(forall (tp :: Type). a -> BoundLoc r tp -> v tp -> a)
-> a -> LocMap r v -> a
foldLocMap MapF (BoundLoc (ArchReg arch)) (LocList (ArchReg arch))
-> BoundLoc (ArchReg arch) tp
-> InitInferValue arch tp
-> MapF (BoundLoc (ArchReg arch)) (LocList (ArchReg arch))
forall (tp :: Type).
MapF (BoundLoc (ArchReg arch)) (LocList (ArchReg arch))
-> BoundLoc (ArchReg arch) tp
-> InitInferValue arch tp
-> MapF (BoundLoc (ArchReg arch)) (LocList (ArchReg arch))
addNonRep MapF (BoundLoc (ArchReg arch)) (LocList (ArchReg arch))
forall {v} (k :: v -> Type) (a :: v -> Type). MapF k a
MapF.empty (BlockStartConstraints arch
-> LocMap (ArchReg arch) (InitInferValue arch)
forall arch.
BlockStartConstraints arch
-> LocMap (ArchReg arch) (InitInferValue arch)
bscLocMap BlockStartConstraints arch
cns)

mkBlockInvariants :: forall arch ids
                  .  (HasRepr (ArchReg arch) TypeRepr
                     , OrdF (ArchReg arch)
                     , ShowF (ArchReg arch)
                     , MemWidth (ArchAddrWidth arch)
                     )
                  => FunPredMap (ArchAddrWidth arch)
                  -> (ArchSegmentOff arch
                       -> ArchSegmentOff arch
                       -> PostValueMap arch ids)
                     -- ^ Maps precessor and successor block addresses to the post value from the
                     -- jump from predecessor to successor.
                  -> ArchSegmentOff arch
                     -- ^ Address of thsi block.
                  -> BlockUsageSummary arch ids
                  -> DependencySet (ArchReg arch) ids
                     -- ^ Dependency set for block.
                  -> BlockInvariants arch ids
mkBlockInvariants :: forall arch ids.
(HasRepr (ArchReg arch) TypeRepr, OrdF (ArchReg arch),
 ShowF (ArchReg arch), MemWidth (ArchAddrWidth arch)) =>
FunPredMap (ArchAddrWidth arch)
-> (ArchSegmentOff arch
    -> ArchSegmentOff arch -> PostValueMap arch ids)
-> ArchSegmentOff arch
-> BlockUsageSummary arch ids
-> DependencySet (ArchReg arch) ids
-> BlockInvariants arch ids
mkBlockInvariants FunPredMap (ArchAddrWidth arch)
predMap MemSegmentOff (ArchAddrWidth arch)
-> MemSegmentOff (ArchAddrWidth arch) -> PostValueMap arch ids
valueMap MemSegmentOff (ArchAddrWidth arch)
addr BlockUsageSummary arch ids
summary DependencySet (ArchReg arch) ids
deps =
  let cns :: BlockStartConstraints arch
cns   = BlockUsageSummary arch ids -> BlockStartConstraints arch
forall arch ids.
BlockUsageSummary arch ids -> BlockStartConstraints arch
blockUsageStartConstraints BlockUsageSummary arch ids
summary
      -- Get addresses of blocks that jump to this block
      preds :: [MemSegmentOff (ArchAddrWidth arch)]
preds = [MemSegmentOff (ArchAddrWidth arch)]
-> MemSegmentOff (ArchAddrWidth arch)
-> FunPredMap (ArchAddrWidth arch)
-> [MemSegmentOff (ArchAddrWidth arch)]
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault [] MemSegmentOff (ArchAddrWidth arch)
addr FunPredMap (ArchAddrWidth arch)
predMap
      -- Maps address of predecessor to the post value for this block.
      predFn :: MemSegmentOff (ArchAddrWidth arch)
-> (MemSegmentOff (ArchAddrWidth arch), PostValueMap arch ids)
predFn MemSegmentOff (ArchAddrWidth arch)
predAddr = (MemSegmentOff (ArchAddrWidth arch)
predAddr, MemSegmentOff (ArchAddrWidth arch)
-> MemSegmentOff (ArchAddrWidth arch) -> PostValueMap arch ids
valueMap MemSegmentOff (ArchAddrWidth arch)
predAddr MemSegmentOff (ArchAddrWidth arch)
addr)
      predphilist :: [(MemSegmentOff (ArchAddrWidth arch), PostValueMap arch ids)]
predphilist = MemSegmentOff (ArchAddrWidth arch)
-> (MemSegmentOff (ArchAddrWidth arch), PostValueMap arch ids)
predFn (MemSegmentOff (ArchAddrWidth arch)
 -> (MemSegmentOff (ArchAddrWidth arch), PostValueMap arch ids))
-> [MemSegmentOff (ArchAddrWidth arch)]
-> [(MemSegmentOff (ArchAddrWidth arch), PostValueMap arch ids)]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [MemSegmentOff (ArchAddrWidth arch)]
preds
   in BI { biUsedAssignSet :: Set (Some (AssignId ids))
biUsedAssignSet = DependencySet (ArchReg arch) ids -> Set (Some (AssignId ids))
forall (r :: Type -> Type) ids.
DependencySet r ids -> Set (Some (AssignId ids))
dsAssignSet DependencySet (ArchReg arch) ids
deps
         , biUsedWriteSet :: Set Int
biUsedWriteSet  = DependencySet (ArchReg arch) ids -> Set Int
forall (r :: Type -> Type) ids. DependencySet r ids -> Set Int
dsWriteStmtIndexSet DependencySet (ArchReg arch) ids
deps
         , biMemAccessList :: [(Int, MemAccessInfo arch ids)]
biMemAccessList = [(Int, MemAccessInfo arch ids)] -> [(Int, MemAccessInfo arch ids)]
forall a. [a] -> [a]
reverse (InferState arch ids -> [(Int, MemAccessInfo arch ids)]
forall arch ids.
InferState arch ids -> [(Int, MemAccessInfo arch ids)]
sisMemAccessStack (BlockUsageSummary arch ids -> InferState arch ids
forall arch ids. BlockUsageSummary arch ids -> InferState arch ids
blockInferState BlockUsageSummary arch ids
summary))
         , biLocMap :: MapF (BoundLoc (ArchReg arch)) (LocList (ArchReg arch))
biLocMap = BlockStartConstraints arch
-> MapF (BoundLoc (ArchReg arch)) (LocList (ArchReg arch))
forall arch.
OrdF (ArchReg arch) =>
BlockStartConstraints arch
-> MapF (BoundLoc (ArchReg arch)) (LocList (ArchReg arch))
mkDepLocMap BlockStartConstraints arch
cns
         , biPredPostValues :: Map (MemSegmentOff (ArchAddrWidth arch)) (PostValueMap arch ids)
biPredPostValues = [(MemSegmentOff (ArchAddrWidth arch), PostValueMap arch ids)]
-> Map (MemSegmentOff (ArchAddrWidth arch)) (PostValueMap arch ids)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(MemSegmentOff (ArchAddrWidth arch), PostValueMap arch ids)]
predphilist
         , biPhiLocs :: [Some (BoundLoc (ArchReg arch))]
biPhiLocs = Set (Some (BoundLoc (ArchReg arch)))
-> [Some (BoundLoc (ArchReg arch))]
forall a. Set a -> [a]
Set.toList (DependencySet (ArchReg arch) ids
-> Set (Some (BoundLoc (ArchReg arch)))
forall (r :: Type -> Type) ids.
DependencySet r ids -> Set (Some (BoundLoc r))
dsLocSet DependencySet (ArchReg arch) ids
deps)
         , biStartConstraints :: BlockStartConstraints arch
biStartConstraints = BlockStartConstraints arch
cns
         , biCallFunType :: Maybe (ArchFunType arch)
biCallFunType = BlockUsageSummary arch ids -> Maybe (ArchFunType arch)
forall arch ids.
BlockUsageSummary arch ids -> Maybe (ArchFunType arch)
blockCallFunType BlockUsageSummary arch ids
summary
         , biAssignMap :: MapF (AssignId ids) (BlockInferValue arch ids)
biAssignMap = InferState arch ids
-> MapF (AssignId ids) (BlockInferValue arch ids)
forall arch ids.
InferState arch ids
-> MapF (AssignId ids) (BlockInferValue arch ids)
sisAssignMap (BlockUsageSummary arch ids -> InferState arch ids
forall arch ids. BlockUsageSummary arch ids -> InferState arch ids
blockInferState BlockUsageSummary arch ids
summary)
         }

-- | Map from block starting addresses to the invariants inferred for that block.
type BlockInvariantMap arch ids
   = Map (ArchSegmentOff arch) (BlockInvariants arch ids)

-- | This analyzes a function to determine which registers must be available to
-- the highest index above sp0 that is read or written.
registerUse :: forall arch ids
            .  ArchConstraints arch
            => RegisterUseContext arch
            -> DiscoveryFunInfo arch ids
            -> Except (RegisterUseError arch)
                      (BlockInvariantMap arch ids)
registerUse :: forall arch ids.
ArchConstraints arch =>
RegisterUseContext arch
-> DiscoveryFunInfo arch ids
-> Except (RegisterUseError arch) (BlockInvariantMap arch ids)
registerUse RegisterUseContext arch
rctx DiscoveryFunInfo arch ids
fun = do
  let predMap :: FunPredMap (RegAddrWidth (ArchReg arch))
predMap = DiscoveryFunInfo arch ids
-> FunPredMap (RegAddrWidth (ArchReg arch))
forall arch ids.
DiscoveryFunInfo arch ids -> FunPredMap (ArchAddrWidth arch)
funBlockPreds DiscoveryFunInfo arch ids
fun
  let blockMap :: Map
  (MemSegmentOff (RegAddrWidth (ArchReg arch)))
  (ParsedBlock arch ids)
blockMap = DiscoveryFunInfo arch ids
funDiscoveryFunInfo arch ids
-> Getting
     (Map
        (MemSegmentOff (RegAddrWidth (ArchReg arch)))
        (ParsedBlock arch ids))
     (DiscoveryFunInfo arch ids)
     (Map
        (MemSegmentOff (RegAddrWidth (ArchReg arch)))
        (ParsedBlock arch ids))
-> Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (ParsedBlock arch ids)
forall s a. s -> Getting a s a -> a
^.Getting
  (Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (ParsedBlock arch ids))
  (DiscoveryFunInfo arch ids)
  (Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (ParsedBlock arch ids))
forall arch ids (f :: Type -> Type).
Functor f =>
(Map (ArchSegmentOff arch) (ParsedBlock arch ids)
 -> f (Map (ArchSegmentOff arch) (ParsedBlock arch ids)))
-> DiscoveryFunInfo arch ids -> f (DiscoveryFunInfo arch ids)
parsedBlocks
  -- Infer start constraints
  Map
  (MemSegmentOff (RegAddrWidth (ArchReg arch)))
  (ParsedBlock arch ids, BlockStartConstraints arch,
   InferState arch ids,
   Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (PostValueMap arch ids))
cnsMap <- RegisterUseContext arch
-> Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (ParsedBlock arch ids)
-> MemSegmentOff (RegAddrWidth (ArchReg arch))
-> ExceptT
     (RegisterUseError arch)
     Identity
     (Map
        (MemSegmentOff (RegAddrWidth (ArchReg arch)))
        (ParsedBlock arch ids, BlockStartConstraints arch,
         InferState arch ids,
         Map
           (MemSegmentOff (RegAddrWidth (ArchReg arch)))
           (PostValueMap arch ids)))
forall arch ids.
ArchConstraints arch =>
RegisterUseContext arch
-> Map (ArchSegmentOff arch) (ParsedBlock arch ids)
-> ArchSegmentOff arch
-> Except
     (RegisterUseError arch)
     (Map (ArchSegmentOff arch) (StartInferInfo arch ids))
inferStartConstraints RegisterUseContext arch
rctx Map
  (MemSegmentOff (RegAddrWidth (ArchReg arch)))
  (ParsedBlock arch ids)
blockMap (DiscoveryFunInfo arch ids
-> MemSegmentOff (RegAddrWidth (ArchReg arch))
forall arch ids. DiscoveryFunInfo arch ids -> ArchSegmentOff arch
discoveredFunAddr DiscoveryFunInfo arch ids
fun)
  -- Infer demand summary for each block
  Map
  (MemSegmentOff (RegAddrWidth (ArchReg arch)))
  (BlockUsageSummary arch ids)
usageMap <- ((ParsedBlock arch ids, BlockStartConstraints arch,
  InferState arch ids,
  Map
    (MemSegmentOff (RegAddrWidth (ArchReg arch)))
    (PostValueMap arch ids))
 -> ExceptT
      (RegisterUseError arch) Identity (BlockUsageSummary arch ids))
-> Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (ParsedBlock arch ids, BlockStartConstraints arch,
      InferState arch ids,
      Map
        (MemSegmentOff (RegAddrWidth (ArchReg arch)))
        (PostValueMap arch ids))
-> ExceptT
     (RegisterUseError arch)
     Identity
     (Map
        (MemSegmentOff (RegAddrWidth (ArchReg arch)))
        (BlockUsageSummary arch ids))
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 (MemSegmentOff (RegAddrWidth (ArchReg arch))) a
-> f (Map (MemSegmentOff (RegAddrWidth (ArchReg arch))) b)
traverse (\(ParsedBlock arch ids
b, BlockStartConstraints arch
cns,InferState arch ids
s,Map
  (MemSegmentOff (RegAddrWidth (ArchReg arch)))
  (PostValueMap arch ids)
_) -> RegisterUseContext arch
-> BlockStartConstraints arch
-> InferState arch ids
-> ParsedBlock arch ids
-> ExceptT
     (RegisterUseError arch) Identity (BlockUsageSummary arch ids)
forall arch ids.
(RegisterInfo (ArchReg arch), FoldableF (ArchStmt arch),
 FoldableFC (ArchFn arch)) =>
RegisterUseContext arch
-> BlockStartConstraints arch
-> InferState arch ids
-> ParsedBlock arch ids
-> Except (RegisterUseError arch) (BlockUsageSummary arch ids)
mkBlockUsageSummary RegisterUseContext arch
rctx BlockStartConstraints arch
cns InferState arch ids
s ParsedBlock arch ids
b) Map
  (MemSegmentOff (RegAddrWidth (ArchReg arch)))
  (ParsedBlock arch ids, BlockStartConstraints arch,
   InferState arch ids,
   Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (PostValueMap arch ids))
cnsMap
  -- Back propagate to compute demands
  let bru :: BlockAddrMap (ArchReg arch) (DependencySet (ArchReg arch) ids)
      bru :: BlockAddrMap (ArchReg arch) (DependencySet (ArchReg arch) ids)
bru = Getting
  (DependencySet (ArchReg arch) ids)
  (BlockUsageSummary arch ids)
  (DependencySet (ArchReg arch) ids)
-> BlockUsageSummary arch ids -> DependencySet (ArchReg arch) ids
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
view Getting
  (DependencySet (ArchReg arch) ids)
  (BlockUsageSummary arch ids)
  (DependencySet (ArchReg arch) ids)
forall arch ids (f :: Type -> Type).
Functor f =>
(DependencySet (ArchReg arch) ids
 -> f (DependencySet (ArchReg arch) ids))
-> BlockUsageSummary arch ids -> f (BlockUsageSummary arch ids)
blockExecDemands (BlockUsageSummary arch ids -> DependencySet (ArchReg arch) ids)
-> Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (BlockUsageSummary arch ids)
-> BlockAddrMap (ArchReg arch) (DependencySet (ArchReg arch) ids)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Map
  (MemSegmentOff (RegAddrWidth (ArchReg arch)))
  (BlockUsageSummary arch ids)
usageMap

  let providePair :: ArchSegmentOff arch -> (ArchSegmentOff arch, LocDependencyMap (ArchReg arch) ids)
      providePair :: MemSegmentOff (RegAddrWidth (ArchReg arch))
-> (MemSegmentOff (RegAddrWidth (ArchReg arch)),
    LocDependencyMap (ArchReg arch) ids)
providePair MemSegmentOff (RegAddrWidth (ArchReg arch))
prev = (MemSegmentOff (RegAddrWidth (ArchReg arch))
prev, LocDependencyMap (ArchReg arch) ids
lm)
        where usage :: BlockUsageSummary arch ids
usage = case MemSegmentOff (RegAddrWidth (ArchReg arch))
-> Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (BlockUsageSummary arch ids)
-> Maybe (BlockUsageSummary arch ids)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup MemSegmentOff (RegAddrWidth (ArchReg arch))
prev Map
  (MemSegmentOff (RegAddrWidth (ArchReg arch)))
  (BlockUsageSummary arch ids)
usageMap of
                        Maybe (BlockUsageSummary arch ids)
Nothing -> String -> BlockUsageSummary arch ids
forall a. HasCallStack => String -> a
error String
"registerUse: Could not find prev"
                        Just BlockUsageSummary arch ids
usage' -> BlockUsageSummary arch ids
usage'
              cns :: BlockStartConstraints arch
cns = BlockUsageSummary arch ids -> BlockStartConstraints arch
forall arch ids.
BlockUsageSummary arch ids -> BlockStartConstraints arch
blockUsageStartConstraints BlockUsageSummary arch ids
usage
              cache :: Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
cache = BlockUsageSummary arch ids
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
forall arch ids.
BlockUsageSummary arch ids
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
assignDeps BlockUsageSummary arch ids
usage
              lm :: LocDependencyMap (ArchReg arch) ids
lm = LocMap { locMapRegs :: MapF (ArchReg arch) (Const (DependencySet (ArchReg arch) ids))
locMapRegs = RegDependencyMap arch ids
-> MapF (ArchReg arch) (Const (DependencySet (ArchReg arch) ids))
forall arch ids.
RegDependencyMap arch ids
-> MapF (ArchReg arch) (Const (DependencySet (ArchReg arch) ids))
rdmMap (BlockUsageSummary arch ids -> RegDependencyMap arch ids
forall arch ids.
BlockUsageSummary arch ids -> RegDependencyMap arch ids
blockRegDependencies BlockUsageSummary arch ids
usage)
                          , locMapStack :: MemMap
  (MemInt (RegAddrWidth (ArchReg arch)))
  (Const (DependencySet (ArchReg arch) ids))
locMapStack =
                              (forall (x :: Type).
 InferStackValue arch ids x
 -> Const (DependencySet (ArchReg arch) ids) x)
-> MemMap
     (MemInt (RegAddrWidth (ArchReg arch))) (InferStackValue arch ids)
-> MemMap
     (MemInt (RegAddrWidth (ArchReg arch)))
     (Const (DependencySet (ArchReg arch) ids))
forall {k} (m :: (k -> Type) -> Type) (f :: k -> Type)
       (g :: k -> Type).
FunctorF m =>
(forall (x :: k). f x -> g x) -> m f -> m g
forall (f :: Type -> Type) (g :: Type -> Type).
(forall (x :: Type). f x -> g x)
-> MemMap (MemInt (RegAddrWidth (ArchReg arch))) f
-> MemMap (MemInt (RegAddrWidth (ArchReg arch))) g
fmapF (DependencySet (ArchReg arch) ids
-> Const (DependencySet (ArchReg arch) ids) x
forall {k} a (b :: k). a -> Const a b
Const (DependencySet (ArchReg arch) ids
 -> Const (DependencySet (ArchReg arch) ids) x)
-> (InferStackValue arch ids x -> DependencySet (ArchReg arch) ids)
-> InferStackValue arch ids x
-> Const (DependencySet (ArchReg arch) ids) x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockStartConstraints arch
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
-> InferStackValue arch ids x
-> DependencySet (ArchReg arch) ids
forall arch ids (tp :: Type).
(HasCallStack, MemWidth (ArchAddrWidth arch),
 OrdF (ArchReg arch)) =>
BlockStartConstraints arch
-> Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
-> InferStackValue arch ids tp
-> DependencySet (ArchReg arch) ids
inferStackValueDeps BlockStartConstraints arch
cns Map (Some (AssignId ids)) (DependencySet (ArchReg arch) ids)
cache)
                                    (InferState arch ids
-> MemMap
     (MemInt (RegAddrWidth (ArchReg arch))) (InferStackValue arch ids)
forall arch ids.
InferState arch ids
-> MemMap (MemInt (ArchAddrWidth arch)) (InferStackValue arch ids)
sisStack (BlockUsageSummary arch ids -> InferState arch ids
forall arch ids. BlockUsageSummary arch ids -> InferState arch ids
blockInferState BlockUsageSummary arch ids
usage))
                          }
  let predProvideMap :: Map
  (MemSegmentOff (RegAddrWidth (ArchReg arch)))
  [(MemSegmentOff (RegAddrWidth (ArchReg arch)),
    LocDependencyMap (ArchReg arch) ids)]
predProvideMap = ([MemSegmentOff (RegAddrWidth (ArchReg arch))]
 -> [(MemSegmentOff (RegAddrWidth (ArchReg arch)),
      LocDependencyMap (ArchReg arch) ids)])
-> FunPredMap (RegAddrWidth (ArchReg arch))
-> Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     [(MemSegmentOff (RegAddrWidth (ArchReg arch)),
       LocDependencyMap (ArchReg arch) ids)]
forall a b.
(a -> b)
-> Map (MemSegmentOff (RegAddrWidth (ArchReg arch))) a
-> Map (MemSegmentOff (RegAddrWidth (ArchReg arch))) b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap ((MemSegmentOff (RegAddrWidth (ArchReg arch))
 -> (MemSegmentOff (RegAddrWidth (ArchReg arch)),
     LocDependencyMap (ArchReg arch) ids))
-> [MemSegmentOff (RegAddrWidth (ArchReg arch))]
-> [(MemSegmentOff (RegAddrWidth (ArchReg arch)),
     LocDependencyMap (ArchReg arch) ids)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap MemSegmentOff (RegAddrWidth (ArchReg arch))
-> (MemSegmentOff (RegAddrWidth (ArchReg arch)),
    LocDependencyMap (ArchReg arch) ids)
providePair) FunPredMap (RegAddrWidth (ArchReg arch))
predMap
  let propMap :: BlockAddrMap (ArchReg arch) (DependencySet (ArchReg arch) ids)
propMap = Map
  (MemSegmentOff (RegAddrWidth (ArchReg arch)))
  [(MemSegmentOff (RegAddrWidth (ArchReg arch)),
    LocDependencyMap (ArchReg arch) ids)]
-> BlockAddrMap (ArchReg arch) (DependencySet (ArchReg arch) ids)
-> Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (Set (Some (BoundLoc (ArchReg arch))))
-> BlockAddrMap (ArchReg arch) (DependencySet (ArchReg arch) ids)
forall arch ids.
(OrdF (ArchReg arch), MemWidth (ArchAddrWidth arch)) =>
PredProvideMap (ArchReg arch) ids
-> Map (ArchSegmentOff arch) (DependencySet (ArchReg arch) ids)
-> Map (ArchSegmentOff arch) (Set (Some (BoundLoc (ArchReg arch))))
-> Map (ArchSegmentOff arch) (DependencySet (ArchReg arch) ids)
backPropagate Map
  (MemSegmentOff (RegAddrWidth (ArchReg arch)))
  [(MemSegmentOff (RegAddrWidth (ArchReg arch)),
    LocDependencyMap (ArchReg arch) ids)]
predProvideMap BlockAddrMap (ArchReg arch) (DependencySet (ArchReg arch) ids)
bru (DependencySet (ArchReg arch) ids
-> Set (Some (BoundLoc (ArchReg arch)))
forall (r :: Type -> Type) ids.
DependencySet r ids -> Set (Some (BoundLoc r))
dsLocSet (DependencySet (ArchReg arch) ids
 -> Set (Some (BoundLoc (ArchReg arch))))
-> BlockAddrMap (ArchReg arch) (DependencySet (ArchReg arch) ids)
-> Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (Set (Some (BoundLoc (ArchReg arch))))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockAddrMap (ArchReg arch) (DependencySet (ArchReg arch) ids)
bru)

  -- Generate final invariants
  let phiValFn :: ArchSegmentOff arch -> ArchSegmentOff arch -> PostValueMap arch ids
      phiValFn :: MemSegmentOff (RegAddrWidth (ArchReg arch))
-> MemSegmentOff (RegAddrWidth (ArchReg arch))
-> PostValueMap arch ids
phiValFn MemSegmentOff (RegAddrWidth (ArchReg arch))
predAddr MemSegmentOff (RegAddrWidth (ArchReg arch))
nextAddr =
        case MemSegmentOff (RegAddrWidth (ArchReg arch))
-> Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (ParsedBlock arch ids, BlockStartConstraints arch,
      InferState arch ids,
      Map
        (MemSegmentOff (RegAddrWidth (ArchReg arch)))
        (PostValueMap arch ids))
-> Maybe
     (ParsedBlock arch ids, BlockStartConstraints arch,
      InferState arch ids,
      Map
        (MemSegmentOff (RegAddrWidth (ArchReg arch)))
        (PostValueMap arch ids))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup MemSegmentOff (RegAddrWidth (ArchReg arch))
predAddr Map
  (MemSegmentOff (RegAddrWidth (ArchReg arch)))
  (ParsedBlock arch ids, BlockStartConstraints arch,
   InferState arch ids,
   Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (PostValueMap arch ids))
cnsMap of
          Maybe
  (ParsedBlock arch ids, BlockStartConstraints arch,
   InferState arch ids,
   Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (PostValueMap arch ids))
Nothing -> String -> PostValueMap arch ids
forall a. HasCallStack => String -> a
error String
"Could not find predAddr"
          Just (ParsedBlock arch ids
_,BlockStartConstraints arch
_,InferState arch ids
_,Map
  (MemSegmentOff (RegAddrWidth (ArchReg arch)))
  (PostValueMap arch ids)
nextVals) -> PostValueMap arch ids
-> MemSegmentOff (RegAddrWidth (ArchReg arch))
-> Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (PostValueMap arch ids)
-> PostValueMap arch ids
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault PostValueMap arch ids
forall arch ids. PostValueMap arch ids
emptyPVM MemSegmentOff (RegAddrWidth (ArchReg arch))
nextAddr Map
  (MemSegmentOff (RegAddrWidth (ArchReg arch)))
  (PostValueMap arch ids)
nextVals
  BlockInvariantMap arch ids
-> Except (RegisterUseError arch) (BlockInvariantMap arch ids)
forall a. a -> ExceptT (RegisterUseError arch) Identity a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (BlockInvariantMap arch ids
 -> Except (RegisterUseError arch) (BlockInvariantMap arch ids))
-> BlockInvariantMap arch ids
-> Except (RegisterUseError arch) (BlockInvariantMap arch ids)
forall a b. (a -> b) -> a -> b
$ (MemSegmentOff (RegAddrWidth (ArchReg arch))
 -> BlockUsageSummary arch ids
 -> DependencySet (ArchReg arch) ids
 -> BlockInvariants arch ids)
-> Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (BlockUsageSummary arch ids)
-> BlockAddrMap (ArchReg arch) (DependencySet (ArchReg arch) ids)
-> BlockInvariantMap arch ids
forall k a b c.
Ord k =>
(k -> a -> b -> c) -> Map k a -> Map k b -> Map k c
Map.intersectionWithKey (FunPredMap (RegAddrWidth (ArchReg arch))
-> (MemSegmentOff (RegAddrWidth (ArchReg arch))
    -> MemSegmentOff (RegAddrWidth (ArchReg arch))
    -> PostValueMap arch ids)
-> MemSegmentOff (RegAddrWidth (ArchReg arch))
-> BlockUsageSummary arch ids
-> DependencySet (ArchReg arch) ids
-> BlockInvariants arch ids
forall arch ids.
(HasRepr (ArchReg arch) TypeRepr, OrdF (ArchReg arch),
 ShowF (ArchReg arch), MemWidth (ArchAddrWidth arch)) =>
FunPredMap (ArchAddrWidth arch)
-> (ArchSegmentOff arch
    -> ArchSegmentOff arch -> PostValueMap arch ids)
-> ArchSegmentOff arch
-> BlockUsageSummary arch ids
-> DependencySet (ArchReg arch) ids
-> BlockInvariants arch ids
mkBlockInvariants FunPredMap (RegAddrWidth (ArchReg arch))
predMap MemSegmentOff (RegAddrWidth (ArchReg arch))
-> MemSegmentOff (RegAddrWidth (ArchReg arch))
-> PostValueMap arch ids
phiValFn) Map
  (MemSegmentOff (RegAddrWidth (ArchReg arch)))
  (BlockUsageSummary arch ids)
usageMap BlockAddrMap (ArchReg arch) (DependencySet (ArchReg arch) ids)
propMap