{-| This performs a whole-program analysis to compute which registers
are needed to evaluate different blocks.  It can be used to compute
which registers are needed for function arguments.
-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
module Data.Macaw.Analysis.FunctionArgs
  ( functionDemands
    -- * Callbacks for architecture-specific information
  , ArchDemandInfo(..)
  , ArchTermStmtRegEffects(..)
  , ComputeArchTermStmtEffects
  , ResolveCallArgsFn
    -- * Demands
  , AddrDemandMap
  , DemandSet(..)
    -- * Errors
  , FunctionSummaryFailureMap
  , FunctionArgAnalysisFailure(..)
    -- * Utilities
  , RegSegmentOff
  , RegisterSet
  ) where

import           Control.Lens
import           Control.Monad (when)
import           Control.Monad.Except (Except, MonadError(..), runExcept)
import           Control.Monad.Reader (MonadReader(..), ReaderT(..), asks)
import           Control.Monad.State.Strict (State, StateT, evalStateT, gets, modify', runState)
import           Data.Foldable
import qualified Data.Kind as Kind
import           Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import           Data.Maybe

import           Data.Parameterized.Classes
import           Data.Parameterized.Some
import           Data.Parameterized.TraversableF
import           Data.Parameterized.TraversableFC
import           Data.Set (Set)
import qualified Data.Set as Set

import           Data.Macaw.CFG
import           Data.Macaw.CFG.DemandSet
  ( DemandContext
  , demandConstraints
  , hasSideEffects
  )
import           Data.Macaw.Discovery.State
import           Data.Macaw.Types

-------------------------------------------------------------------------------
--PreBlockMap

-- | Map from blocks to their predcessors within a function.
type PredBlockMap arch = Map (ArchSegmentOff arch) [ArchSegmentOff arch]

-- | Generate map from block within a function to their predecessors
predBlockMap :: DiscoveryFunInfo arch ids -> PredBlockMap arch
predBlockMap :: forall arch ids. DiscoveryFunInfo arch ids -> PredBlockMap arch
predBlockMap DiscoveryFunInfo arch ids
finfo =
  ([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))
dest, [ParsedBlock arch ids -> MemSegmentOff (RegAddrWidth (ArchReg arch))
forall arch ids. ParsedBlock arch ids -> ArchSegmentOff arch
pblockAddr ParsedBlock arch ids
b])
    | 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
finfoDiscoveryFunInfo 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)
    , MemSegmentOff (RegAddrWidth (ArchReg arch))
dest <- 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)
    ]

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

-- The algorithm computes the set of direct deps (i.e., from writes)
-- and then iterates, propagating back via the register deps.  It
-- doesn't compute assignment uses (although it could) mainly to keep
-- memory use down.  We recompute assignment use later in RegisterUse.
--
-- The basic question this analysis answers is: what arguments does a
-- function require, and what results does it produce?
--
-- There are 3 phases
-- 1. Block-local summarization
-- 2. Function-local summarization
-- 3. Global fixpoint calculation.
--
-- The first 2 phases calculate, for each function, the following information:
--
-- A. What registers are required by a function (ignoring function
--    calls)?
--
-- B. Given that result register {rax, rdx, xmm0} is demanded, what
--    extra register arguments are required, and what extra result
--    arguments are required?
--
-- C. Given that function f now requires argument r, what extra
--    arguments are required, and what extra result registers are
--    demanded?

-- | A set of registers
type RegisterSet (r :: Type -> Kind.Type) = Set (Some r)

-- | A memory segment offset compatible with the architecture registers.
type RegSegmentOff r = MemSegmentOff (RegAddrWidth r)

-- | This stores the information that is needed to compute a value of some sort.
data DemandSet (r :: Type -> Kind.Type) =
    DemandSet { forall (r :: Type -> Type). DemandSet r -> RegisterSet r
registerDemands       :: !(RegisterSet r)
                -- | Maps a function address to the registers we need it to return.
              , forall (r :: Type -> Type).
DemandSet r -> Map (MemSegmentOff (RegAddrWidth r)) (RegisterSet r)
functionResultDemands :: !(Map (MemSegmentOff (RegAddrWidth r)) (RegisterSet r))
              }

-- | Return True if the demand set indicates no registers are needed.
isEmptyDemandSet :: DemandSet r -> Bool
isEmptyDemandSet :: forall (r :: Type -> Type). DemandSet r -> Bool
isEmptyDemandSet DemandSet r
ds =
  Set (Some r) -> Bool
forall a. Set a -> Bool
Set.null (DemandSet r -> Set (Some r)
forall (r :: Type -> Type). DemandSet r -> RegisterSet r
registerDemands DemandSet r
ds) Bool -> Bool -> Bool
&& Map (MemSegmentOff (RegAddrWidth r)) (Set (Some r)) -> Bool
forall k a. Map k a -> Bool
Map.null (DemandSet r -> Map (MemSegmentOff (RegAddrWidth r)) (Set (Some r))
forall (r :: Type -> Type).
DemandSet r -> Map (MemSegmentOff (RegAddrWidth r)) (RegisterSet r)
functionResultDemands DemandSet r
ds)

-- | Create a demand set for specific registers.
registerDemandSet :: RegisterSet r -> DemandSet r
registerDemandSet :: forall (r :: Type -> Type). RegisterSet r -> DemandSet r
registerDemandSet RegisterSet r
s = DemandSet { registerDemands :: RegisterSet r
registerDemands = RegisterSet r
s
                                , functionResultDemands :: Map (MemSegmentOff (RegAddrWidth r)) (RegisterSet r)
functionResultDemands = Map (MemSegmentOff (RegAddrWidth r)) (RegisterSet r)
forall k a. Map k a
Map.empty
                                }

-- | @demandFunctionReturn f r@ demands the return register of @r@ from @f@.
demandFunctionReturn :: MemSegmentOff (RegAddrWidth r) -> Some r -> DemandSet r
demandFunctionReturn :: forall (r :: Type -> Type).
MemSegmentOff (RegAddrWidth r) -> Some r -> DemandSet r
demandFunctionReturn MemSegmentOff (RegAddrWidth r)
faddr Some r
sr =
  DemandSet { registerDemands :: RegisterSet r
registerDemands = RegisterSet r
forall a. Set a
Set.empty
            , functionResultDemands :: Map (MemSegmentOff (RegAddrWidth r)) (RegisterSet r)
functionResultDemands = MemSegmentOff (RegAddrWidth r)
-> RegisterSet r
-> Map (MemSegmentOff (RegAddrWidth r)) (RegisterSet r)
forall k a. k -> a -> Map k a
Map.singleton MemSegmentOff (RegAddrWidth r)
faddr (Some r -> RegisterSet r
forall a. a -> Set a
Set.singleton Some r
sr)
            }

deriving instance (ShowF r, MemWidth (RegAddrWidth r)) => Show (DemandSet r)
deriving instance TestEquality r => Eq (DemandSet r)
deriving instance OrdF r => Ord (DemandSet r)

instance OrdF r => Semigroup (DemandSet r) where
  DemandSet r
ds1 <> :: DemandSet r -> DemandSet r -> DemandSet r
<> DemandSet r
ds2 =
    DemandSet { registerDemands :: RegisterSet r
registerDemands = DemandSet r -> RegisterSet r
forall (r :: Type -> Type). DemandSet r -> RegisterSet r
registerDemands DemandSet r
ds1 RegisterSet r -> RegisterSet r -> RegisterSet r
forall a. Semigroup a => a -> a -> a
<> DemandSet r -> RegisterSet r
forall (r :: Type -> Type). DemandSet r -> RegisterSet r
registerDemands DemandSet r
ds2
              , functionResultDemands :: Map (MemSegmentOff (RegAddrWidth r)) (RegisterSet r)
functionResultDemands =
                  (RegisterSet r -> RegisterSet r -> RegisterSet r)
-> Map (MemSegmentOff (RegAddrWidth r)) (RegisterSet r)
-> Map (MemSegmentOff (RegAddrWidth r)) (RegisterSet r)
-> Map (MemSegmentOff (RegAddrWidth r)) (RegisterSet r)
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith RegisterSet r -> RegisterSet r -> RegisterSet r
forall a. Ord a => Set a -> Set a -> Set a
Set.union (DemandSet r -> Map (MemSegmentOff (RegAddrWidth r)) (RegisterSet r)
forall (r :: Type -> Type).
DemandSet r -> Map (MemSegmentOff (RegAddrWidth r)) (RegisterSet r)
functionResultDemands DemandSet r
ds1)
                                          (DemandSet r -> Map (MemSegmentOff (RegAddrWidth r)) (RegisterSet r)
forall (r :: Type -> Type).
DemandSet r -> Map (MemSegmentOff (RegAddrWidth r)) (RegisterSet r)
functionResultDemands DemandSet r
ds2)
              }

instance OrdF r => Monoid (DemandSet r) where
  mempty :: DemandSet r
mempty = DemandSet { registerDemands :: RegisterSet r
registerDemands = RegisterSet r
forall a. Set a
Set.empty
                     , functionResultDemands :: Map (MemSegmentOff (RegAddrWidth r)) (RegisterSet r)
functionResultDemands = Map (MemSegmentOff (RegAddrWidth r)) (RegisterSet r)
forall k a. Map k a
Map.empty
                     }

demandSetDifference :: OrdF r => DemandSet r -> DemandSet r -> DemandSet r
demandSetDifference :: forall (r :: Type -> Type).
OrdF r =>
DemandSet r -> DemandSet r -> DemandSet r
demandSetDifference DemandSet r
ds1 DemandSet r
ds2 =
  DemandSet { registerDemands :: RegisterSet r
registerDemands = DemandSet r -> RegisterSet r
forall (r :: Type -> Type). DemandSet r -> RegisterSet r
registerDemands DemandSet r
ds1 RegisterSet r -> RegisterSet r -> RegisterSet r
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` DemandSet r -> RegisterSet r
forall (r :: Type -> Type). DemandSet r -> RegisterSet r
registerDemands DemandSet r
ds2
            , functionResultDemands :: Map (MemSegmentOff (RegAddrWidth r)) (RegisterSet r)
functionResultDemands =
                (RegisterSet r -> RegisterSet r -> Maybe (RegisterSet r))
-> Map (MemSegmentOff (RegAddrWidth r)) (RegisterSet r)
-> Map (MemSegmentOff (RegAddrWidth r)) (RegisterSet r)
-> Map (MemSegmentOff (RegAddrWidth r)) (RegisterSet r)
forall k a b.
Ord k =>
(a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a
Map.differenceWith RegisterSet r -> RegisterSet r -> Maybe (RegisterSet r)
forall {a}. Ord a => Set a -> Set a -> Maybe (Set a)
setDiff
                (DemandSet r -> Map (MemSegmentOff (RegAddrWidth r)) (RegisterSet r)
forall (r :: Type -> Type).
DemandSet r -> Map (MemSegmentOff (RegAddrWidth r)) (RegisterSet r)
functionResultDemands DemandSet r
ds1)
                (DemandSet r -> Map (MemSegmentOff (RegAddrWidth r)) (RegisterSet r)
forall (r :: Type -> Type).
DemandSet r -> Map (MemSegmentOff (RegAddrWidth r)) (RegisterSet r)
functionResultDemands DemandSet r
ds2)
            }
  where
    setDiff :: Set a -> Set a -> Maybe (Set a)
setDiff Set a
s1 Set a
s2 =
      let s' :: Set a
s' = Set a
s1 Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set a
s2
      in if Set a -> Bool
forall a. Set a -> Bool
Set.null Set a
s' then Maybe (Set a)
forall a. Maybe a
Nothing else Set a -> Maybe (Set a)
forall a. a -> Maybe a
Just Set a
s'

-- | This type is used to describe the context in which a particular
-- demand set is needed.
data DemandType r
  -- | This denotes demands that are always neede to execute the block.
  = DemandAlways
  -- | This denotes a value needed if the function at the given
  -- address needs the specific register as an argument.
  | forall tp. DemandFunctionArg (RegSegmentOff r) (r tp)
    -- | This key is used to denote the demands associating with
    -- needing to compute the the return value of the
    -- function stored in the given register.
  | forall tp. DemandFunctionResult (r tp)

instance (MemWidth (RegAddrWidth r), ShowF r) => Show (DemandType r) where
  showsPrec :: Int -> DemandType r -> ShowS
showsPrec Int
_ DemandType r
DemandAlways  = String -> ShowS
showString String
"DemandAlways"
  showsPrec Int
p (DemandFunctionArg MemSegmentOff (RegAddrWidth r)
a r tp
r) = Bool -> ShowS -> ShowS
showParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
10) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
    String -> ShowS
showString String
"DemandFunctionArg " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MemSegmentOff (RegAddrWidth r) -> ShowS
forall a. Show a => a -> ShowS
shows MemSegmentOff (RegAddrWidth r)
a ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
' ' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. r tp -> ShowS
forall {k} (f :: k -> Type) (tp :: k). ShowF f => f tp -> ShowS
showsF r tp
r
  showsPrec Int
p (DemandFunctionResult r tp
r) = Bool -> ShowS -> ShowS
showParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
10) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
    String -> ShowS
showString String
"DemandFunctionResult " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. r tp -> ShowS
forall {k} (f :: k -> Type) (tp :: k). ShowF f => f tp -> ShowS
showsF r tp
r

instance TestEquality r => Eq (DemandType r) where
  DemandType r
DemandAlways == :: DemandType r -> DemandType r -> Bool
== DemandType r
DemandAlways = Bool
True
  (DemandFunctionArg RegSegmentOff r
faddr1 r tp
r1) == (DemandFunctionArg RegSegmentOff r
faddr2 r tp
r2) =
    RegSegmentOff r
faddr1 RegSegmentOff r -> RegSegmentOff r -> Bool
forall a. Eq a => a -> a -> Bool
== RegSegmentOff r
faddr2 Bool -> Bool -> Bool
&& Maybe (tp :~: tp) -> Bool
forall a. Maybe a -> Bool
isJust (r tp -> r 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). r a -> r b -> Maybe (a :~: b)
testEquality r tp
r1 r tp
r2)
  (DemandFunctionResult r tp
r1) == (DemandFunctionResult r tp
r2) =
    Maybe (tp :~: tp) -> Bool
forall a. Maybe a -> Bool
isJust (r tp -> r 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). r a -> r b -> Maybe (a :~: b)
testEquality r tp
r1 r tp
r2)
  DemandType r
_ == DemandType r
_ = Bool
False

instance OrdF r => Ord (DemandType r) where
  DemandType r
DemandAlways compare :: DemandType r -> DemandType r -> Ordering
`compare` DemandType r
DemandAlways = Ordering
EQ
  DemandType r
DemandAlways `compare` DemandType r
_  = Ordering
LT
  DemandType r
_ `compare` DemandType r
DemandAlways  = Ordering
GT

  (DemandFunctionArg RegSegmentOff r
faddr1 r tp
r1) `compare` (DemandFunctionArg RegSegmentOff r
faddr2 r tp
r2)
    | RegSegmentOff r
faddr1 RegSegmentOff r -> RegSegmentOff r -> Bool
forall a. Eq a => a -> a -> Bool
== RegSegmentOff r
faddr2 = OrderingF tp tp -> Ordering
forall {k} (x :: k) (y :: k). OrderingF x y -> Ordering
toOrdering (r tp -> r tp -> OrderingF tp tp
forall k (ktp :: k -> Type) (x :: k) (y :: k).
OrdF ktp =>
ktp x -> ktp y -> OrderingF x y
forall (x :: Type) (y :: Type). r x -> r y -> OrderingF x y
compareF r tp
r1 r tp
r2)
    | Bool
otherwise = RegSegmentOff r
faddr1 RegSegmentOff r -> RegSegmentOff r -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` RegSegmentOff r
faddr2

  (DemandFunctionArg {}) `compare` DemandType r
_ = Ordering
LT
  DemandType r
_ `compare` (DemandFunctionArg {}) = Ordering
GT

  (DemandFunctionResult r tp
r1) `compare` (DemandFunctionResult r tp
r2) =
    OrderingF tp tp -> Ordering
forall {k} (x :: k) (y :: k). OrderingF x y -> Ordering
toOrdering (r tp -> r tp -> OrderingF tp tp
forall k (ktp :: k -> Type) (x :: k) (y :: k).
OrdF ktp =>
ktp x -> ktp y -> OrderingF x y
forall (x :: Type) (y :: Type). r x -> r y -> OrderingF x y
compareF r tp
r1 r tp
r2)

-- | This maps information produced by the block to what is needed to
-- produce that information.
newtype BlockDemands r = BD (Map (DemandType r) (DemandSet r))

demandAlways :: DemandSet r -> BlockDemands r
demandAlways :: forall (r :: Type -> Type). DemandSet r -> BlockDemands r
demandAlways DemandSet r
s = Map (DemandType r) (DemandSet r) -> BlockDemands r
forall (r :: Type -> Type).
Map (DemandType r) (DemandSet r) -> BlockDemands r
BD (DemandType r -> DemandSet r -> Map (DemandType r) (DemandSet r)
forall k a. k -> a -> Map k a
Map.singleton DemandType r
forall (r :: Type -> Type). DemandType r
DemandAlways DemandSet r
s)

-- | Record requirements to compute the value of an argument to a
-- function at the given address (if the function turns out to need
-- that register).
addDemandFunctionArg :: OrdF r
                     => RegSegmentOff r  -- ^ Register with demands.
                     -> r tp        -- ^ Register for this argument
                     -> DemandSet r -- ^ Demands for argument
                     -> BlockDemands r -- ^ Current known demands for block.
                     -> BlockDemands r
addDemandFunctionArg :: forall (r :: Type -> Type) (tp :: Type).
OrdF r =>
RegSegmentOff r
-> r tp -> DemandSet r -> BlockDemands r -> BlockDemands r
addDemandFunctionArg RegSegmentOff r
a r tp
r DemandSet r
s (BD Map (DemandType r) (DemandSet r)
m) = Map (DemandType r) (DemandSet r) -> BlockDemands r
forall (r :: Type -> Type).
Map (DemandType r) (DemandSet r) -> BlockDemands r
BD ((DemandSet r -> DemandSet r -> DemandSet r)
-> DemandType r
-> DemandSet r
-> Map (DemandType r) (DemandSet r)
-> Map (DemandType r) (DemandSet r)
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith DemandSet r -> DemandSet r -> DemandSet r
forall a. Monoid a => a -> a -> a
mappend (RegSegmentOff r -> r tp -> DemandType r
forall (r :: Type -> Type) (tp :: Type).
RegSegmentOff r -> r tp -> DemandType r
DemandFunctionArg RegSegmentOff r
a r tp
r) DemandSet r
s Map (DemandType r) (DemandSet r)
m)

-- | Record requirements to compute the return value of the given function.
addDemandFunctionResult :: OrdF r => r tp -> DemandSet r -> BlockDemands r -> BlockDemands r
addDemandFunctionResult :: forall (r :: Type -> Type) (tp :: Type).
OrdF r =>
r tp -> DemandSet r -> BlockDemands r -> BlockDemands r
addDemandFunctionResult r tp
r DemandSet r
s (BD Map (DemandType r) (DemandSet r)
m) = Map (DemandType r) (DemandSet r) -> BlockDemands r
forall (r :: Type -> Type).
Map (DemandType r) (DemandSet r) -> BlockDemands r
BD ((DemandSet r -> DemandSet r -> DemandSet r)
-> DemandType r
-> DemandSet r
-> Map (DemandType r) (DemandSet r)
-> Map (DemandType r) (DemandSet r)
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith DemandSet r -> DemandSet r -> DemandSet r
forall a. Monoid a => a -> a -> a
mappend (r tp -> DemandType r
forall (r :: Type -> Type) (tp :: Type). r tp -> DemandType r
DemandFunctionResult r tp
r) DemandSet r
s Map (DemandType r) (DemandSet r)
m)

-- | Take the union of the demands.
unionBlockDemands :: OrdF r => BlockDemands r -> BlockDemands r -> BlockDemands r
unionBlockDemands :: forall (r :: Type -> Type).
OrdF r =>
BlockDemands r -> BlockDemands r -> BlockDemands r
unionBlockDemands (BD Map (DemandType r) (DemandSet r)
x) (BD Map (DemandType r) (DemandSet r)
y) = Map (DemandType r) (DemandSet r) -> BlockDemands r
forall (r :: Type -> Type).
Map (DemandType r) (DemandSet r) -> BlockDemands r
BD ((DemandSet r -> DemandSet r -> DemandSet r)
-> Map (DemandType r) (DemandSet r)
-> Map (DemandType r) (DemandSet r)
-> Map (DemandType r) (DemandSet r)
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith DemandSet r -> DemandSet r -> DemandSet r
forall a. Monoid a => a -> a -> a
mappend Map (DemandType r) (DemandSet r)
x Map (DemandType r) (DemandSet r)
y)

instance OrdF r => Semigroup (BlockDemands r) where
  <> :: BlockDemands r -> BlockDemands r -> BlockDemands r
(<>) = BlockDemands r -> BlockDemands r -> BlockDemands r
forall (r :: Type -> Type).
OrdF r =>
BlockDemands r -> BlockDemands r -> BlockDemands r
unionBlockDemands

instance OrdF r => Monoid (BlockDemands r) where
  mempty :: BlockDemands r
mempty = Map (DemandType r) (DemandSet r) -> BlockDemands r
forall (r :: Type -> Type).
Map (DemandType r) (DemandSet r) -> BlockDemands r
BD Map (DemandType r) (DemandSet r)
forall k a. Map k a
Map.empty

-- | A cache from assignment identifiers to registers.
type AssignmentCache r ids = Map (Some (AssignId ids)) (RegisterSet r)

-- | Maps each register to the what information is needed to compute
-- the value stored in that register.
--
-- To reduce the size of the underlying map, this does not including
-- bindings for registers that need no additional information to be
-- computed.
newtype FinalRegisterDemands r = FRD (Map (Some r) (DemandSet r))

-- | Add demands for a register to collection.
insertRegDemand :: OrdF r
                => r tp
                -> DemandSet r
                -> FinalRegisterDemands r
                -> FinalRegisterDemands r
insertRegDemand :: forall (r :: Type -> Type) (tp :: Type).
OrdF r =>
r tp
-> DemandSet r -> FinalRegisterDemands r -> FinalRegisterDemands r
insertRegDemand r tp
r DemandSet r
s (FRD Map (Some r) (DemandSet r)
m)
  | DemandSet r -> Bool
forall (r :: Type -> Type). DemandSet r -> Bool
isEmptyDemandSet DemandSet r
s = Map (Some r) (DemandSet r) -> FinalRegisterDemands r
forall (r :: Type -> Type).
Map (Some r) (DemandSet r) -> FinalRegisterDemands r
FRD Map (Some r) (DemandSet r)
m
  | Bool
otherwise = Map (Some r) (DemandSet r) -> FinalRegisterDemands r
forall (r :: Type -> Type).
Map (Some r) (DemandSet r) -> FinalRegisterDemands r
FRD ((DemandSet r -> DemandSet r -> DemandSet r)
-> Some r
-> DemandSet r
-> Map (Some r) (DemandSet r)
-> Map (Some r) (DemandSet r)
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith DemandSet r -> DemandSet r -> DemandSet r
forall a. Monoid a => a -> a -> a
mappend (r tp -> Some r
forall k (f :: k -> Type) (x :: k). f x -> Some f
Some r tp
r) DemandSet r
s Map (Some r) (DemandSet r)
m)

-- | @postRegisterDemands s r@ returns the demand set needed to
-- compute @r@ in @s@.
postRegisterDemands :: OrdF r => FinalRegisterDemands r -> r tp -> DemandSet r
postRegisterDemands :: forall (r :: Type -> Type) (tp :: Type).
OrdF r =>
FinalRegisterDemands r -> r tp -> DemandSet r
postRegisterDemands (FRD Map (Some r) (DemandSet r)
m) r tp
r = Map (Some r) (DemandSet r)
mMap (Some r) (DemandSet r)
-> Getting (DemandSet r) (Map (Some r) (DemandSet r)) (DemandSet r)
-> DemandSet r
forall s a. s -> Getting a s a -> a
^.Index (Map (Some r) (DemandSet r))
-> Traversal'
     (Map (Some r) (DemandSet r)) (IxValue (Map (Some r) (DemandSet r)))
forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix (r tp -> Some r
forall k (f :: k -> Type) (x :: k). f x -> Some f
Some r tp
r)

instance OrdF r => Semigroup (FinalRegisterDemands r) where
  FRD Map (Some r) (DemandSet r)
x <> :: FinalRegisterDemands r
-> FinalRegisterDemands r -> FinalRegisterDemands r
<> FRD Map (Some r) (DemandSet r)
y = Map (Some r) (DemandSet r) -> FinalRegisterDemands r
forall (r :: Type -> Type).
Map (Some r) (DemandSet r) -> FinalRegisterDemands r
FRD ((DemandSet r -> DemandSet r -> DemandSet r)
-> Map (Some r) (DemandSet r)
-> Map (Some r) (DemandSet r)
-> Map (Some r) (DemandSet r)
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith DemandSet r -> DemandSet r -> DemandSet r
forall a. Monoid a => a -> a -> a
mappend Map (Some r) (DemandSet r)
x Map (Some r) (DemandSet r)
y)

instance OrdF r => Monoid (FinalRegisterDemands r) where
  mempty :: FinalRegisterDemands r
mempty = Map (Some r) (DemandSet r) -> FinalRegisterDemands r
forall (r :: Type -> Type).
Map (Some r) (DemandSet r) -> FinalRegisterDemands r
FRD Map (Some r) (DemandSet r)
forall k a. Map k a
Map.empty

-- | Describes the effects of an architecture-specific statement
data ArchTermStmtRegEffects arch
   = ArchTermStmtRegEffects { forall arch. ArchTermStmtRegEffects arch -> [Some (ArchReg arch)]
termRegDemands :: ![Some (ArchReg arch)]
                              -- ^ Registers demanded by term statement
                            , forall arch. ArchTermStmtRegEffects arch -> [Some (ArchReg arch)]
termRegTransfers :: ![Some (ArchReg arch)]
                              -- ^ Registers that are not modified by
                              -- terminal statement.
                            }

-- | Returns information about the registers needed and modified by a
-- terminal statement
--
-- The first argument is the terminal statement.
--
-- The second is the state of registers when it is executed.
type ComputeArchTermStmtEffects arch ids
   = ArchTermStmt arch (Value arch ids)
   -> RegState (ArchReg arch) (Value arch ids)
   -> ArchTermStmtRegEffects arch

-- | Information about the architecture/environment what arguments a
-- function needs.
data ArchDemandInfo arch = ArchDemandInfo
     { -- | Registers the ABI says a function may use for its arguments.
       forall arch. ArchDemandInfo arch -> [Some (ArchReg arch)]
functionArgRegs :: ![Some (ArchReg arch)]
       -- | Registers the ABI says a function may use to return values.
     , forall arch. ArchDemandInfo arch -> [Some (ArchReg arch)]
functionRetRegs :: ![Some (ArchReg arch)]
       -- | Registers the ABI specifies that callees should save.
     , forall arch. ArchDemandInfo arch -> Set (Some (ArchReg arch))
calleeSavedRegs :: !(Set (Some (ArchReg arch)))
       -- | Compute the effects of a terminal statement on registers.
     , forall arch.
ArchDemandInfo arch
-> forall ids. ComputeArchTermStmtEffects arch ids
computeArchTermStmtEffects :: !(forall ids . ComputeArchTermStmtEffects arch ids)
       -- | Information needed to infer what values are demanded by a AssignRhs and Stmt.
     , forall arch. ArchDemandInfo arch -> DemandContext arch
demandInfoCtx :: !(DemandContext arch)
     }

------------------------------------------------------------------------
-- FunArgContext

-- | Function for resolving arguments to call.
--
-- Takes address of callsite and registers.
type ResolveCallArgsFn arch
  = forall ids
  .  ArchSegmentOff arch
  -> RegState (ArchReg arch) (Value arch ids)
  -> Either String [Some (Value arch ids)]

-- | Contextual information to inform argument computation.
data FunArgContext arch = FAC
  { forall arch. FunArgContext arch -> ArchDemandInfo arch
archDemandInfo :: !(ArchDemandInfo arch)
  , forall arch. FunArgContext arch -> Memory (ArchAddrWidth arch)
ctxMemory :: !(Memory (ArchAddrWidth arch))
    -- ^ State of memory for code analysis
  , forall arch. FunArgContext arch -> Set (ArchSegmentOff arch)
computedAddrSet :: !(Set (ArchSegmentOff arch))
    -- ^ Set of addresses that we are current computing addresses for.
  , forall arch. FunArgContext arch -> ResolveCallArgsFn arch
resolveCallArgs :: !(ResolveCallArgsFn arch)
    -- ^ Given a call with the registers, this infers the arguments
    -- returned by the call or an error message if it cannot be inferred.
  }

-- | This is information needed to compute dependencies for a single function.
data FunctionArgsState arch ids = FAS
  { -- | If a demand d is demanded of block address then the block
    --   demands S, s.t.  `blockDemandMap ^. at addr ^. at d = Just S1
    forall arch ids.
FunctionArgsState arch ids
-> Map (ArchSegmentOff arch) (BlockDemands (ArchReg arch))
_blockDemandMap    :: !(Map (ArchSegmentOff arch) (BlockDemands (ArchReg arch)))
    -- | A cache of the assignments and their deps.  The key is not
    -- included in the set of deps (but probably should be).
  , forall arch ids.
FunctionArgsState arch ids -> AssignmentCache (ArchReg arch) ids
_assignmentCache :: !(AssignmentCache (ArchReg arch) ids)
  }

blockDemandMap :: Simple Lens (FunctionArgsState arch ids)
                    (Map (ArchSegmentOff arch) (BlockDemands (ArchReg arch)))
blockDemandMap :: forall arch ids (f :: Type -> Type).
Functor f =>
(Map (ArchSegmentOff arch) (BlockDemands (ArchReg arch))
 -> f (Map (ArchSegmentOff arch) (BlockDemands (ArchReg arch))))
-> FunctionArgsState arch ids -> f (FunctionArgsState arch ids)
blockDemandMap = (FunctionArgsState arch ids
 -> Map
      (MemSegmentOff (RegAddrWidth (ArchReg arch)))
      (BlockDemands (ArchReg arch)))
-> (FunctionArgsState arch ids
    -> Map
         (MemSegmentOff (RegAddrWidth (ArchReg arch)))
         (BlockDemands (ArchReg arch))
    -> FunctionArgsState arch ids)
-> Lens
     (FunctionArgsState arch ids)
     (FunctionArgsState arch ids)
     (Map
        (MemSegmentOff (RegAddrWidth (ArchReg arch)))
        (BlockDemands (ArchReg arch)))
     (Map
        (MemSegmentOff (RegAddrWidth (ArchReg arch)))
        (BlockDemands (ArchReg arch)))
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens FunctionArgsState arch ids
-> Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (BlockDemands (ArchReg arch))
forall arch ids.
FunctionArgsState arch ids
-> Map (ArchSegmentOff arch) (BlockDemands (ArchReg arch))
_blockDemandMap (\FunctionArgsState arch ids
s Map
  (MemSegmentOff (RegAddrWidth (ArchReg arch)))
  (BlockDemands (ArchReg arch))
v -> FunctionArgsState arch ids
s { _blockDemandMap = v })

assignmentCache :: Simple Lens (FunctionArgsState arch ids) (AssignmentCache (ArchReg arch) ids)
assignmentCache :: forall arch ids (f :: Type -> Type).
Functor f =>
(AssignmentCache (ArchReg arch) ids
 -> f (AssignmentCache (ArchReg arch) ids))
-> FunctionArgsState arch ids -> f (FunctionArgsState arch ids)
assignmentCache = (FunctionArgsState arch ids -> AssignmentCache (ArchReg arch) ids)
-> (FunctionArgsState arch ids
    -> AssignmentCache (ArchReg arch) ids
    -> FunctionArgsState arch ids)
-> Lens
     (FunctionArgsState arch ids)
     (FunctionArgsState arch ids)
     (AssignmentCache (ArchReg arch) ids)
     (AssignmentCache (ArchReg arch) ids)
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens FunctionArgsState arch ids -> AssignmentCache (ArchReg arch) ids
forall arch ids.
FunctionArgsState arch ids -> AssignmentCache (ArchReg arch) ids
_assignmentCache (\FunctionArgsState arch ids
s AssignmentCache (ArchReg arch) ids
v -> FunctionArgsState arch ids
s { _assignmentCache = v })

initFunctionArgsState :: FunctionArgsState arch ids
initFunctionArgsState :: forall arch ids. FunctionArgsState arch ids
initFunctionArgsState =
  FAS { _blockDemandMap :: Map (ArchSegmentOff arch) (BlockDemands (ArchReg arch))
_blockDemandMap    = Map (ArchSegmentOff arch) (BlockDemands (ArchReg arch))
forall k a. Map k a
Map.empty
      , _assignmentCache :: AssignmentCache (ArchReg arch) ids
_assignmentCache   = AssignmentCache (ArchReg arch) ids
forall k a. Map k a
Map.empty
      }

-- | Describes a reason a function call failed.
data FunctionArgAnalysisFailure w
   = CallAnalysisError !(MemSegmentOff w) !String
     -- ^ Could not determine call arguments.
   | PLTStubNotSupported
     -- ^ PLT stub analysis not supported.
  deriving (Int -> FunctionArgAnalysisFailure w -> ShowS
[FunctionArgAnalysisFailure w] -> ShowS
FunctionArgAnalysisFailure w -> String
(Int -> FunctionArgAnalysisFailure w -> ShowS)
-> (FunctionArgAnalysisFailure w -> String)
-> ([FunctionArgAnalysisFailure w] -> ShowS)
-> Show (FunctionArgAnalysisFailure w)
forall (w :: Nat).
MemWidth w =>
Int -> FunctionArgAnalysisFailure w -> ShowS
forall (w :: Nat).
MemWidth w =>
[FunctionArgAnalysisFailure w] -> ShowS
forall (w :: Nat).
MemWidth w =>
FunctionArgAnalysisFailure w -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall (w :: Nat).
MemWidth w =>
Int -> FunctionArgAnalysisFailure w -> ShowS
showsPrec :: Int -> FunctionArgAnalysisFailure w -> ShowS
$cshow :: forall (w :: Nat).
MemWidth w =>
FunctionArgAnalysisFailure w -> String
show :: FunctionArgAnalysisFailure w -> String
$cshowList :: forall (w :: Nat).
MemWidth w =>
[FunctionArgAnalysisFailure w] -> ShowS
showList :: [FunctionArgAnalysisFailure w] -> ShowS
Show)

-- | Monad that runs for computing the dependcies of each block.
type FunctionArgsM arch ids =
  StateT (FunctionArgsState arch ids)
         (ReaderT (FunArgContext arch) (Except (FunctionArgAnalysisFailure (ArchAddrWidth arch))))

evalFunctionArgsM :: FunArgContext arch
                  -> FunctionSummaries (ArchReg arch) -- ^ Existing summaries
                  -> ArchSegmentOff arch -- ^ Address of function we are initializing
                  -> FunctionArgsM arch ids (FunctionSummaries (ArchReg arch))
                  -> FunctionSummaries (ArchReg arch)
evalFunctionArgsM :: forall arch ids.
FunArgContext arch
-> FunctionSummaries (ArchReg arch)
-> ArchSegmentOff arch
-> FunctionArgsM arch ids (FunctionSummaries (ArchReg arch))
-> FunctionSummaries (ArchReg arch)
evalFunctionArgsM FunArgContext arch
ctx FunctionSummaries (ArchReg arch)
s MemSegmentOff (RegAddrWidth (ArchReg arch))
faddr FunctionArgsM arch ids (FunctionSummaries (ArchReg arch))
m =
  case Except
  (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))
  (FunctionSummaries (ArchReg arch))
-> Either
     (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))
     (FunctionSummaries (ArchReg arch))
forall e a. Except e a -> Either e a
runExcept (ReaderT
  (FunArgContext arch)
  (ExceptT
     (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))
     Identity)
  (FunctionSummaries (ArchReg arch))
-> FunArgContext arch
-> Except
     (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))
     (FunctionSummaries (ArchReg arch))
forall r (m :: Type -> Type) a. ReaderT r m a -> r -> m a
runReaderT (FunctionArgsM arch ids (FunctionSummaries (ArchReg arch))
-> FunctionArgsState arch ids
-> ReaderT
     (FunArgContext arch)
     (ExceptT
        (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))
        Identity)
     (FunctionSummaries (ArchReg arch))
forall (m :: Type -> Type) s a. Monad m => StateT s m a -> s -> m a
evalStateT FunctionArgsM arch ids (FunctionSummaries (ArchReg arch))
m FunctionArgsState arch ids
forall arch ids. FunctionArgsState arch ids
initFunctionArgsState) FunArgContext arch
ctx) of
    Left FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch))
e -> FunctionSummaries (ArchReg arch)
s { inferenceFails = Map.insert faddr e (inferenceFails s) }
    Right FunctionSummaries (ArchReg arch)
r' -> FunctionSummaries (ArchReg arch)
r'

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

withAssignmentCache :: State (AssignmentCache (ArchReg arch) ids)  a -> FunctionArgsM arch ids a
withAssignmentCache :: forall arch ids a.
State (AssignmentCache (ArchReg arch) ids) a
-> FunctionArgsM arch ids a
withAssignmentCache State (AssignmentCache (ArchReg arch) ids) a
m = do
  AssignmentCache (ArchReg arch) ids
c <- Getting
  (AssignmentCache (ArchReg arch) ids)
  (FunctionArgsState arch ids)
  (AssignmentCache (ArchReg arch) ids)
-> StateT
     (FunctionArgsState arch ids)
     (ReaderT
        (FunArgContext arch)
        (Except
           (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
     (AssignmentCache (ArchReg arch) ids)
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
use Getting
  (AssignmentCache (ArchReg arch) ids)
  (FunctionArgsState arch ids)
  (AssignmentCache (ArchReg arch) ids)
forall arch ids (f :: Type -> Type).
Functor f =>
(AssignmentCache (ArchReg arch) ids
 -> f (AssignmentCache (ArchReg arch) ids))
-> FunctionArgsState arch ids -> f (FunctionArgsState arch ids)
assignmentCache
  let (a
r, AssignmentCache (ArchReg arch) ids
c') = State (AssignmentCache (ArchReg arch) ids) a
-> AssignmentCache (ArchReg arch) ids
-> (a, AssignmentCache (ArchReg arch) ids)
forall s a. State s a -> s -> (a, s)
runState State (AssignmentCache (ArchReg arch) ids) a
m AssignmentCache (ArchReg arch) ids
c
  AssignmentCache (ArchReg arch) ids
-> StateT
     (FunctionArgsState arch ids)
     (ReaderT
        (FunArgContext arch)
        (Except
           (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
     ()
-> StateT
     (FunctionArgsState arch ids)
     (ReaderT
        (FunArgContext arch)
        (Except
           (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
     ()
forall a b. a -> b -> b
seq AssignmentCache (ArchReg arch) ids
c' (StateT
   (FunctionArgsState arch ids)
   (ReaderT
      (FunArgContext arch)
      (Except
         (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
   ()
 -> StateT
      (FunctionArgsState arch ids)
      (ReaderT
         (FunArgContext arch)
         (Except
            (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
      ())
-> StateT
     (FunctionArgsState arch ids)
     (ReaderT
        (FunArgContext arch)
        (Except
           (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
     ()
-> StateT
     (FunctionArgsState arch ids)
     (ReaderT
        (FunArgContext arch)
        (Except
           (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
     ()
forall a b. (a -> b) -> a -> b
$ (AssignmentCache (ArchReg arch) ids
 -> Identity (AssignmentCache (ArchReg arch) ids))
-> FunctionArgsState arch ids
-> Identity (FunctionArgsState arch ids)
forall arch ids (f :: Type -> Type).
Functor f =>
(AssignmentCache (ArchReg arch) ids
 -> f (AssignmentCache (ArchReg arch) ids))
-> FunctionArgsState arch ids -> f (FunctionArgsState arch ids)
assignmentCache ((AssignmentCache (ArchReg arch) ids
  -> Identity (AssignmentCache (ArchReg arch) ids))
 -> FunctionArgsState arch ids
 -> Identity (FunctionArgsState arch ids))
-> AssignmentCache (ArchReg arch) ids
-> StateT
     (FunctionArgsState arch ids)
     (ReaderT
        (FunArgContext arch)
        (Except
           (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
     ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= AssignmentCache (ArchReg arch) ids
c'
  a -> FunctionArgsM arch ids a
forall a.
a
-> StateT
     (FunctionArgsState arch ids)
     (ReaderT
        (FunArgContext arch)
        (Except
           (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
     a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure a
r

-- | Return the input registers that a value depends on.
--
-- Note. This caches the assignment register sets so that we do not
-- need to recalculate the demand set for assignments referenced
-- multiple times.
valueUses :: (OrdF (ArchReg arch), FoldableFC (ArchFn arch))
          => Value arch ids tp
          -> State (AssignmentCache (ArchReg arch) ids) (RegisterSet (ArchReg arch))
valueUses :: forall arch ids (tp :: Type).
(OrdF (ArchReg arch), FoldableFC (ArchFn arch)) =>
Value arch ids tp
-> State
     (AssignmentCache (ArchReg arch) ids) (RegisterSet (ArchReg arch))
valueUses (AssignedValue (Assignment AssignId ids tp
a AssignRhs arch (Value arch ids) tp
rhs)) = do
   Maybe (RegisterSet (ArchReg arch))
mr <- (AssignmentCache (ArchReg arch) ids
 -> Maybe (RegisterSet (ArchReg arch)))
-> StateT
     (AssignmentCache (ArchReg arch) ids)
     Identity
     (Maybe (RegisterSet (ArchReg arch)))
forall s (m :: Type -> Type) a. MonadState s m => (s -> a) -> m a
gets ((AssignmentCache (ArchReg arch) ids
  -> Maybe (RegisterSet (ArchReg arch)))
 -> StateT
      (AssignmentCache (ArchReg arch) ids)
      Identity
      (Maybe (RegisterSet (ArchReg arch))))
-> (AssignmentCache (ArchReg arch) ids
    -> Maybe (RegisterSet (ArchReg arch)))
-> StateT
     (AssignmentCache (ArchReg arch) ids)
     Identity
     (Maybe (RegisterSet (ArchReg arch)))
forall a b. (a -> b) -> a -> b
$ Some (AssignId ids)
-> AssignmentCache (ArchReg arch) ids
-> Maybe (RegisterSet (ArchReg arch))
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)
   case Maybe (RegisterSet (ArchReg arch))
mr of
     Just RegisterSet (ArchReg arch)
s -> RegisterSet (ArchReg arch)
-> State
     (AssignmentCache (ArchReg arch) ids) (RegisterSet (ArchReg arch))
forall a.
a -> StateT (AssignmentCache (ArchReg arch) ids) Identity a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure RegisterSet (ArchReg arch)
s
     Maybe (RegisterSet (ArchReg arch))
Nothing -> do
       RegisterSet (ArchReg arch)
rhs' <- (forall (x :: Type).
 RegisterSet (ArchReg arch)
 -> Value arch ids x
 -> State
      (AssignmentCache (ArchReg arch) ids) (RegisterSet (ArchReg arch)))
-> RegisterSet (ArchReg arch)
-> AssignRhs arch (Value arch ids) tp
-> State
     (AssignmentCache (ArchReg arch) ids) (RegisterSet (ArchReg arch))
forall {k} {l} (t :: (k -> Type) -> l -> Type) (m :: Type -> Type)
       b (f :: k -> Type) (c :: l).
(FoldableFC t, Monad m) =>
(forall (x :: k). b -> f x -> m b) -> b -> t f c -> m b
foldlMFC (\RegisterSet (ArchReg arch)
s Value arch ids x
v -> RegisterSet (ArchReg arch)
-> State
     (AssignmentCache (ArchReg arch) ids) (RegisterSet (ArchReg arch))
-> State
     (AssignmentCache (ArchReg arch) ids) (RegisterSet (ArchReg arch))
forall a b. a -> b -> b
seq RegisterSet (ArchReg arch)
s (State
   (AssignmentCache (ArchReg arch) ids) (RegisterSet (ArchReg arch))
 -> State
      (AssignmentCache (ArchReg arch) ids) (RegisterSet (ArchReg arch)))
-> State
     (AssignmentCache (ArchReg arch) ids) (RegisterSet (ArchReg arch))
-> State
     (AssignmentCache (ArchReg arch) ids) (RegisterSet (ArchReg arch))
forall a b. (a -> b) -> a -> b
$ RegisterSet (ArchReg arch)
-> RegisterSet (ArchReg arch) -> RegisterSet (ArchReg arch)
forall a. Ord a => Set a -> Set a -> Set a
Set.union RegisterSet (ArchReg arch)
s (RegisterSet (ArchReg arch) -> RegisterSet (ArchReg arch))
-> State
     (AssignmentCache (ArchReg arch) ids) (RegisterSet (ArchReg arch))
-> State
     (AssignmentCache (ArchReg arch) ids) (RegisterSet (ArchReg arch))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Value arch ids x
-> State
     (AssignmentCache (ArchReg arch) ids) (RegisterSet (ArchReg arch))
forall arch ids (tp :: Type).
(OrdF (ArchReg arch), FoldableFC (ArchFn arch)) =>
Value arch ids tp
-> State
     (AssignmentCache (ArchReg arch) ids) (RegisterSet (ArchReg arch))
valueUses Value arch ids x
v) RegisterSet (ArchReg arch)
forall a. Set a
Set.empty AssignRhs arch (Value arch ids) tp
rhs
       RegisterSet (ArchReg arch)
-> StateT (AssignmentCache (ArchReg arch) ids) Identity ()
-> StateT (AssignmentCache (ArchReg arch) ids) Identity ()
forall a b. a -> b -> b
seq RegisterSet (ArchReg arch)
rhs' (StateT (AssignmentCache (ArchReg arch) ids) Identity ()
 -> StateT (AssignmentCache (ArchReg arch) ids) Identity ())
-> StateT (AssignmentCache (ArchReg arch) ids) Identity ()
-> StateT (AssignmentCache (ArchReg arch) ids) Identity ()
forall a b. (a -> b) -> a -> b
$ (AssignmentCache (ArchReg arch) ids
 -> AssignmentCache (ArchReg arch) ids)
-> StateT (AssignmentCache (ArchReg arch) ids) Identity ()
forall s (m :: Type -> Type). MonadState s m => (s -> s) -> m ()
modify' ((AssignmentCache (ArchReg arch) ids
  -> AssignmentCache (ArchReg arch) ids)
 -> StateT (AssignmentCache (ArchReg arch) ids) Identity ())
-> (AssignmentCache (ArchReg arch) ids
    -> AssignmentCache (ArchReg arch) ids)
-> StateT (AssignmentCache (ArchReg arch) ids) Identity ()
forall a b. (a -> b) -> a -> b
$ Some (AssignId ids)
-> RegisterSet (ArchReg arch)
-> AssignmentCache (ArchReg arch) ids
-> AssignmentCache (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
a) RegisterSet (ArchReg arch)
rhs'
       RegisterSet (ArchReg arch)
-> State
     (AssignmentCache (ArchReg arch) ids) (RegisterSet (ArchReg arch))
forall a.
a -> StateT (AssignmentCache (ArchReg arch) ids) Identity a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure RegisterSet (ArchReg arch)
rhs'
valueUses (Initial ArchReg arch tp
r) =
  RegisterSet (ArchReg arch)
-> State
     (AssignmentCache (ArchReg arch) ids) (RegisterSet (ArchReg arch))
forall a.
a -> StateT (AssignmentCache (ArchReg arch) ids) Identity a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (RegisterSet (ArchReg arch)
 -> State
      (AssignmentCache (ArchReg arch) ids) (RegisterSet (ArchReg arch)))
-> RegisterSet (ArchReg arch)
-> State
     (AssignmentCache (ArchReg arch) ids) (RegisterSet (ArchReg arch))
forall a b. (a -> b) -> a -> b
$! Some (ArchReg arch) -> RegisterSet (ArchReg arch)
forall a. a -> Set a
Set.singleton (ArchReg arch tp -> Some (ArchReg arch)
forall k (f :: k -> Type) (x :: k). f x -> Some f
Some ArchReg arch tp
r)
valueUses Value arch ids tp
_ =
  RegisterSet (ArchReg arch)
-> State
     (AssignmentCache (ArchReg arch) ids) (RegisterSet (ArchReg arch))
forall a.
a -> StateT (AssignmentCache (ArchReg arch) ids) Identity a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (RegisterSet (ArchReg arch)
 -> State
      (AssignmentCache (ArchReg arch) ids) (RegisterSet (ArchReg arch)))
-> RegisterSet (ArchReg arch)
-> State
     (AssignmentCache (ArchReg arch) ids) (RegisterSet (ArchReg arch))
forall a b. (a -> b) -> a -> b
$! RegisterSet (ArchReg arch)
forall a. Set a
Set.empty

addValueUses :: (OrdF (ArchReg arch), FoldableFC (ArchFn arch))
             => RegisterSet (ArchReg arch)
             -> Value arch ids tp
             -> State (AssignmentCache (ArchReg arch) ids) (RegisterSet (ArchReg arch))
addValueUses :: forall arch ids (tp :: Type).
(OrdF (ArchReg arch), FoldableFC (ArchFn arch)) =>
RegisterSet (ArchReg arch)
-> Value arch ids tp
-> State
     (AssignmentCache (ArchReg arch) ids) (RegisterSet (ArchReg arch))
addValueUses RegisterSet (ArchReg arch)
s Value arch ids tp
v = RegisterSet (ArchReg arch)
-> RegisterSet (ArchReg arch) -> RegisterSet (ArchReg arch)
forall a. Ord a => Set a -> Set a -> Set a
Set.union RegisterSet (ArchReg arch)
s (RegisterSet (ArchReg arch) -> RegisterSet (ArchReg arch))
-> StateT
     (AssignmentCache (ArchReg arch) ids)
     Identity
     (RegisterSet (ArchReg arch))
-> StateT
     (AssignmentCache (ArchReg arch) ids)
     Identity
     (RegisterSet (ArchReg arch))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Value arch ids tp
-> StateT
     (AssignmentCache (ArchReg arch) ids)
     Identity
     (RegisterSet (ArchReg arch))
forall arch ids (tp :: Type).
(OrdF (ArchReg arch), FoldableFC (ArchFn arch)) =>
Value arch ids tp
-> State
     (AssignmentCache (ArchReg arch) ids) (RegisterSet (ArchReg arch))
valueUses Value arch ids tp
v

addBlockDemands :: OrdF (ArchReg arch)
                => ArchSegmentOff arch
                -> BlockDemands (ArchReg arch)
                -> FunctionArgsM arch ids ()
addBlockDemands :: forall arch ids.
OrdF (ArchReg arch) =>
ArchSegmentOff arch
-> BlockDemands (ArchReg arch) -> FunctionArgsM arch ids ()
addBlockDemands MemSegmentOff (RegAddrWidth (ArchReg arch))
a BlockDemands (ArchReg arch)
m =
  (Map
   (MemSegmentOff (RegAddrWidth (ArchReg arch)))
   (BlockDemands (ArchReg arch))
 -> Identity
      (Map
         (MemSegmentOff (RegAddrWidth (ArchReg arch)))
         (BlockDemands (ArchReg arch))))
-> FunctionArgsState arch ids
-> Identity (FunctionArgsState arch ids)
forall arch ids (f :: Type -> Type).
Functor f =>
(Map (ArchSegmentOff arch) (BlockDemands (ArchReg arch))
 -> f (Map (ArchSegmentOff arch) (BlockDemands (ArchReg arch))))
-> FunctionArgsState arch ids -> f (FunctionArgsState arch ids)
blockDemandMap ((Map
    (MemSegmentOff (RegAddrWidth (ArchReg arch)))
    (BlockDemands (ArchReg arch))
  -> Identity
       (Map
          (MemSegmentOff (RegAddrWidth (ArchReg arch)))
          (BlockDemands (ArchReg arch))))
 -> FunctionArgsState arch ids
 -> Identity (FunctionArgsState arch ids))
-> (Map
      (MemSegmentOff (RegAddrWidth (ArchReg arch)))
      (BlockDemands (ArchReg arch))
    -> Map
         (MemSegmentOff (RegAddrWidth (ArchReg arch)))
         (BlockDemands (ArchReg arch)))
-> StateT
     (FunctionArgsState arch ids)
     (ReaderT
        (FunArgContext arch)
        (Except
           (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
     ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= (BlockDemands (ArchReg arch)
 -> BlockDemands (ArchReg arch) -> BlockDemands (ArchReg arch))
-> MemSegmentOff (RegAddrWidth (ArchReg arch))
-> BlockDemands (ArchReg arch)
-> Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (BlockDemands (ArchReg arch))
-> Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (BlockDemands (ArchReg arch))
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith BlockDemands (ArchReg arch)
-> BlockDemands (ArchReg arch) -> BlockDemands (ArchReg arch)
forall (r :: Type -> Type).
OrdF r =>
BlockDemands r -> BlockDemands r -> BlockDemands r
unionBlockDemands MemSegmentOff (RegAddrWidth (ArchReg arch))
a BlockDemands (ArchReg arch)
m

-- | Given a block and a maping from register to value after the block
-- has executed, this traverses the registers that will be available
-- in future blocks, and records a mapping from those registers to
-- their input dependencies.
recordBlockTransfer :: forall arch ids t
                    .  ( RegisterInfo (ArchReg arch)
                       , FoldableFC (ArchFn arch)
                       , Foldable t
                       )
                    => ArchSegmentOff arch
                       -- ^ Address of current block.
                    -> RegState (ArchReg arch) (Value arch ids)
                       -- ^ Map from registers to values.
                    -> t (Some (ArchReg arch))
                       -- ^ List of registers that subsequent blocks may depend on.
                    -> FunctionArgsM arch ids (FinalRegisterDemands (ArchReg arch))
recordBlockTransfer :: forall arch ids (t :: Type -> Type).
(RegisterInfo (ArchReg arch), FoldableFC (ArchFn arch),
 Foldable t) =>
ArchSegmentOff arch
-> RegState (ArchReg arch) (Value arch ids)
-> t (Some (ArchReg arch))
-> FunctionArgsM arch ids (FinalRegisterDemands (ArchReg arch))
recordBlockTransfer ArchSegmentOff arch
_addr RegState (ArchReg arch) (Value arch ids)
regs t (Some (ArchReg arch))
regSet = do
  let doReg :: FinalRegisterDemands (ArchReg arch)
            -> Some (ArchReg arch)
            -> State (AssignmentCache (ArchReg arch) ids)
                     (FinalRegisterDemands (ArchReg arch))
      doReg :: FinalRegisterDemands (ArchReg arch)
-> Some (ArchReg arch)
-> State
     (AssignmentCache (ArchReg arch) ids)
     (FinalRegisterDemands (ArchReg arch))
doReg FinalRegisterDemands (ArchReg arch)
m (Some ArchReg arch x
r) =
        case ArchReg arch x
-> ArchReg arch (BVType (RegAddrWidth (ArchReg arch)))
-> Maybe (x :~: 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 x
r ArchReg arch (BVType (RegAddrWidth (ArchReg arch)))
forall (r :: Type -> Type).
RegisterInfo r =>
r (BVType (RegAddrWidth r))
ip_reg of
          Just x :~: BVType (RegAddrWidth (ArchReg arch))
_ -> FinalRegisterDemands (ArchReg arch)
-> State
     (AssignmentCache (ArchReg arch) ids)
     (FinalRegisterDemands (ArchReg arch))
forall a.
a -> StateT (AssignmentCache (ArchReg arch) ids) Identity a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure FinalRegisterDemands (ArchReg arch)
m
          Maybe (x :~: BVType (RegAddrWidth (ArchReg arch)))
Nothing -> do
            RegisterSet (ArchReg arch)
rs' <- Value arch ids x
-> StateT
     (AssignmentCache (ArchReg arch) ids)
     Identity
     (RegisterSet (ArchReg arch))
forall arch ids (tp :: Type).
(OrdF (ArchReg arch), FoldableFC (ArchFn arch)) =>
Value arch ids tp
-> State
     (AssignmentCache (ArchReg arch) ids) (RegisterSet (ArchReg arch))
valueUses (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)
            FinalRegisterDemands (ArchReg arch)
-> State
     (AssignmentCache (ArchReg arch) ids)
     (FinalRegisterDemands (ArchReg arch))
forall a.
a -> StateT (AssignmentCache (ArchReg arch) ids) Identity a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (FinalRegisterDemands (ArchReg arch)
 -> State
      (AssignmentCache (ArchReg arch) ids)
      (FinalRegisterDemands (ArchReg arch)))
-> FinalRegisterDemands (ArchReg arch)
-> State
     (AssignmentCache (ArchReg arch) ids)
     (FinalRegisterDemands (ArchReg arch))
forall a b. (a -> b) -> a -> b
$! ArchReg arch x
-> DemandSet (ArchReg arch)
-> FinalRegisterDemands (ArchReg arch)
-> FinalRegisterDemands (ArchReg arch)
forall (r :: Type -> Type) (tp :: Type).
OrdF r =>
r tp
-> DemandSet r -> FinalRegisterDemands r -> FinalRegisterDemands r
insertRegDemand ArchReg arch x
r (RegisterSet (ArchReg arch) -> DemandSet (ArchReg arch)
forall (r :: Type -> Type). RegisterSet r -> DemandSet r
registerDemandSet RegisterSet (ArchReg arch)
rs') FinalRegisterDemands (ArchReg arch)
m
  State
  (AssignmentCache (ArchReg arch) ids)
  (FinalRegisterDemands (ArchReg arch))
-> FunctionArgsM arch ids (FinalRegisterDemands (ArchReg arch))
forall arch ids a.
State (AssignmentCache (ArchReg arch) ids) a
-> FunctionArgsM arch ids a
withAssignmentCache (State
   (AssignmentCache (ArchReg arch) ids)
   (FinalRegisterDemands (ArchReg arch))
 -> FunctionArgsM arch ids (FinalRegisterDemands (ArchReg arch)))
-> State
     (AssignmentCache (ArchReg arch) ids)
     (FinalRegisterDemands (ArchReg arch))
-> FunctionArgsM arch ids (FinalRegisterDemands (ArchReg arch))
forall a b. (a -> b) -> a -> b
$ (FinalRegisterDemands (ArchReg arch)
 -> Some (ArchReg arch)
 -> State
      (AssignmentCache (ArchReg arch) ids)
      (FinalRegisterDemands (ArchReg arch)))
-> FinalRegisterDemands (ArchReg arch)
-> t (Some (ArchReg arch))
-> State
     (AssignmentCache (ArchReg arch) ids)
     (FinalRegisterDemands (ArchReg arch))
forall (t :: Type -> Type) (m :: Type -> Type) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM FinalRegisterDemands (ArchReg arch)
-> Some (ArchReg arch)
-> State
     (AssignmentCache (ArchReg arch) ids)
     (FinalRegisterDemands (ArchReg arch))
doReg FinalRegisterDemands (ArchReg arch)
forall a. Monoid a => a
mempty t (Some (ArchReg arch))
regSet

-- | A block requires a value, and so we need to remember which
-- registers are required.
demandValue :: (OrdF (ArchReg arch), FoldableFC (ArchFn arch))
            => ArchSegmentOff arch
            -> Value arch ids tp
            -> FunctionArgsM arch ids ()
demandValue :: forall arch ids (tp :: Type).
(OrdF (ArchReg arch), FoldableFC (ArchFn arch)) =>
ArchSegmentOff arch
-> Value arch ids tp -> FunctionArgsM arch ids ()
demandValue ArchSegmentOff arch
addr Value arch ids tp
v = do
  RegisterSet (ArchReg arch)
regs <- State
  (AssignmentCache (ArchReg arch) ids) (RegisterSet (ArchReg arch))
-> StateT
     (FunctionArgsState arch ids)
     (ReaderT
        (FunArgContext arch)
        (Except
           (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
     (RegisterSet (ArchReg arch))
forall arch ids a.
State (AssignmentCache (ArchReg arch) ids) a
-> FunctionArgsM arch ids a
withAssignmentCache (State
   (AssignmentCache (ArchReg arch) ids) (RegisterSet (ArchReg arch))
 -> StateT
      (FunctionArgsState arch ids)
      (ReaderT
         (FunArgContext arch)
         (Except
            (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
      (RegisterSet (ArchReg arch)))
-> State
     (AssignmentCache (ArchReg arch) ids) (RegisterSet (ArchReg arch))
-> StateT
     (FunctionArgsState arch ids)
     (ReaderT
        (FunArgContext arch)
        (Except
           (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
     (RegisterSet (ArchReg arch))
forall a b. (a -> b) -> a -> b
$ Value arch ids tp
-> State
     (AssignmentCache (ArchReg arch) ids) (RegisterSet (ArchReg arch))
forall arch ids (tp :: Type).
(OrdF (ArchReg arch), FoldableFC (ArchFn arch)) =>
Value arch ids tp
-> State
     (AssignmentCache (ArchReg arch) ids) (RegisterSet (ArchReg arch))
valueUses Value arch ids tp
v
  ArchSegmentOff arch
-> BlockDemands (ArchReg arch) -> FunctionArgsM arch ids ()
forall arch ids.
OrdF (ArchReg arch) =>
ArchSegmentOff arch
-> BlockDemands (ArchReg arch) -> FunctionArgsM arch ids ()
addBlockDemands ArchSegmentOff arch
addr (BlockDemands (ArchReg arch) -> FunctionArgsM arch ids ())
-> BlockDemands (ArchReg arch) -> FunctionArgsM arch ids ()
forall a b. (a -> b) -> a -> b
$ DemandSet (ArchReg arch) -> BlockDemands (ArchReg arch)
forall (r :: Type -> Type). DemandSet r -> BlockDemands r
demandAlways (RegisterSet (ArchReg arch) -> DemandSet (ArchReg arch)
forall (r :: Type -> Type). RegisterSet r -> DemandSet r
registerDemandSet RegisterSet (ArchReg arch)
regs)

-- -----------------------------------------------------------------------------
-- Entry point

-- | Maps each function to the demand set for that function.
type AddrDemandMap r = Map (RegSegmentOff r) (DemandSet r)

-- | Maps a pair of (addr,reg) to the additional demands needed if the
-- function at @addr@ needs @reg@ as an argument.
type ArgDemandsMap r = Map (RegSegmentOff r, Some r) (AddrDemandMap r)

-- | This updates the demand information to demand the values in
-- certain registers when a call to a function we are inferring
-- demands the value.
linkKnownCallArguments :: ( FoldableFC (ArchFn arch)
                          , RegisterInfo (ArchReg arch)
                          )
                       => BlockDemands (ArchReg arch)
                       -> ArchSegmentOff arch
                          -- ^ Address of function we are calling
                       -> RegState (ArchReg arch) (Value arch ids)
                          -- ^ The mapping registers to values when the call occurs.
                       -> FunctionArgsM arch ids (BlockDemands (ArchReg arch))
linkKnownCallArguments :: forall arch ids.
(FoldableFC (ArchFn arch), RegisterInfo (ArchReg arch)) =>
BlockDemands (ArchReg arch)
-> ArchSegmentOff arch
-> RegState (ArchReg arch) (Value arch ids)
-> FunctionArgsM arch ids (BlockDemands (ArchReg arch))
linkKnownCallArguments BlockDemands (ArchReg arch)
curBlockDemands ArchSegmentOff arch
faddr RegState (ArchReg arch) (Value arch ids)
regs = do
  -- Associate the demand sets for each potential argument
  -- register with the registers used by faddr.
  [Some (ArchReg arch)]
argRegs <- (FunArgContext arch -> [Some (ArchReg arch)])
-> StateT
     (FunctionArgsState arch ids)
     (ReaderT
        (FunArgContext arch)
        (Except
           (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
     [Some (ArchReg arch)]
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks ((FunArgContext arch -> [Some (ArchReg arch)])
 -> StateT
      (FunctionArgsState arch ids)
      (ReaderT
         (FunArgContext arch)
         (Except
            (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
      [Some (ArchReg arch)])
-> (FunArgContext arch -> [Some (ArchReg arch)])
-> StateT
     (FunctionArgsState arch ids)
     (ReaderT
        (FunArgContext arch)
        (Except
           (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
     [Some (ArchReg arch)]
forall a b. (a -> b) -> a -> b
$ ArchDemandInfo arch -> [Some (ArchReg arch)]
forall arch. ArchDemandInfo arch -> [Some (ArchReg arch)]
functionArgRegs (ArchDemandInfo arch -> [Some (ArchReg arch)])
-> (FunArgContext arch -> ArchDemandInfo arch)
-> FunArgContext arch
-> [Some (ArchReg arch)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FunArgContext arch -> ArchDemandInfo arch
forall arch. FunArgContext arch -> ArchDemandInfo arch
archDemandInfo
  -- Get current demands associated with block.
  let insertArgRegDemands :: BlockDemands (ArchReg arch)
-> Some (ArchReg arch)
-> StateT
     (AssignmentCache (ArchReg arch) ids)
     Identity
     (BlockDemands (ArchReg arch))
insertArgRegDemands BlockDemands (ArchReg arch)
m (Some ArchReg arch x
r) = do
        RegisterSet (ArchReg arch)
vals <- Value arch ids x
-> StateT
     (AssignmentCache (ArchReg arch) ids)
     Identity
     (RegisterSet (ArchReg arch))
forall arch ids (tp :: Type).
(OrdF (ArchReg arch), FoldableFC (ArchFn arch)) =>
Value arch ids tp
-> State
     (AssignmentCache (ArchReg arch) ids) (RegisterSet (ArchReg arch))
valueUses (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)
        BlockDemands (ArchReg arch)
-> StateT
     (AssignmentCache (ArchReg arch) ids)
     Identity
     (BlockDemands (ArchReg arch))
forall a.
a -> StateT (AssignmentCache (ArchReg arch) ids) Identity a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (BlockDemands (ArchReg arch)
 -> StateT
      (AssignmentCache (ArchReg arch) ids)
      Identity
      (BlockDemands (ArchReg arch)))
-> BlockDemands (ArchReg arch)
-> StateT
     (AssignmentCache (ArchReg arch) ids)
     Identity
     (BlockDemands (ArchReg arch))
forall a b. (a -> b) -> a -> b
$! ArchSegmentOff arch
-> ArchReg arch x
-> DemandSet (ArchReg arch)
-> BlockDemands (ArchReg arch)
-> BlockDemands (ArchReg arch)
forall (r :: Type -> Type) (tp :: Type).
OrdF r =>
RegSegmentOff r
-> r tp -> DemandSet r -> BlockDemands r -> BlockDemands r
addDemandFunctionArg ArchSegmentOff arch
faddr ArchReg arch x
r (RegisterSet (ArchReg arch) -> DemandSet (ArchReg arch)
forall (r :: Type -> Type). RegisterSet r -> DemandSet r
registerDemandSet RegisterSet (ArchReg arch)
vals) BlockDemands (ArchReg arch)
m
  -- Add demands for computing an argument register value.
  StateT
  (AssignmentCache (ArchReg arch) ids)
  Identity
  (BlockDemands (ArchReg arch))
-> FunctionArgsM arch ids (BlockDemands (ArchReg arch))
forall arch ids a.
State (AssignmentCache (ArchReg arch) ids) a
-> FunctionArgsM arch ids a
withAssignmentCache (StateT
   (AssignmentCache (ArchReg arch) ids)
   Identity
   (BlockDemands (ArchReg arch))
 -> FunctionArgsM arch ids (BlockDemands (ArchReg arch)))
-> StateT
     (AssignmentCache (ArchReg arch) ids)
     Identity
     (BlockDemands (ArchReg arch))
-> FunctionArgsM arch ids (BlockDemands (ArchReg arch))
forall a b. (a -> b) -> a -> b
$ (BlockDemands (ArchReg arch)
 -> Some (ArchReg arch)
 -> StateT
      (AssignmentCache (ArchReg arch) ids)
      Identity
      (BlockDemands (ArchReg arch)))
-> BlockDemands (ArchReg arch)
-> [Some (ArchReg arch)]
-> StateT
     (AssignmentCache (ArchReg arch) ids)
     Identity
     (BlockDemands (ArchReg arch))
forall (t :: Type -> Type) (m :: Type -> Type) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM BlockDemands (ArchReg arch)
-> Some (ArchReg arch)
-> StateT
     (AssignmentCache (ArchReg arch) ids)
     Identity
     (BlockDemands (ArchReg arch))
insertArgRegDemands BlockDemands (ArchReg arch)
curBlockDemands [Some (ArchReg arch)]
argRegs

-- | This updates the block demand and transfer information to connect
-- demand for registers after the call to the information we expect
-- the call to return.
--
-- Its primary pupose is to add the glue that tells a caller when
-- its caller reads its return information.
linkKnownCallReturnValues :: forall arch ids
                          . ( RegisterInfo (ArchReg arch)
                            , FoldableFC (ArchFn arch)
                            )
                          => ArchSegmentOff arch
                             -- ^ Address of this block
                          -> ArchSegmentOff arch
                             -- ^ Address of function we are calling
                          -> RegState (ArchReg arch) (Value arch ids)
                          -- ^ The mapping registers to values when the call occurs.
                          -> Maybe (ArchSegmentOff arch)
                             -- ^ Address to return to or `Nothing` for tail call.
                          -> FunctionArgsM arch ids (FinalRegisterDemands (ArchReg arch))
linkKnownCallReturnValues :: forall arch ids.
(RegisterInfo (ArchReg arch), FoldableFC (ArchFn arch)) =>
ArchSegmentOff arch
-> ArchSegmentOff arch
-> RegState (ArchReg arch) (Value arch ids)
-> Maybe (ArchSegmentOff arch)
-> FunctionArgsM arch ids (FinalRegisterDemands (ArchReg arch))
linkKnownCallReturnValues MemSegmentOff (RegAddrWidth (ArchReg arch))
blockAddr MemSegmentOff (RegAddrWidth (ArchReg arch))
faddr RegState (ArchReg arch) (Value arch ids)
regs Maybe (MemSegmentOff (RegAddrWidth (ArchReg arch)))
mReturnAddr = do
  ArchDemandInfo arch
ainfo <- (FunArgContext arch -> ArchDemandInfo arch)
-> StateT
     (FunctionArgsState arch ids)
     (ReaderT
        (FunArgContext arch)
        (Except
           (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
     (ArchDemandInfo arch)
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks FunArgContext arch -> ArchDemandInfo arch
forall arch. FunArgContext arch -> ArchDemandInfo arch
archDemandInfo

  let retRegs :: [Some (ArchReg arch)]
retRegs = ArchDemandInfo arch -> [Some (ArchReg arch)]
forall arch. ArchDemandInfo arch -> [Some (ArchReg arch)]
functionRetRegs ArchDemandInfo arch
ainfo

  case Maybe (MemSegmentOff (RegAddrWidth (ArchReg arch)))
mReturnAddr of
    Maybe (MemSegmentOff (RegAddrWidth (ArchReg arch)))
Nothing -> do
      -- Get demands for this block.
      BlockDemands (ArchReg arch)
curDemandMap <- BlockDemands (ArchReg arch)
-> MemSegmentOff (RegAddrWidth (ArchReg arch))
-> Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (BlockDemands (ArchReg arch))
-> BlockDemands (ArchReg arch)
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault BlockDemands (ArchReg arch)
forall a. Monoid a => a
mempty MemSegmentOff (RegAddrWidth (ArchReg arch))
blockAddr (Map
   (MemSegmentOff (RegAddrWidth (ArchReg arch)))
   (BlockDemands (ArchReg arch))
 -> BlockDemands (ArchReg arch))
-> StateT
     (FunctionArgsState arch ids)
     (ReaderT
        (FunArgContext arch)
        (Except
           (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
     (Map
        (MemSegmentOff (RegAddrWidth (ArchReg arch)))
        (BlockDemands (ArchReg arch)))
-> StateT
     (FunctionArgsState arch ids)
     (ReaderT
        (FunArgContext arch)
        (Except
           (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
     (BlockDemands (ArchReg arch))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting
  (Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (BlockDemands (ArchReg arch)))
  (FunctionArgsState arch ids)
  (Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (BlockDemands (ArchReg arch)))
-> StateT
     (FunctionArgsState arch ids)
     (ReaderT
        (FunArgContext arch)
        (Except
           (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
     (Map
        (MemSegmentOff (RegAddrWidth (ArchReg arch)))
        (BlockDemands (ArchReg arch)))
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
use Getting
  (Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (BlockDemands (ArchReg arch)))
  (FunctionArgsState arch ids)
  (Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (BlockDemands (ArchReg arch)))
forall arch ids (f :: Type -> Type).
Functor f =>
(Map (ArchSegmentOff arch) (BlockDemands (ArchReg arch))
 -> f (Map (ArchSegmentOff arch) (BlockDemands (ArchReg arch))))
-> FunctionArgsState arch ids -> f (FunctionArgsState arch ids)
blockDemandMap

      -- For each return register @r@, extend @curDemandMap@ so that
      -- to indicate that if a caller demands this function returns
      -- register @r@, then it is demanded that @faddr@ returns
      -- register @r@.
      let addRetRegDemands :: BlockDemands (ArchReg arch)
-> Some (ArchReg arch) -> BlockDemands (ArchReg arch)
addRetRegDemands BlockDemands (ArchReg arch)
m (Some ArchReg arch x
r) =
            ArchReg arch x
-> DemandSet (ArchReg arch)
-> BlockDemands (ArchReg arch)
-> BlockDemands (ArchReg arch)
forall (r :: Type -> Type) (tp :: Type).
OrdF r =>
r tp -> DemandSet r -> BlockDemands r -> BlockDemands r
addDemandFunctionResult ArchReg arch x
r (MemSegmentOff (RegAddrWidth (ArchReg arch))
-> Some (ArchReg arch) -> DemandSet (ArchReg arch)
forall (r :: Type -> Type).
MemSegmentOff (RegAddrWidth r) -> Some r -> DemandSet r
demandFunctionReturn MemSegmentOff (RegAddrWidth (ArchReg arch))
faddr (ArchReg arch x -> Some (ArchReg arch)
forall k (f :: k -> Type) (x :: k). f x -> Some f
Some ArchReg arch x
r)) BlockDemands (ArchReg arch)
m
      let nextDemandMap :: BlockDemands (ArchReg arch)
nextDemandMap = (BlockDemands (ArchReg arch)
 -> Some (ArchReg arch) -> BlockDemands (ArchReg arch))
-> BlockDemands (ArchReg arch)
-> [Some (ArchReg arch)]
-> BlockDemands (ArchReg 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' BlockDemands (ArchReg arch)
-> Some (ArchReg arch) -> BlockDemands (ArchReg arch)
addRetRegDemands BlockDemands (ArchReg arch)
curDemandMap [Some (ArchReg arch)]
retRegs
      -- Update new demands for address.
      (Map
   (MemSegmentOff (RegAddrWidth (ArchReg arch)))
   (BlockDemands (ArchReg arch))
 -> Identity
      (Map
         (MemSegmentOff (RegAddrWidth (ArchReg arch)))
         (BlockDemands (ArchReg arch))))
-> FunctionArgsState arch ids
-> Identity (FunctionArgsState arch ids)
forall arch ids (f :: Type -> Type).
Functor f =>
(Map (ArchSegmentOff arch) (BlockDemands (ArchReg arch))
 -> f (Map (ArchSegmentOff arch) (BlockDemands (ArchReg arch))))
-> FunctionArgsState arch ids -> f (FunctionArgsState arch ids)
blockDemandMap ((Map
    (MemSegmentOff (RegAddrWidth (ArchReg arch)))
    (BlockDemands (ArchReg arch))
  -> Identity
       (Map
          (MemSegmentOff (RegAddrWidth (ArchReg arch)))
          (BlockDemands (ArchReg arch))))
 -> FunctionArgsState arch ids
 -> Identity (FunctionArgsState arch ids))
-> (Map
      (MemSegmentOff (RegAddrWidth (ArchReg arch)))
      (BlockDemands (ArchReg arch))
    -> Map
         (MemSegmentOff (RegAddrWidth (ArchReg arch)))
         (BlockDemands (ArchReg arch)))
-> StateT
     (FunctionArgsState arch ids)
     (ReaderT
        (FunArgContext arch)
        (Except
           (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
     ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= MemSegmentOff (RegAddrWidth (ArchReg arch))
-> BlockDemands (ArchReg arch)
-> Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (BlockDemands (ArchReg arch))
-> Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (BlockDemands (ArchReg arch))
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert MemSegmentOff (RegAddrWidth (ArchReg arch))
blockAddr BlockDemands (ArchReg arch)
nextDemandMap
      -- Do not worry about registers provided if function does not return.
      FinalRegisterDemands (ArchReg arch)
-> FunctionArgsM arch ids (FinalRegisterDemands (ArchReg arch))
forall a.
a
-> StateT
     (FunctionArgsState arch ids)
     (ReaderT
        (FunArgContext arch)
        (Except
           (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
     a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure FinalRegisterDemands (ArchReg arch)
forall a. Monoid a => a
mempty
    Just MemSegmentOff (RegAddrWidth (ArchReg arch))
_ -> do

      -- Compute final register demands for registers preserved by calls, and return registers.
      FinalRegisterDemands (ArchReg arch)
newDemands <-
        MemSegmentOff (RegAddrWidth (ArchReg arch))
-> RegState (ArchReg arch) (Value arch ids)
-> [Some (ArchReg arch)]
-> FunctionArgsM arch ids (FinalRegisterDemands (ArchReg arch))
forall arch ids (t :: Type -> Type).
(RegisterInfo (ArchReg arch), FoldableFC (ArchFn arch),
 Foldable t) =>
ArchSegmentOff arch
-> RegState (ArchReg arch) (Value arch ids)
-> t (Some (ArchReg arch))
-> FunctionArgsM arch ids (FinalRegisterDemands (ArchReg arch))
recordBlockTransfer MemSegmentOff (RegAddrWidth (ArchReg arch))
blockAddr RegState (ArchReg arch) (Value arch ids)
regs (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]
: Set (Some (ArchReg arch)) -> [Some (ArchReg arch)]
forall a. Set a -> [a]
Set.toList (ArchDemandInfo arch -> Set (Some (ArchReg arch))
forall arch. ArchDemandInfo arch -> Set (Some (ArchReg arch))
calleeSavedRegs ArchDemandInfo arch
ainfo))

      -- return registers that demanding the register
      let linkRetReg :: FinalRegisterDemands (ArchReg arch)
-> Some (ArchReg arch) -> FinalRegisterDemands (ArchReg arch)
linkRetReg FinalRegisterDemands (ArchReg arch)
m (Some ArchReg arch x
r) = ArchReg arch x
-> DemandSet (ArchReg arch)
-> FinalRegisterDemands (ArchReg arch)
-> FinalRegisterDemands (ArchReg arch)
forall (r :: Type -> Type) (tp :: Type).
OrdF r =>
r tp
-> DemandSet r -> FinalRegisterDemands r -> FinalRegisterDemands r
insertRegDemand ArchReg arch x
r (MemSegmentOff (RegAddrWidth (ArchReg arch))
-> Some (ArchReg arch) -> DemandSet (ArchReg arch)
forall (r :: Type -> Type).
MemSegmentOff (RegAddrWidth r) -> Some r -> DemandSet r
demandFunctionReturn MemSegmentOff (RegAddrWidth (ArchReg arch))
faddr (ArchReg arch x -> Some (ArchReg arch)
forall k (f :: k -> Type) (x :: k). f x -> Some f
Some ArchReg arch x
r)) FinalRegisterDemands (ArchReg arch)
m

      let srDemandSet :: FinalRegisterDemands (ArchReg arch)
          srDemandSet :: FinalRegisterDemands (ArchReg arch)
srDemandSet = (FinalRegisterDemands (ArchReg arch)
 -> Some (ArchReg arch) -> FinalRegisterDemands (ArchReg arch))
-> FinalRegisterDemands (ArchReg arch)
-> [Some (ArchReg arch)]
-> FinalRegisterDemands (ArchReg 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 FinalRegisterDemands (ArchReg arch)
-> Some (ArchReg arch) -> FinalRegisterDemands (ArchReg arch)
linkRetReg FinalRegisterDemands (ArchReg arch)
newDemands [Some (ArchReg arch)]
retRegs
      FinalRegisterDemands (ArchReg arch)
-> FunctionArgsM arch ids (FinalRegisterDemands (ArchReg arch))
forall a.
a
-> StateT
     (FunctionArgsState arch ids)
     (ReaderT
        (FunArgContext arch)
        (Except
           (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
     a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure FinalRegisterDemands (ArchReg arch)
srDemandSet

-- | This records information about a call from the given block to the
-- target block.
summarizeCall :: forall arch ids
              .  ( FoldableFC (ArchFn arch)
                 , RegisterInfo (ArchReg arch)
                 )
              => ArchSegmentOff arch
                 -- ^ The label for the current block.
              -> ArchAddrWord arch
                 -- ^ Offset from start of block for the call instruction.
              -> RegState (ArchReg arch) (Value arch ids)
                 -- ^ The current mapping from registers to values
              -> Maybe (ArchSegmentOff arch)
                 -- ^ Address to return to or `Nothing` for tail call.
              -> FunctionArgsM arch ids (FinalRegisterDemands (ArchReg arch))
summarizeCall :: forall arch ids.
(FoldableFC (ArchFn arch), RegisterInfo (ArchReg arch)) =>
ArchSegmentOff arch
-> ArchAddrWord arch
-> RegState (ArchReg arch) (Value arch ids)
-> Maybe (ArchSegmentOff arch)
-> FunctionArgsM arch ids (FinalRegisterDemands (ArchReg arch))
summarizeCall MemSegmentOff (RegAddrWidth (ArchReg arch))
blockAddr MemWord (RegAddrWidth (ArchReg arch))
callOff RegState (ArchReg arch) (Value arch ids)
finalRegs Maybe (MemSegmentOff (RegAddrWidth (ArchReg arch)))
mReturnAddr = do
  FunArgContext arch
ctx <- StateT
  (FunctionArgsState arch ids)
  (ReaderT
     (FunArgContext arch)
     (Except
        (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
  (FunArgContext arch)
forall r (m :: Type -> Type). MonadReader r m => m r
ask

  let ipVal :: Value arch ids (BVType (RegAddrWidth (ArchReg arch)))
ipVal = RegState (ArchReg arch) (Value arch ids)
finalRegsRegState (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
  let spVal :: Value arch ids (BVType (RegAddrWidth (ArchReg arch)))
spVal = RegState (ArchReg arch) (Value arch ids)
finalRegsRegState (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

  -- Record stack pointer and IP is always needed.
  do Set (Some (ArchReg arch))
demands <- State
  (AssignmentCache (ArchReg arch) ids) (Set (Some (ArchReg arch)))
-> StateT
     (FunctionArgsState arch ids)
     (ReaderT
        (FunArgContext arch)
        (Except
           (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
     (Set (Some (ArchReg arch)))
forall arch ids a.
State (AssignmentCache (ArchReg arch) ids) a
-> FunctionArgsM arch ids a
withAssignmentCache (State
   (AssignmentCache (ArchReg arch) ids) (Set (Some (ArchReg arch)))
 -> StateT
      (FunctionArgsState arch ids)
      (ReaderT
         (FunArgContext arch)
         (Except
            (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
      (Set (Some (ArchReg arch))))
-> State
     (AssignmentCache (ArchReg arch) ids) (Set (Some (ArchReg arch)))
-> StateT
     (FunctionArgsState arch ids)
     (ReaderT
        (FunArgContext arch)
        (Except
           (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
     (Set (Some (ArchReg arch)))
forall a b. (a -> b) -> a -> b
$ (Set (Some (ArchReg arch))
 -> Value arch ids (BVType (RegAddrWidth (ArchReg arch)))
 -> State
      (AssignmentCache (ArchReg arch) ids) (Set (Some (ArchReg arch))))
-> Set (Some (ArchReg arch))
-> [Value arch ids (BVType (RegAddrWidth (ArchReg arch)))]
-> State
     (AssignmentCache (ArchReg arch) ids) (Set (Some (ArchReg arch)))
forall (t :: Type -> Type) (m :: Type -> Type) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM Set (Some (ArchReg arch))
-> Value arch ids (BVType (RegAddrWidth (ArchReg arch)))
-> State
     (AssignmentCache (ArchReg arch) ids) (Set (Some (ArchReg arch)))
forall arch ids (tp :: Type).
(OrdF (ArchReg arch), FoldableFC (ArchFn arch)) =>
RegisterSet (ArchReg arch)
-> Value arch ids tp
-> State
     (AssignmentCache (ArchReg arch) ids) (RegisterSet (ArchReg arch))
addValueUses Set (Some (ArchReg arch))
forall a. Set a
Set.empty [Value arch ids (BVType (RegAddrWidth (ArchReg arch)))
ipVal, Value arch ids (BVType (RegAddrWidth (ArchReg arch)))
spVal]
     MemSegmentOff (RegAddrWidth (ArchReg arch))
-> BlockDemands (ArchReg arch)
-> StateT
     (FunctionArgsState arch ids)
     (ReaderT
        (FunArgContext arch)
        (Except
           (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
     ()
forall arch ids.
OrdF (ArchReg arch) =>
ArchSegmentOff arch
-> BlockDemands (ArchReg arch) -> FunctionArgsM arch ids ()
addBlockDemands MemSegmentOff (RegAddrWidth (ArchReg arch))
blockAddr (BlockDemands (ArchReg arch)
 -> StateT
      (FunctionArgsState arch ids)
      (ReaderT
         (FunArgContext arch)
         (Except
            (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
      ())
-> BlockDemands (ArchReg arch)
-> StateT
     (FunctionArgsState arch ids)
     (ReaderT
        (FunArgContext arch)
        (Except
           (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
     ()
forall a b. (a -> b) -> a -> b
$ DemandSet (ArchReg arch) -> BlockDemands (ArchReg arch)
forall (r :: Type -> Type). DemandSet r -> BlockDemands r
demandAlways (Set (Some (ArchReg arch)) -> DemandSet (ArchReg arch)
forall (r :: Type -> Type). RegisterSet r -> DemandSet r
registerDemandSet Set (Some (ArchReg arch))
demands)


  case () of
    -- When we call a function whose arguments we are concurrently
    -- trying to compute, we need to link the fact that if the
    -- function demands a register then we demand the register.
    ()
_ | Just MemSegmentOff (RegAddrWidth (ArchReg arch))
faddr <- Memory (RegAddrWidth (ArchReg arch))
-> Value arch ids (BVType (RegAddrWidth (ArchReg arch)))
-> Maybe (MemSegmentOff (RegAddrWidth (ArchReg arch)))
forall arch ids.
Memory (ArchAddrWidth arch)
-> BVValue arch ids (ArchAddrWidth arch)
-> Maybe (ArchSegmentOff arch)
valueAsSegmentOff (FunArgContext arch -> Memory (RegAddrWidth (ArchReg arch))
forall arch. FunArgContext arch -> Memory (ArchAddrWidth arch)
ctxMemory FunArgContext arch
ctx) Value arch ids (BVType (RegAddrWidth (ArchReg arch)))
ipVal
      , MemSegmentOff (RegAddrWidth (ArchReg arch))
-> Set (MemSegmentOff (RegAddrWidth (ArchReg arch))) -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member MemSegmentOff (RegAddrWidth (ArchReg arch))
faddr (FunArgContext arch
-> Set (MemSegmentOff (RegAddrWidth (ArchReg arch)))
forall arch. FunArgContext arch -> Set (ArchSegmentOff arch)
computedAddrSet FunArgContext arch
ctx) -> do

      BlockDemands (ArchReg arch)
curBlockDemands <- BlockDemands (ArchReg arch)
-> MemSegmentOff (RegAddrWidth (ArchReg arch))
-> Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (BlockDemands (ArchReg arch))
-> BlockDemands (ArchReg arch)
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault BlockDemands (ArchReg arch)
forall a. Monoid a => a
mempty MemSegmentOff (RegAddrWidth (ArchReg arch))
blockAddr (Map
   (MemSegmentOff (RegAddrWidth (ArchReg arch)))
   (BlockDemands (ArchReg arch))
 -> BlockDemands (ArchReg arch))
-> StateT
     (FunctionArgsState arch ids)
     (ReaderT
        (FunArgContext arch)
        (Except
           (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
     (Map
        (MemSegmentOff (RegAddrWidth (ArchReg arch)))
        (BlockDemands (ArchReg arch)))
-> StateT
     (FunctionArgsState arch ids)
     (ReaderT
        (FunArgContext arch)
        (Except
           (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
     (BlockDemands (ArchReg arch))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting
  (Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (BlockDemands (ArchReg arch)))
  (FunctionArgsState arch ids)
  (Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (BlockDemands (ArchReg arch)))
-> StateT
     (FunctionArgsState arch ids)
     (ReaderT
        (FunArgContext arch)
        (Except
           (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
     (Map
        (MemSegmentOff (RegAddrWidth (ArchReg arch)))
        (BlockDemands (ArchReg arch)))
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
use Getting
  (Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (BlockDemands (ArchReg arch)))
  (FunctionArgsState arch ids)
  (Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (BlockDemands (ArchReg arch)))
forall arch ids (f :: Type -> Type).
Functor f =>
(Map (ArchSegmentOff arch) (BlockDemands (ArchReg arch))
 -> f (Map (ArchSegmentOff arch) (BlockDemands (ArchReg arch))))
-> FunctionArgsState arch ids -> f (FunctionArgsState arch ids)
blockDemandMap
      BlockDemands (ArchReg arch)
newBlockDemands <- BlockDemands (ArchReg arch)
-> MemSegmentOff (RegAddrWidth (ArchReg arch))
-> RegState (ArchReg arch) (Value arch ids)
-> StateT
     (FunctionArgsState arch ids)
     (ReaderT
        (FunArgContext arch)
        (Except
           (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
     (BlockDemands (ArchReg arch))
forall arch ids.
(FoldableFC (ArchFn arch), RegisterInfo (ArchReg arch)) =>
BlockDemands (ArchReg arch)
-> ArchSegmentOff arch
-> RegState (ArchReg arch) (Value arch ids)
-> FunctionArgsM arch ids (BlockDemands (ArchReg arch))
linkKnownCallArguments BlockDemands (ArchReg arch)
curBlockDemands MemSegmentOff (RegAddrWidth (ArchReg arch))
faddr RegState (ArchReg arch) (Value arch ids)
finalRegs
      -- Update new demands for address.
      (Map
   (MemSegmentOff (RegAddrWidth (ArchReg arch)))
   (BlockDemands (ArchReg arch))
 -> Identity
      (Map
         (MemSegmentOff (RegAddrWidth (ArchReg arch)))
         (BlockDemands (ArchReg arch))))
-> FunctionArgsState arch ids
-> Identity (FunctionArgsState arch ids)
forall arch ids (f :: Type -> Type).
Functor f =>
(Map (ArchSegmentOff arch) (BlockDemands (ArchReg arch))
 -> f (Map (ArchSegmentOff arch) (BlockDemands (ArchReg arch))))
-> FunctionArgsState arch ids -> f (FunctionArgsState arch ids)
blockDemandMap ((Map
    (MemSegmentOff (RegAddrWidth (ArchReg arch)))
    (BlockDemands (ArchReg arch))
  -> Identity
       (Map
          (MemSegmentOff (RegAddrWidth (ArchReg arch)))
          (BlockDemands (ArchReg arch))))
 -> FunctionArgsState arch ids
 -> Identity (FunctionArgsState arch ids))
-> (Map
      (MemSegmentOff (RegAddrWidth (ArchReg arch)))
      (BlockDemands (ArchReg arch))
    -> Map
         (MemSegmentOff (RegAddrWidth (ArchReg arch)))
         (BlockDemands (ArchReg arch)))
-> StateT
     (FunctionArgsState arch ids)
     (ReaderT
        (FunArgContext arch)
        (Except
           (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
     ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= MemSegmentOff (RegAddrWidth (ArchReg arch))
-> BlockDemands (ArchReg arch)
-> Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (BlockDemands (ArchReg arch))
-> Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (BlockDemands (ArchReg arch))
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert MemSegmentOff (RegAddrWidth (ArchReg arch))
blockAddr BlockDemands (ArchReg arch)
newBlockDemands
      MemSegmentOff (RegAddrWidth (ArchReg arch))
-> MemSegmentOff (RegAddrWidth (ArchReg arch))
-> RegState (ArchReg arch) (Value arch ids)
-> Maybe (MemSegmentOff (RegAddrWidth (ArchReg arch)))
-> FunctionArgsM arch ids (FinalRegisterDemands (ArchReg arch))
forall arch ids.
(RegisterInfo (ArchReg arch), FoldableFC (ArchFn arch)) =>
ArchSegmentOff arch
-> ArchSegmentOff arch
-> RegState (ArchReg arch) (Value arch ids)
-> Maybe (ArchSegmentOff arch)
-> FunctionArgsM arch ids (FinalRegisterDemands (ArchReg arch))
linkKnownCallReturnValues MemSegmentOff (RegAddrWidth (ArchReg arch))
blockAddr MemSegmentOff (RegAddrWidth (ArchReg arch))
faddr RegState (ArchReg arch) (Value arch ids)
finalRegs Maybe (MemSegmentOff (RegAddrWidth (ArchReg arch)))
mReturnAddr

    -- Otherwise we compute statically what information to record.
    ()
_ -> do

      let ainfo :: ArchDemandInfo arch
ainfo = FunArgContext arch -> ArchDemandInfo arch
forall arch. FunArgContext arch -> ArchDemandInfo arch
archDemandInfo FunArgContext arch
ctx

      let callAddr :: MemSegmentOff (RegAddrWidth (ArchReg arch))
callAddr =
            case 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))
blockAddr (MemWord (RegAddrWidth (ArchReg arch)) -> Integer
forall a. Integral a => a -> Integer
toInteger MemWord (RegAddrWidth (ArchReg arch))
callOff) of
              Just MemSegmentOff (RegAddrWidth (ArchReg arch))
a -> MemSegmentOff (RegAddrWidth (ArchReg arch))
a
              Maybe (MemSegmentOff (RegAddrWidth (ArchReg arch)))
Nothing -> String -> MemSegmentOff (RegAddrWidth (ArchReg arch))
forall a. HasCallStack => String -> a
error String
"Call site is not a valid address."
      [Some (Value arch ids)]
argValues <-
        case FunArgContext arch -> ResolveCallArgsFn arch
forall arch. FunArgContext arch -> ResolveCallArgsFn arch
resolveCallArgs FunArgContext arch
ctx MemSegmentOff (RegAddrWidth (ArchReg arch))
callAddr RegState (ArchReg arch) (Value arch ids)
finalRegs of
          Left String
e -> FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch))
-> StateT
     (FunctionArgsState arch ids)
     (ReaderT
        (FunArgContext arch)
        (Except
           (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
     [Some (Value arch ids)]
forall a.
FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch))
-> StateT
     (FunctionArgsState arch ids)
     (ReaderT
        (FunArgContext arch)
        (Except
           (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
     a
forall e (m :: Type -> Type) a. MonadError e m => e -> m a
throwError (MemSegmentOff (RegAddrWidth (ArchReg arch))
-> String
-> FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch))
forall (w :: Nat).
MemSegmentOff w -> String -> FunctionArgAnalysisFailure w
CallAnalysisError MemSegmentOff (RegAddrWidth (ArchReg arch))
callAddr String
e)
          Right [Some (Value arch ids)]
r -> [Some (Value arch ids)]
-> StateT
     (FunctionArgsState arch ids)
     (ReaderT
        (FunArgContext arch)
        (Except
           (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
     [Some (Value arch ids)]
forall a.
a
-> StateT
     (FunctionArgsState arch ids)
     (ReaderT
        (FunArgContext arch)
        (Except
           (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
     a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure [Some (Value arch ids)]
r
      let regUses :: RegisterSet (ArchReg arch)
-> Some (Value arch ids)
-> State
     (AssignmentCache (ArchReg arch) ids) (RegisterSet (ArchReg arch))
regUses RegisterSet (ArchReg arch)
s (Some Value arch ids x
v) = RegisterSet (ArchReg arch)
-> Value arch ids x
-> State
     (AssignmentCache (ArchReg arch) ids) (RegisterSet (ArchReg arch))
forall arch ids (tp :: Type).
(OrdF (ArchReg arch), FoldableFC (ArchFn arch)) =>
RegisterSet (ArchReg arch)
-> Value arch ids tp
-> State
     (AssignmentCache (ArchReg arch) ids) (RegisterSet (ArchReg arch))
addValueUses RegisterSet (ArchReg arch)
s Value arch ids x
v
      Set (Some (ArchReg arch))
demands <- State
  (AssignmentCache (ArchReg arch) ids) (Set (Some (ArchReg arch)))
-> StateT
     (FunctionArgsState arch ids)
     (ReaderT
        (FunArgContext arch)
        (Except
           (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
     (Set (Some (ArchReg arch)))
forall arch ids a.
State (AssignmentCache (ArchReg arch) ids) a
-> FunctionArgsM arch ids a
withAssignmentCache (State
   (AssignmentCache (ArchReg arch) ids) (Set (Some (ArchReg arch)))
 -> StateT
      (FunctionArgsState arch ids)
      (ReaderT
         (FunArgContext arch)
         (Except
            (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
      (Set (Some (ArchReg arch))))
-> State
     (AssignmentCache (ArchReg arch) ids) (Set (Some (ArchReg arch)))
-> StateT
     (FunctionArgsState arch ids)
     (ReaderT
        (FunArgContext arch)
        (Except
           (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
     (Set (Some (ArchReg arch)))
forall a b. (a -> b) -> a -> b
$ (Set (Some (ArchReg arch))
 -> Some (Value arch ids)
 -> State
      (AssignmentCache (ArchReg arch) ids) (Set (Some (ArchReg arch))))
-> Set (Some (ArchReg arch))
-> [Some (Value arch ids)]
-> State
     (AssignmentCache (ArchReg arch) ids) (Set (Some (ArchReg arch)))
forall (t :: Type -> Type) (m :: Type -> Type) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM Set (Some (ArchReg arch))
-> Some (Value arch ids)
-> State
     (AssignmentCache (ArchReg arch) ids) (Set (Some (ArchReg arch)))
forall {arch} {ids}.
(OrdF (ArchReg arch), FoldableFC (ArchFn arch)) =>
RegisterSet (ArchReg arch)
-> Some (Value arch ids)
-> State
     (AssignmentCache (ArchReg arch) ids) (RegisterSet (ArchReg arch))
regUses Set (Some (ArchReg arch))
forall a. Set a
Set.empty [Some (Value arch ids)]
argValues
      MemSegmentOff (RegAddrWidth (ArchReg arch))
-> BlockDemands (ArchReg arch)
-> StateT
     (FunctionArgsState arch ids)
     (ReaderT
        (FunArgContext arch)
        (Except
           (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
     ()
forall arch ids.
OrdF (ArchReg arch) =>
ArchSegmentOff arch
-> BlockDemands (ArchReg arch) -> FunctionArgsM arch ids ()
addBlockDemands MemSegmentOff (RegAddrWidth (ArchReg arch))
blockAddr (BlockDemands (ArchReg arch)
 -> StateT
      (FunctionArgsState arch ids)
      (ReaderT
         (FunArgContext arch)
         (Except
            (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
      ())
-> BlockDemands (ArchReg arch)
-> StateT
     (FunctionArgsState arch ids)
     (ReaderT
        (FunArgContext arch)
        (Except
           (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
     ()
forall a b. (a -> b) -> a -> b
$ DemandSet (ArchReg arch) -> BlockDemands (ArchReg arch)
forall (r :: Type -> Type). DemandSet r -> BlockDemands r
demandAlways (Set (Some (ArchReg arch)) -> DemandSet (ArchReg arch)
forall (r :: Type -> Type). RegisterSet r -> DemandSet r
registerDemandSet Set (Some (ArchReg arch))
demands)

      -- Only need registers if this call has a return value.
      if Maybe (MemSegmentOff (RegAddrWidth (ArchReg arch))) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (MemSegmentOff (RegAddrWidth (ArchReg arch)))
mReturnAddr then do
        -- Copy callee saved registers and stack pointer across function.
        let savedRegs :: [Some (ArchReg arch)]
savedRegs = 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]
: Set (Some (ArchReg arch)) -> [Some (ArchReg arch)]
forall a. Set a -> [a]
Set.toList (ArchDemandInfo arch -> Set (Some (ArchReg arch))
forall arch. ArchDemandInfo arch -> Set (Some (ArchReg arch))
calleeSavedRegs ArchDemandInfo arch
ainfo)
        MemSegmentOff (RegAddrWidth (ArchReg arch))
-> RegState (ArchReg arch) (Value arch ids)
-> [Some (ArchReg arch)]
-> FunctionArgsM arch ids (FinalRegisterDemands (ArchReg arch))
forall arch ids (t :: Type -> Type).
(RegisterInfo (ArchReg arch), FoldableFC (ArchFn arch),
 Foldable t) =>
ArchSegmentOff arch
-> RegState (ArchReg arch) (Value arch ids)
-> t (Some (ArchReg arch))
-> FunctionArgsM arch ids (FinalRegisterDemands (ArchReg arch))
recordBlockTransfer MemSegmentOff (RegAddrWidth (ArchReg arch))
blockAddr RegState (ArchReg arch) (Value arch ids)
finalRegs [Some (ArchReg arch)]
savedRegs
       else
        FinalRegisterDemands (ArchReg arch)
-> FunctionArgsM arch ids (FinalRegisterDemands (ArchReg arch))
forall a.
a
-> StateT
     (FunctionArgsState arch ids)
     (ReaderT
        (FunArgContext arch)
        (Except
           (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
     a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure FinalRegisterDemands (ArchReg arch)
forall a. Monoid a => a
mempty

recordStmtsDemands :: OrdF (ArchReg arch)
                   => ArchSegmentOff arch -- ^ Address of block
                   -> ArchAddrWord arch -- ^ Offset from start of block of current instruction.
                   -> [Stmt arch ids]
                   -> FunctionArgsM arch ids (ArchAddrWord arch)
recordStmtsDemands :: forall arch ids.
OrdF (ArchReg arch) =>
ArchSegmentOff arch
-> ArchAddrWord arch
-> [Stmt arch ids]
-> FunctionArgsM arch ids (ArchAddrWord arch)
recordStmtsDemands ArchSegmentOff arch
_blockAddr ArchAddrWord arch
off [] = do
  ArchAddrWord arch -> FunctionArgsM arch ids (ArchAddrWord arch)
forall a.
a
-> StateT
     (FunctionArgsState arch ids)
     (ReaderT
        (FunArgContext arch)
        (Except
           (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
     a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ArchAddrWord arch
off
recordStmtsDemands ArchSegmentOff arch
blockAddr ArchAddrWord arch
off (Stmt arch ids
stmt:[Stmt arch ids]
stmts) = do
  DemandContext arch
ctx <- (FunArgContext arch -> DemandContext arch)
-> StateT
     (FunctionArgsState arch ids)
     (ReaderT
        (FunArgContext arch)
        (Except
           (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
     (DemandContext arch)
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks ((FunArgContext arch -> DemandContext arch)
 -> StateT
      (FunctionArgsState arch ids)
      (ReaderT
         (FunArgContext arch)
         (Except
            (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
      (DemandContext arch))
-> (FunArgContext arch -> DemandContext arch)
-> StateT
     (FunctionArgsState arch ids)
     (ReaderT
        (FunArgContext arch)
        (Except
           (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
     (DemandContext arch)
forall a b. (a -> b) -> a -> b
$ ArchDemandInfo arch -> DemandContext arch
forall arch. ArchDemandInfo arch -> DemandContext arch
demandInfoCtx (ArchDemandInfo arch -> DemandContext arch)
-> (FunArgContext arch -> ArchDemandInfo arch)
-> FunArgContext arch
-> DemandContext arch
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FunArgContext arch -> ArchDemandInfo arch
forall arch. FunArgContext arch -> ArchDemandInfo arch
archDemandInfo
  DemandContext arch
-> forall a.
   ((FoldableFC (ArchFn arch), FoldableF (ArchStmt arch)) => a) -> a
forall arch.
DemandContext arch
-> forall a.
   ((FoldableFC (ArchFn arch), FoldableF (ArchStmt arch)) => a) -> a
demandConstraints DemandContext arch
ctx (((FoldableFC (ArchFn arch), FoldableF (ArchStmt arch)) =>
  FunctionArgsM arch ids (ArchAddrWord arch))
 -> FunctionArgsM arch ids (ArchAddrWord arch))
-> ((FoldableFC (ArchFn arch), FoldableF (ArchStmt arch)) =>
    FunctionArgsM arch ids (ArchAddrWord arch))
-> FunctionArgsM arch ids (ArchAddrWord arch)
forall a b. (a -> b) -> a -> b
$ do
   case Stmt arch ids
stmt of
    AssignStmt Assignment arch ids tp
a -> do
      Bool
-> StateT
     (FunctionArgsState arch ids)
     (ReaderT
        (FunArgContext arch)
        (Except
           (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
     ()
-> StateT
     (FunctionArgsState arch ids)
     (ReaderT
        (FunArgContext arch)
        (Except
           (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
     ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (DemandContext arch -> AssignRhs arch (Value arch ids) tp -> Bool
forall arch (f :: Type -> Type) (tp :: Type).
DemandContext arch -> AssignRhs arch f tp -> Bool
hasSideEffects DemandContext arch
ctx (Assignment arch ids tp -> AssignRhs arch (Value arch ids) tp
forall arch ids (tp :: Type).
Assignment arch ids tp -> AssignRhs arch (Value arch ids) tp
assignRhs Assignment arch ids tp
a)) (StateT
   (FunctionArgsState arch ids)
   (ReaderT
      (FunArgContext arch)
      (Except
         (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
   ()
 -> StateT
      (FunctionArgsState arch ids)
      (ReaderT
         (FunArgContext arch)
         (Except
            (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
      ())
-> StateT
     (FunctionArgsState arch ids)
     (ReaderT
        (FunArgContext arch)
        (Except
           (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
     ()
-> StateT
     (FunctionArgsState arch ids)
     (ReaderT
        (FunArgContext arch)
        (Except
           (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
     ()
forall a b. (a -> b) -> a -> b
$ do
        (forall (x :: Type).
 Value arch ids x
 -> StateT
      (FunctionArgsState arch ids)
      (ReaderT
         (FunArgContext arch)
         (Except
            (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
      ())
-> forall (x :: Type).
   AssignRhs arch (Value arch ids) x
   -> StateT
        (FunctionArgsState arch ids)
        (ReaderT
           (FunArgContext arch)
           (Except
              (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
        ()
forall {k} {l} (t :: (k -> Type) -> l -> Type) (m :: Type -> Type)
       (f :: k -> Type) a.
(FoldableFC t, Applicative m) =>
(forall (x :: k). f x -> m a) -> forall (x :: l). t f x -> m ()
traverseFC_ (ArchSegmentOff arch
-> Value arch ids x
-> StateT
     (FunctionArgsState arch ids)
     (ReaderT
        (FunArgContext arch)
        (Except
           (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
     ()
forall arch ids (tp :: Type).
(OrdF (ArchReg arch), FoldableFC (ArchFn arch)) =>
ArchSegmentOff arch
-> Value arch ids tp -> FunctionArgsM arch ids ()
demandValue ArchSegmentOff arch
blockAddr) (Assignment arch ids tp -> AssignRhs arch (Value arch ids) tp
forall arch ids (tp :: Type).
Assignment arch ids tp -> AssignRhs arch (Value arch ids) tp
assignRhs Assignment arch ids tp
a)
      ArchSegmentOff arch
-> ArchAddrWord arch
-> [Stmt arch ids]
-> FunctionArgsM arch ids (ArchAddrWord arch)
forall arch ids.
OrdF (ArchReg arch) =>
ArchSegmentOff arch
-> ArchAddrWord arch
-> [Stmt arch ids]
-> FunctionArgsM arch ids (ArchAddrWord arch)
recordStmtsDemands ArchSegmentOff arch
blockAddr ArchAddrWord arch
off [Stmt arch ids]
stmts
    WriteMem ArchAddrValue arch ids
addr MemRepr tp
_ Value arch ids tp
v -> do
      ArchSegmentOff arch
-> ArchAddrValue arch ids
-> StateT
     (FunctionArgsState arch ids)
     (ReaderT
        (FunArgContext arch)
        (Except
           (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
     ()
forall arch ids (tp :: Type).
(OrdF (ArchReg arch), FoldableFC (ArchFn arch)) =>
ArchSegmentOff arch
-> Value arch ids tp -> FunctionArgsM arch ids ()
demandValue ArchSegmentOff arch
blockAddr ArchAddrValue arch ids
addr
      ArchSegmentOff arch
-> Value arch ids tp
-> StateT
     (FunctionArgsState arch ids)
     (ReaderT
        (FunArgContext arch)
        (Except
           (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
     ()
forall arch ids (tp :: Type).
(OrdF (ArchReg arch), FoldableFC (ArchFn arch)) =>
ArchSegmentOff arch
-> Value arch ids tp -> FunctionArgsM arch ids ()
demandValue ArchSegmentOff arch
blockAddr Value arch ids tp
v
      ArchSegmentOff arch
-> ArchAddrWord arch
-> [Stmt arch ids]
-> FunctionArgsM arch ids (ArchAddrWord arch)
forall arch ids.
OrdF (ArchReg arch) =>
ArchSegmentOff arch
-> ArchAddrWord arch
-> [Stmt arch ids]
-> FunctionArgsM arch ids (ArchAddrWord arch)
recordStmtsDemands ArchSegmentOff arch
blockAddr ArchAddrWord arch
off [Stmt arch ids]
stmts
    CondWriteMem Value arch ids BoolType
cond ArchAddrValue arch ids
addr MemRepr tp
_ Value arch ids tp
v -> do
      ArchSegmentOff arch
-> Value arch ids BoolType
-> StateT
     (FunctionArgsState arch ids)
     (ReaderT
        (FunArgContext arch)
        (Except
           (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
     ()
forall arch ids (tp :: Type).
(OrdF (ArchReg arch), FoldableFC (ArchFn arch)) =>
ArchSegmentOff arch
-> Value arch ids tp -> FunctionArgsM arch ids ()
demandValue ArchSegmentOff arch
blockAddr Value arch ids BoolType
cond
      ArchSegmentOff arch
-> ArchAddrValue arch ids
-> StateT
     (FunctionArgsState arch ids)
     (ReaderT
        (FunArgContext arch)
        (Except
           (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
     ()
forall arch ids (tp :: Type).
(OrdF (ArchReg arch), FoldableFC (ArchFn arch)) =>
ArchSegmentOff arch
-> Value arch ids tp -> FunctionArgsM arch ids ()
demandValue ArchSegmentOff arch
blockAddr ArchAddrValue arch ids
addr
      ArchSegmentOff arch
-> Value arch ids tp
-> StateT
     (FunctionArgsState arch ids)
     (ReaderT
        (FunArgContext arch)
        (Except
           (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
     ()
forall arch ids (tp :: Type).
(OrdF (ArchReg arch), FoldableFC (ArchFn arch)) =>
ArchSegmentOff arch
-> Value arch ids tp -> FunctionArgsM arch ids ()
demandValue ArchSegmentOff arch
blockAddr Value arch ids tp
v
      ArchSegmentOff arch
-> ArchAddrWord arch
-> [Stmt arch ids]
-> FunctionArgsM arch ids (ArchAddrWord arch)
forall arch ids.
OrdF (ArchReg arch) =>
ArchSegmentOff arch
-> ArchAddrWord arch
-> [Stmt arch ids]
-> FunctionArgsM arch ids (ArchAddrWord arch)
recordStmtsDemands ArchSegmentOff arch
blockAddr ArchAddrWord arch
off [Stmt arch ids]
stmts
    InstructionStart ArchAddrWord arch
off' Text
_ -> do
      ArchSegmentOff arch
-> ArchAddrWord arch
-> [Stmt arch ids]
-> FunctionArgsM arch ids (ArchAddrWord arch)
forall arch ids.
OrdF (ArchReg arch) =>
ArchSegmentOff arch
-> ArchAddrWord arch
-> [Stmt arch ids]
-> FunctionArgsM arch ids (ArchAddrWord arch)
recordStmtsDemands ArchSegmentOff arch
blockAddr ArchAddrWord arch
off' [Stmt arch ids]
stmts
    Comment Text
_ -> do
      ArchSegmentOff arch
-> ArchAddrWord arch
-> [Stmt arch ids]
-> FunctionArgsM arch ids (ArchAddrWord arch)
forall arch ids.
OrdF (ArchReg arch) =>
ArchSegmentOff arch
-> ArchAddrWord arch
-> [Stmt arch ids]
-> FunctionArgsM arch ids (ArchAddrWord arch)
recordStmtsDemands ArchSegmentOff arch
blockAddr ArchAddrWord arch
off [Stmt arch ids]
stmts
    ExecArchStmt ArchStmt arch (Value arch ids)
astmt -> do
      (forall (x :: Type).
 Value arch ids x
 -> StateT
      (FunctionArgsState arch ids)
      (ReaderT
         (FunArgContext arch)
         (Except
            (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
      ())
-> ArchStmt arch (Value arch ids)
-> StateT
     (FunctionArgsState arch ids)
     (ReaderT
        (FunArgContext arch)
        (Except
           (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
     ()
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_ (ArchSegmentOff arch
-> Value arch ids s
-> StateT
     (FunctionArgsState arch ids)
     (ReaderT
        (FunArgContext arch)
        (Except
           (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
     ()
forall arch ids (tp :: Type).
(OrdF (ArchReg arch), FoldableFC (ArchFn arch)) =>
ArchSegmentOff arch
-> Value arch ids tp -> FunctionArgsM arch ids ()
demandValue ArchSegmentOff arch
blockAddr) ArchStmt arch (Value arch ids)
astmt
      ArchSegmentOff arch
-> ArchAddrWord arch
-> [Stmt arch ids]
-> FunctionArgsM arch ids (ArchAddrWord arch)
forall arch ids.
OrdF (ArchReg arch) =>
ArchSegmentOff arch
-> ArchAddrWord arch
-> [Stmt arch ids]
-> FunctionArgsM arch ids (ArchAddrWord arch)
recordStmtsDemands ArchSegmentOff arch
blockAddr ArchAddrWord arch
off [Stmt arch ids]
stmts
    ArchState ArchMemAddr arch
_addr MapF (ArchReg arch) (Value arch ids)
_assn -> do
      ArchSegmentOff arch
-> ArchAddrWord arch
-> [Stmt arch ids]
-> FunctionArgsM arch ids (ArchAddrWord arch)
forall arch ids.
OrdF (ArchReg arch) =>
ArchSegmentOff arch
-> ArchAddrWord arch
-> [Stmt arch ids]
-> FunctionArgsM arch ids (ArchAddrWord arch)
recordStmtsDemands ArchSegmentOff arch
blockAddr ArchAddrWord arch
off [Stmt arch ids]
stmts

-- | 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.
summarizeBlock :: forall arch ids
               .  ArchConstraints arch
               => ParsedBlock arch ids -- ^ Current block
               -> FunctionArgsM arch ids (FinalRegisterDemands (ArchReg arch))
summarizeBlock :: forall arch ids.
ArchConstraints arch =>
ParsedBlock arch ids
-> FunctionArgsM arch ids (FinalRegisterDemands (ArchReg arch))
summarizeBlock ParsedBlock arch ids
b = do
  let blockAddr :: ArchSegmentOff arch
blockAddr = ParsedBlock arch ids -> ArchSegmentOff arch
forall arch ids. ParsedBlock arch ids -> ArchSegmentOff arch
pblockAddr ParsedBlock arch ids
b

  -- Add this label to block demand map with empty set.
  ArchSegmentOff arch
-> BlockDemands (ArchReg arch)
-> StateT
     (FunctionArgsState arch ids)
     (ReaderT
        (FunArgContext arch)
        (Except
           (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
     ()
forall arch ids.
OrdF (ArchReg arch) =>
ArchSegmentOff arch
-> BlockDemands (ArchReg arch) -> FunctionArgsM arch ids ()
addBlockDemands ArchSegmentOff arch
blockAddr BlockDemands (ArchReg arch)
forall a. Monoid a => a
mempty

  FunArgContext arch
ctx <- StateT
  (FunctionArgsState arch ids)
  (ReaderT
     (FunArgContext arch)
     (Except
        (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
  (FunArgContext arch)
forall r (m :: Type -> Type). MonadReader r m => m r
ask
  let ainfo :: ArchDemandInfo arch
ainfo = FunArgContext arch -> ArchDemandInfo arch
forall arch. FunArgContext arch -> ArchDemandInfo arch
archDemandInfo FunArgContext arch
ctx
  -- Add all values demanded by non-terminal statements in list.
  MemWord (RegAddrWidth (ArchReg arch))
finalOff <- ArchSegmentOff arch
-> MemWord (RegAddrWidth (ArchReg arch))
-> [Stmt arch ids]
-> StateT
     (FunctionArgsState arch ids)
     (ReaderT
        (FunArgContext arch)
        (Except
           (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
     (MemWord (RegAddrWidth (ArchReg arch)))
forall arch ids.
OrdF (ArchReg arch) =>
ArchSegmentOff arch
-> ArchAddrWord arch
-> [Stmt arch ids]
-> FunctionArgsM arch ids (ArchAddrWord arch)
recordStmtsDemands ArchSegmentOff arch
blockAddr MemWord (RegAddrWidth (ArchReg arch))
0 (ParsedBlock arch ids -> [Stmt arch ids]
forall arch ids. ParsedBlock arch ids -> [Stmt arch ids]
pblockStmts ParsedBlock arch ids
b)
  -- Add values demanded by terminal statements
  case ParsedBlock arch ids -> ParsedTermStmt arch ids
forall arch ids. ParsedBlock arch ids -> ParsedTermStmt arch ids
pblockTermStmt ParsedBlock arch ids
b of
    ParsedCall RegState (ArchReg arch) (Value arch ids)
regs Maybe (ArchSegmentOff arch)
mRetAddr -> do
      -- Record the demands based on the call, and add edges between
      -- this note and next nodes.
      ArchSegmentOff arch
-> MemWord (RegAddrWidth (ArchReg arch))
-> RegState (ArchReg arch) (Value arch ids)
-> Maybe (ArchSegmentOff arch)
-> FunctionArgsM arch ids (FinalRegisterDemands (ArchReg arch))
forall arch ids.
(FoldableFC (ArchFn arch), RegisterInfo (ArchReg arch)) =>
ArchSegmentOff arch
-> ArchAddrWord arch
-> RegState (ArchReg arch) (Value arch ids)
-> Maybe (ArchSegmentOff arch)
-> FunctionArgsM arch ids (FinalRegisterDemands (ArchReg arch))
summarizeCall ArchSegmentOff arch
blockAddr MemWord (RegAddrWidth (ArchReg arch))
finalOff RegState (ArchReg arch) (Value arch ids)
regs Maybe (ArchSegmentOff arch)
mRetAddr

    PLTStub{} -> do
      FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch))
-> FunctionArgsM arch ids (FinalRegisterDemands (ArchReg arch))
forall a.
FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch))
-> StateT
     (FunctionArgsState arch ids)
     (ReaderT
        (FunArgContext arch)
        (Except
           (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
     a
forall e (m :: Type -> Type) a. MonadError e m => e -> m a
throwError FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch))
forall (w :: Nat). FunctionArgAnalysisFailure w
PLTStubNotSupported
    ParsedJump RegState (ArchReg arch) (Value arch ids)
regs ArchSegmentOff arch
_tgtAddr -> do
      -- record all propagations
      ArchSegmentOff arch
-> RegState (ArchReg arch) (Value arch ids)
-> [Some (ArchReg arch)]
-> FunctionArgsM arch ids (FinalRegisterDemands (ArchReg arch))
forall arch ids (t :: Type -> Type).
(RegisterInfo (ArchReg arch), FoldableFC (ArchFn arch),
 Foldable t) =>
ArchSegmentOff arch
-> RegState (ArchReg arch) (Value arch ids)
-> t (Some (ArchReg arch))
-> FunctionArgsM arch ids (FinalRegisterDemands (ArchReg arch))
recordBlockTransfer ArchSegmentOff arch
blockAddr RegState (ArchReg arch) (Value arch ids)
regs [Some (ArchReg arch)]
forall (r :: Type -> Type). RegisterInfo r => [Some r]
archRegs

    ParsedBranch RegState (ArchReg arch) (Value arch ids)
regs Value arch ids BoolType
cond ArchSegmentOff arch
_trueAddr ArchSegmentOff arch
_falseAddr -> do
      ArchSegmentOff arch
-> Value arch ids BoolType
-> StateT
     (FunctionArgsState arch ids)
     (ReaderT
        (FunArgContext arch)
        (Except
           (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
     ()
forall arch ids (tp :: Type).
(OrdF (ArchReg arch), FoldableFC (ArchFn arch)) =>
ArchSegmentOff arch
-> Value arch ids tp -> FunctionArgsM arch ids ()
demandValue ArchSegmentOff arch
blockAddr Value arch ids BoolType
cond
      -- Compute all transfers
      ArchSegmentOff arch
-> RegState (ArchReg arch) (Value arch ids)
-> [Some (ArchReg arch)]
-> FunctionArgsM arch ids (FinalRegisterDemands (ArchReg arch))
forall arch ids (t :: Type -> Type).
(RegisterInfo (ArchReg arch), FoldableFC (ArchFn arch),
 Foldable t) =>
ArchSegmentOff arch
-> RegState (ArchReg arch) (Value arch ids)
-> t (Some (ArchReg arch))
-> FunctionArgsM arch ids (FinalRegisterDemands (ArchReg arch))
recordBlockTransfer ArchSegmentOff arch
blockAddr RegState (ArchReg arch) (Value arch ids)
regs [Some (ArchReg arch)]
forall (r :: Type -> Type). RegisterInfo r => [Some r]
archRegs

    ParsedLookupTable JumpTableLayout arch
_layout RegState (ArchReg arch) (Value arch ids)
regs ArchAddrValue arch ids
lookupIdx Vector (ArchSegmentOff arch)
_vec -> do
      ArchSegmentOff arch
-> ArchAddrValue arch ids
-> StateT
     (FunctionArgsState arch ids)
     (ReaderT
        (FunArgContext arch)
        (Except
           (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
     ()
forall arch ids (tp :: Type).
(OrdF (ArchReg arch), FoldableFC (ArchFn arch)) =>
ArchSegmentOff arch
-> Value arch ids tp -> FunctionArgsM arch ids ()
demandValue ArchSegmentOff arch
blockAddr ArchAddrValue arch ids
lookupIdx
      -- record all propagations
      ArchSegmentOff arch
-> RegState (ArchReg arch) (Value arch ids)
-> [Some (ArchReg arch)]
-> FunctionArgsM arch ids (FinalRegisterDemands (ArchReg arch))
forall arch ids (t :: Type -> Type).
(RegisterInfo (ArchReg arch), FoldableFC (ArchFn arch),
 Foldable t) =>
ArchSegmentOff arch
-> RegState (ArchReg arch) (Value arch ids)
-> t (Some (ArchReg arch))
-> FunctionArgsM arch ids (FinalRegisterDemands (ArchReg arch))
recordBlockTransfer ArchSegmentOff arch
blockAddr RegState (ArchReg arch) (Value arch ids)
regs [Some (ArchReg arch)]
forall (r :: Type -> Type). RegisterInfo r => [Some r]
archRegs

    ParsedReturn RegState (ArchReg arch) (Value arch ids)
regs -> do
      let retRegs :: [Some (ArchReg arch)]
retRegs = ArchDemandInfo arch -> [Some (ArchReg arch)]
forall arch. ArchDemandInfo arch -> [Some (ArchReg arch)]
functionRetRegs ArchDemandInfo arch
ainfo
      let regDemandSet :: BlockDemands (ArchReg arch)
-> Some (ArchReg arch)
-> StateT
     (AssignmentCache (ArchReg arch) ids)
     Identity
     (BlockDemands (ArchReg arch))
regDemandSet BlockDemands (ArchReg arch)
m (Some ArchReg arch x
r) = do
            RegisterSet (ArchReg arch)
rUses <- Value arch ids x
-> StateT
     (AssignmentCache (ArchReg arch) ids)
     Identity
     (RegisterSet (ArchReg arch))
forall arch ids (tp :: Type).
(OrdF (ArchReg arch), FoldableFC (ArchFn arch)) =>
Value arch ids tp
-> State
     (AssignmentCache (ArchReg arch) ids) (RegisterSet (ArchReg arch))
valueUses (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)
            BlockDemands (ArchReg arch)
-> StateT
     (AssignmentCache (ArchReg arch) ids)
     Identity
     (BlockDemands (ArchReg arch))
forall a.
a -> StateT (AssignmentCache (ArchReg arch) ids) Identity a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (BlockDemands (ArchReg arch)
 -> StateT
      (AssignmentCache (ArchReg arch) ids)
      Identity
      (BlockDemands (ArchReg arch)))
-> BlockDemands (ArchReg arch)
-> StateT
     (AssignmentCache (ArchReg arch) ids)
     Identity
     (BlockDemands (ArchReg arch))
forall a b. (a -> b) -> a -> b
$! ArchReg arch x
-> DemandSet (ArchReg arch)
-> BlockDemands (ArchReg arch)
-> BlockDemands (ArchReg arch)
forall (r :: Type -> Type) (tp :: Type).
OrdF r =>
r tp -> DemandSet r -> BlockDemands r -> BlockDemands r
addDemandFunctionResult ArchReg arch x
r (RegisterSet (ArchReg arch) -> DemandSet (ArchReg arch)
forall (r :: Type -> Type). RegisterSet r -> DemandSet r
registerDemandSet RegisterSet (ArchReg arch)
rUses) BlockDemands (ArchReg arch)
m
      BlockDemands (ArchReg arch)
demands <- StateT
  (AssignmentCache (ArchReg arch) ids)
  Identity
  (BlockDemands (ArchReg arch))
-> StateT
     (FunctionArgsState arch ids)
     (ReaderT
        (FunArgContext arch)
        (Except
           (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
     (BlockDemands (ArchReg arch))
forall arch ids a.
State (AssignmentCache (ArchReg arch) ids) a
-> FunctionArgsM arch ids a
withAssignmentCache (StateT
   (AssignmentCache (ArchReg arch) ids)
   Identity
   (BlockDemands (ArchReg arch))
 -> StateT
      (FunctionArgsState arch ids)
      (ReaderT
         (FunArgContext arch)
         (Except
            (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
      (BlockDemands (ArchReg arch)))
-> StateT
     (AssignmentCache (ArchReg arch) ids)
     Identity
     (BlockDemands (ArchReg arch))
-> StateT
     (FunctionArgsState arch ids)
     (ReaderT
        (FunArgContext arch)
        (Except
           (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
     (BlockDemands (ArchReg arch))
forall a b. (a -> b) -> a -> b
$ (BlockDemands (ArchReg arch)
 -> Some (ArchReg arch)
 -> StateT
      (AssignmentCache (ArchReg arch) ids)
      Identity
      (BlockDemands (ArchReg arch)))
-> BlockDemands (ArchReg arch)
-> [Some (ArchReg arch)]
-> StateT
     (AssignmentCache (ArchReg arch) ids)
     Identity
     (BlockDemands (ArchReg arch))
forall (t :: Type -> Type) (m :: Type -> Type) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM BlockDemands (ArchReg arch)
-> Some (ArchReg arch)
-> StateT
     (AssignmentCache (ArchReg arch) ids)
     Identity
     (BlockDemands (ArchReg arch))
regDemandSet BlockDemands (ArchReg arch)
forall a. Monoid a => a
mempty [Some (ArchReg arch)]
retRegs
      ArchSegmentOff arch
-> BlockDemands (ArchReg arch)
-> StateT
     (FunctionArgsState arch ids)
     (ReaderT
        (FunArgContext arch)
        (Except
           (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
     ()
forall arch ids.
OrdF (ArchReg arch) =>
ArchSegmentOff arch
-> BlockDemands (ArchReg arch) -> FunctionArgsM arch ids ()
addBlockDemands ArchSegmentOff arch
blockAddr BlockDemands (ArchReg arch)
demands
      FinalRegisterDemands (ArchReg arch)
-> FunctionArgsM arch ids (FinalRegisterDemands (ArchReg arch))
forall a.
a
-> StateT
     (FunctionArgsState arch ids)
     (ReaderT
        (FunArgContext arch)
        (Except
           (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
     a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure FinalRegisterDemands (ArchReg arch)
forall a. Monoid a => a
mempty

    ParsedArchTermStmt ArchTermStmt arch (Value arch ids)
tstmt RegState (ArchReg arch) (Value arch ids)
regs Maybe (ArchSegmentOff arch)
_nextAddr -> do
       -- Compute effects of terminal statement.
      let e :: ArchTermStmtRegEffects arch
e = ArchDemandInfo arch
-> forall ids. ComputeArchTermStmtEffects arch ids
forall arch.
ArchDemandInfo arch
-> forall ids. ComputeArchTermStmtEffects arch ids
computeArchTermStmtEffects ArchDemandInfo arch
ainfo ArchTermStmt arch (Value arch ids)
tstmt RegState (ArchReg arch) (Value arch ids)
regs

      -- Demand all registers the terminal statement demands.
      do let regUses :: RegisterSet (ArchReg arch)
-> Some (ArchReg arch)
-> StateT
     (AssignmentCache (ArchReg arch) ids)
     Identity
     (RegisterSet (ArchReg arch))
regUses RegisterSet (ArchReg arch)
s (Some ArchReg arch x
r) = RegisterSet (ArchReg arch)
-> Value arch ids x
-> StateT
     (AssignmentCache (ArchReg arch) ids)
     Identity
     (RegisterSet (ArchReg arch))
forall arch ids (tp :: Type).
(OrdF (ArchReg arch), FoldableFC (ArchFn arch)) =>
RegisterSet (ArchReg arch)
-> Value arch ids tp
-> State
     (AssignmentCache (ArchReg arch) ids) (RegisterSet (ArchReg arch))
addValueUses RegisterSet (ArchReg arch)
s (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)
         RegisterSet (ArchReg arch)
demands <- StateT
  (AssignmentCache (ArchReg arch) ids)
  Identity
  (RegisterSet (ArchReg arch))
-> StateT
     (FunctionArgsState arch ids)
     (ReaderT
        (FunArgContext arch)
        (Except
           (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
     (RegisterSet (ArchReg arch))
forall arch ids a.
State (AssignmentCache (ArchReg arch) ids) a
-> FunctionArgsM arch ids a
withAssignmentCache (StateT
   (AssignmentCache (ArchReg arch) ids)
   Identity
   (RegisterSet (ArchReg arch))
 -> StateT
      (FunctionArgsState arch ids)
      (ReaderT
         (FunArgContext arch)
         (Except
            (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
      (RegisterSet (ArchReg arch)))
-> StateT
     (AssignmentCache (ArchReg arch) ids)
     Identity
     (RegisterSet (ArchReg arch))
-> StateT
     (FunctionArgsState arch ids)
     (ReaderT
        (FunArgContext arch)
        (Except
           (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
     (RegisterSet (ArchReg arch))
forall a b. (a -> b) -> a -> b
$
           (RegisterSet (ArchReg arch)
 -> Some (ArchReg arch)
 -> StateT
      (AssignmentCache (ArchReg arch) ids)
      Identity
      (RegisterSet (ArchReg arch)))
-> RegisterSet (ArchReg arch)
-> [Some (ArchReg arch)]
-> StateT
     (AssignmentCache (ArchReg arch) ids)
     Identity
     (RegisterSet (ArchReg arch))
forall (t :: Type -> Type) (m :: Type -> Type) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM RegisterSet (ArchReg arch)
-> Some (ArchReg arch)
-> StateT
     (AssignmentCache (ArchReg arch) ids)
     Identity
     (RegisterSet (ArchReg arch))
regUses RegisterSet (ArchReg arch)
forall a. Set a
Set.empty (ArchTermStmtRegEffects arch -> [Some (ArchReg arch)]
forall arch. ArchTermStmtRegEffects arch -> [Some (ArchReg arch)]
termRegDemands ArchTermStmtRegEffects arch
e)
         ArchSegmentOff arch
-> BlockDemands (ArchReg arch)
-> StateT
     (FunctionArgsState arch ids)
     (ReaderT
        (FunArgContext arch)
        (Except
           (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
     ()
forall arch ids.
OrdF (ArchReg arch) =>
ArchSegmentOff arch
-> BlockDemands (ArchReg arch) -> FunctionArgsM arch ids ()
addBlockDemands ArchSegmentOff arch
blockAddr (BlockDemands (ArchReg arch)
 -> StateT
      (FunctionArgsState arch ids)
      (ReaderT
         (FunArgContext arch)
         (Except
            (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
      ())
-> BlockDemands (ArchReg arch)
-> StateT
     (FunctionArgsState arch ids)
     (ReaderT
        (FunArgContext arch)
        (Except
           (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
     ()
forall a b. (a -> b) -> a -> b
$ DemandSet (ArchReg arch) -> BlockDemands (ArchReg arch)
forall (r :: Type -> Type). DemandSet r -> BlockDemands r
demandAlways (RegisterSet (ArchReg arch) -> DemandSet (ArchReg arch)
forall (r :: Type -> Type). RegisterSet r -> DemandSet r
registerDemandSet RegisterSet (ArchReg arch)
demands)
      -- Record registers transered.
      ArchSegmentOff arch
-> RegState (ArchReg arch) (Value arch ids)
-> [Some (ArchReg arch)]
-> FunctionArgsM arch ids (FinalRegisterDemands (ArchReg arch))
forall arch ids (t :: Type -> Type).
(RegisterInfo (ArchReg arch), FoldableFC (ArchFn arch),
 Foldable t) =>
ArchSegmentOff arch
-> RegState (ArchReg arch) (Value arch ids)
-> t (Some (ArchReg arch))
-> FunctionArgsM arch ids (FinalRegisterDemands (ArchReg arch))
recordBlockTransfer ArchSegmentOff arch
blockAddr RegState (ArchReg arch) (Value arch ids)
regs (ArchTermStmtRegEffects arch -> [Some (ArchReg arch)]
forall arch. ArchTermStmtRegEffects arch -> [Some (ArchReg arch)]
termRegTransfers ArchTermStmtRegEffects arch
e)
    ParsedTranslateError Text
_ -> do
      -- We ignore demands for translate errors.
      FinalRegisterDemands (ArchReg arch)
-> FunctionArgsM arch ids (FinalRegisterDemands (ArchReg arch))
forall a.
a
-> StateT
     (FunctionArgsState arch ids)
     (ReaderT
        (FunArgContext arch)
        (Except
           (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
     a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure FinalRegisterDemands (ArchReg arch)
forall a. Monoid a => a
mempty
    ClassifyFailure RegState (ArchReg arch) (Value arch ids)
_ [String]
_ ->
      -- We ignore demands for classify failure.
      FinalRegisterDemands (ArchReg arch)
-> FunctionArgsM arch ids (FinalRegisterDemands (ArchReg arch))
forall a.
a
-> StateT
     (FunctionArgsState arch ids)
     (ReaderT
        (FunArgContext arch)
        (Except
           (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
     a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure FinalRegisterDemands (ArchReg arch)
forall a. Monoid a => a
mempty

transferRegDemand :: ( MemWidth (ArchAddrWidth arch)
                     , OrdF (ArchReg arch)
                     , ShowF (ArchReg arch)
                     )
                  => FinalRegisterDemands (ArchReg arch)
                  -> DemandSet (ArchReg arch)
                  -- ^ Demands of the start of the next block
                  -> Some (ArchReg arch)
                     -- ^ The register to back propagate
                  -> FunctionArgsM arch ids (DemandSet (ArchReg arch))
transferRegDemand :: forall arch ids.
(MemWidth (ArchAddrWidth arch), OrdF (ArchReg arch),
 ShowF (ArchReg arch)) =>
FinalRegisterDemands (ArchReg arch)
-> DemandSet (ArchReg arch)
-> Some (ArchReg arch)
-> FunctionArgsM arch ids (DemandSet (ArchReg arch))
transferRegDemand (FRD Map (Some (ArchReg arch)) (DemandSet (ArchReg arch))
xfer) DemandSet (ArchReg arch)
s (Some ArchReg arch x
r) =
  case Some (ArchReg arch)
-> Map (Some (ArchReg arch)) (DemandSet (ArchReg arch))
-> Maybe (DemandSet (ArchReg arch))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (ArchReg arch x -> Some (ArchReg arch)
forall k (f :: k -> Type) (x :: k). f x -> Some f
Some ArchReg arch x
r) Map (Some (ArchReg arch)) (DemandSet (ArchReg arch))
xfer of
    Just DemandSet (ArchReg arch)
t -> DemandSet (ArchReg arch)
-> FunctionArgsM arch ids (DemandSet (ArchReg arch))
forall a.
a
-> StateT
     (FunctionArgsState arch ids)
     (ReaderT
        (FunArgContext arch)
        (Except (FunctionArgAnalysisFailure (ArchAddrWidth arch))))
     a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (DemandSet (ArchReg arch)
 -> FunctionArgsM arch ids (DemandSet (ArchReg arch)))
-> DemandSet (ArchReg arch)
-> FunctionArgsM arch ids (DemandSet (ArchReg arch))
forall a b. (a -> b) -> a -> b
$ DemandSet (ArchReg arch)
-> DemandSet (ArchReg arch) -> DemandSet (ArchReg arch)
forall a. Monoid a => a -> a -> a
mappend DemandSet (ArchReg arch)
s DemandSet (ArchReg arch)
t
    Maybe (DemandSet (ArchReg arch))
Nothing -> DemandSet (ArchReg arch)
-> FunctionArgsM arch ids (DemandSet (ArchReg arch))
forall a.
a
-> StateT
     (FunctionArgsState arch ids)
     (ReaderT
        (FunArgContext arch)
        (Except (FunctionArgAnalysisFailure (ArchAddrWidth arch))))
     a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure DemandSet (ArchReg arch)
s

transferDemands :: ( MemWidth (ArchAddrWidth arch)
                   , OrdF (ArchReg arch)
                   , ShowF (ArchReg arch)
                   )
                => FinalRegisterDemands (ArchReg arch)
                   -- ^ Map from registers to demand sets in
                   -- previous block needed to compute that register.
                -> DemandSet (ArchReg arch)
                   -- ^ Demands of the start of the next block
                -> FunctionArgsM arch ids (DemandSet (ArchReg arch))
transferDemands :: forall arch ids.
(MemWidth (ArchAddrWidth arch), OrdF (ArchReg arch),
 ShowF (ArchReg arch)) =>
FinalRegisterDemands (ArchReg arch)
-> DemandSet (ArchReg arch)
-> FunctionArgsM arch ids (DemandSet (ArchReg arch))
transferDemands FinalRegisterDemands (ArchReg arch)
xfer (DemandSet RegisterSet (ArchReg arch)
regs Map
  (MemSegmentOff (ArchAddrWidth arch)) (RegisterSet (ArchReg arch))
funs) = do
  (DemandSet (ArchReg arch)
 -> Some (ArchReg arch)
 -> FunctionArgsM arch ids (DemandSet (ArchReg arch)))
-> DemandSet (ArchReg arch)
-> RegisterSet (ArchReg arch)
-> FunctionArgsM arch ids (DemandSet (ArchReg arch))
forall (t :: Type -> Type) (m :: Type -> Type) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM (FinalRegisterDemands (ArchReg arch)
-> DemandSet (ArchReg arch)
-> Some (ArchReg arch)
-> FunctionArgsM arch ids (DemandSet (ArchReg arch))
forall arch ids.
(MemWidth (ArchAddrWidth arch), OrdF (ArchReg arch),
 ShowF (ArchReg arch)) =>
FinalRegisterDemands (ArchReg arch)
-> DemandSet (ArchReg arch)
-> Some (ArchReg arch)
-> FunctionArgsM arch ids (DemandSet (ArchReg arch))
transferRegDemand FinalRegisterDemands (ArchReg arch)
xfer) (RegisterSet (ArchReg arch)
-> Map
     (MemSegmentOff (ArchAddrWidth arch)) (RegisterSet (ArchReg arch))
-> DemandSet (ArchReg arch)
forall (r :: Type -> Type).
RegisterSet r
-> Map (MemSegmentOff (RegAddrWidth r)) (RegisterSet r)
-> DemandSet r
DemandSet RegisterSet (ArchReg arch)
forall a. Set a
Set.empty Map
  (MemSegmentOff (ArchAddrWidth arch)) (RegisterSet (ArchReg arch))
funs) RegisterSet (ArchReg arch)
regs

-- | Given new demands on a register, this back propagates the demands
-- to the predecessor blocks.
calculateOnePred :: ( MemWidth (ArchAddrWidth arch)
                    , OrdF (ArchReg arch)
                    , ShowF (ArchReg arch)
                    )
                 => Map (ArchSegmentOff arch) (FinalRegisterDemands (ArchReg arch))
                    -- ^ Maps the entry point of each block in the function to the
                    -- register demands map for that block.
                 -> BlockDemands (ArchReg arch)
                    -- ^ New demands for this block.
                 -> Map (ArchSegmentOff arch) (BlockDemands (ArchReg arch))
                 -- ^ Maps each block to the demands that have not yet
                 -- been backpropagated to predecessors.
                 -> ArchSegmentOff arch
                    -- ^ Address of the previous block.
                 -> FunctionArgsM arch ids (Map (ArchSegmentOff arch) (BlockDemands (ArchReg arch)))
calculateOnePred :: forall arch ids.
(MemWidth (ArchAddrWidth arch), OrdF (ArchReg arch),
 ShowF (ArchReg arch)) =>
Map (ArchSegmentOff arch) (FinalRegisterDemands (ArchReg arch))
-> BlockDemands (ArchReg arch)
-> Map (ArchSegmentOff arch) (BlockDemands (ArchReg arch))
-> ArchSegmentOff arch
-> FunctionArgsM
     arch ids (Map (ArchSegmentOff arch) (BlockDemands (ArchReg arch)))
calculateOnePred Map
  (MemSegmentOff (ArchAddrWidth arch))
  (FinalRegisterDemands (ArchReg arch))
xferMap (BD Map (DemandType (ArchReg arch)) (DemandSet (ArchReg arch))
newDemands) Map
  (MemSegmentOff (ArchAddrWidth arch)) (BlockDemands (ArchReg arch))
pendingMap MemSegmentOff (ArchAddrWidth arch)
predAddr = do
  let xfer :: FinalRegisterDemands (ArchReg arch)
xfer = Map
  (MemSegmentOff (ArchAddrWidth arch))
  (FinalRegisterDemands (ArchReg arch))
xferMapMap
  (MemSegmentOff (ArchAddrWidth arch))
  (FinalRegisterDemands (ArchReg arch))
-> Getting
     (FinalRegisterDemands (ArchReg arch))
     (Map
        (MemSegmentOff (ArchAddrWidth arch))
        (FinalRegisterDemands (ArchReg arch)))
     (FinalRegisterDemands (ArchReg arch))
-> FinalRegisterDemands (ArchReg arch)
forall s a. s -> Getting a s a -> a
^.Index
  (Map
     (MemSegmentOff (ArchAddrWidth arch))
     (FinalRegisterDemands (ArchReg arch)))
-> Traversal'
     (Map
        (MemSegmentOff (ArchAddrWidth arch))
        (FinalRegisterDemands (ArchReg arch)))
     (IxValue
        (Map
           (MemSegmentOff (ArchAddrWidth arch))
           (FinalRegisterDemands (ArchReg arch))))
forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Index
  (Map
     (MemSegmentOff (ArchAddrWidth arch))
     (FinalRegisterDemands (ArchReg arch)))
MemSegmentOff (ArchAddrWidth arch)
predAddr

  -- update uses, returning value before this iteration
  BD Map (DemandType (ArchReg arch)) (DemandSet (ArchReg arch))
seenDemands <- Getting
  (BlockDemands (ArchReg arch))
  (FunctionArgsState arch ids)
  (BlockDemands (ArchReg arch))
-> StateT
     (FunctionArgsState arch ids)
     (ReaderT
        (FunArgContext arch)
        (Except (FunctionArgAnalysisFailure (ArchAddrWidth arch))))
     (BlockDemands (ArchReg arch))
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
use ((Map
   (MemSegmentOff (ArchAddrWidth arch)) (BlockDemands (ArchReg arch))
 -> Const
      (BlockDemands (ArchReg arch))
      (Map
         (MemSegmentOff (ArchAddrWidth arch))
         (BlockDemands (ArchReg arch))))
-> FunctionArgsState arch ids
-> Const (BlockDemands (ArchReg arch)) (FunctionArgsState arch ids)
forall arch ids (f :: Type -> Type).
Functor f =>
(Map (ArchSegmentOff arch) (BlockDemands (ArchReg arch))
 -> f (Map (ArchSegmentOff arch) (BlockDemands (ArchReg arch))))
-> FunctionArgsState arch ids -> f (FunctionArgsState arch ids)
blockDemandMap ((Map
    (MemSegmentOff (ArchAddrWidth arch)) (BlockDemands (ArchReg arch))
  -> Const
       (BlockDemands (ArchReg arch))
       (Map
          (MemSegmentOff (ArchAddrWidth arch))
          (BlockDemands (ArchReg arch))))
 -> FunctionArgsState arch ids
 -> Const
      (BlockDemands (ArchReg arch)) (FunctionArgsState arch ids))
-> ((BlockDemands (ArchReg arch)
     -> Const
          (BlockDemands (ArchReg arch)) (BlockDemands (ArchReg arch)))
    -> Map
         (MemSegmentOff (ArchAddrWidth arch)) (BlockDemands (ArchReg arch))
    -> Const
         (BlockDemands (ArchReg arch))
         (Map
            (MemSegmentOff (ArchAddrWidth arch))
            (BlockDemands (ArchReg arch))))
-> Getting
     (BlockDemands (ArchReg arch))
     (FunctionArgsState arch ids)
     (BlockDemands (ArchReg arch))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index
  (Map
     (MemSegmentOff (ArchAddrWidth arch)) (BlockDemands (ArchReg arch)))
-> Traversal'
     (Map
        (MemSegmentOff (ArchAddrWidth arch)) (BlockDemands (ArchReg arch)))
     (IxValue
        (Map
           (MemSegmentOff (ArchAddrWidth arch))
           (BlockDemands (ArchReg arch))))
forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Index
  (Map
     (MemSegmentOff (ArchAddrWidth arch)) (BlockDemands (ArchReg arch)))
MemSegmentOff (ArchAddrWidth arch)
predAddr)

  Map (DemandType (ArchReg arch)) (DemandSet (ArchReg arch))
demands' <- (DemandSet (ArchReg arch)
 -> StateT
      (FunctionArgsState arch ids)
      (ReaderT
         (FunArgContext arch)
         (Except (FunctionArgAnalysisFailure (ArchAddrWidth arch))))
      (DemandSet (ArchReg arch)))
-> Map (DemandType (ArchReg arch)) (DemandSet (ArchReg arch))
-> StateT
     (FunctionArgsState arch ids)
     (ReaderT
        (FunArgContext arch)
        (Except (FunctionArgAnalysisFailure (ArchAddrWidth arch))))
     (Map (DemandType (ArchReg arch)) (DemandSet (ArchReg arch)))
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 (DemandType (ArchReg arch)) a
-> f (Map (DemandType (ArchReg arch)) b)
traverse (FinalRegisterDemands (ArchReg arch)
-> DemandSet (ArchReg arch)
-> StateT
     (FunctionArgsState arch ids)
     (ReaderT
        (FunArgContext arch)
        (Except (FunctionArgAnalysisFailure (ArchAddrWidth arch))))
     (DemandSet (ArchReg arch))
forall arch ids.
(MemWidth (ArchAddrWidth arch), OrdF (ArchReg arch),
 ShowF (ArchReg arch)) =>
FinalRegisterDemands (ArchReg arch)
-> DemandSet (ArchReg arch)
-> FunctionArgsM arch ids (DemandSet (ArchReg arch))
transferDemands FinalRegisterDemands (ArchReg arch)
xfer) Map (DemandType (ArchReg arch)) (DemandSet (ArchReg arch))
newDemands

  let diff :: OrdF r => DemandSet r -> DemandSet r -> Maybe (DemandSet r)
      diff :: forall (r :: Type -> Type).
OrdF r =>
DemandSet r -> DemandSet r -> Maybe (DemandSet r)
diff DemandSet r
ds1 DemandSet r
ds2 | DemandSet r
ds' DemandSet r -> DemandSet r -> Bool
forall a. Eq a => a -> a -> Bool
== DemandSet r
forall a. Monoid a => a
mempty = Maybe (DemandSet r)
forall a. Maybe a
Nothing
                   | Bool
otherwise = DemandSet r -> Maybe (DemandSet r)
forall a. a -> Maybe a
Just DemandSet r
ds'
        where ds' :: DemandSet r
ds' = DemandSet r
ds1 DemandSet r -> DemandSet r -> DemandSet r
forall (r :: Type -> Type).
OrdF r =>
DemandSet r -> DemandSet r -> DemandSet r
`demandSetDifference` DemandSet r
ds2

  let d :: Map (DemandType (ArchReg arch)) (DemandSet (ArchReg arch))
d = (DemandSet (ArchReg arch)
 -> DemandSet (ArchReg arch) -> Maybe (DemandSet (ArchReg arch)))
-> Map (DemandType (ArchReg arch)) (DemandSet (ArchReg arch))
-> Map (DemandType (ArchReg arch)) (DemandSet (ArchReg arch))
-> Map (DemandType (ArchReg arch)) (DemandSet (ArchReg arch))
forall k a b.
Ord k =>
(a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a
Map.differenceWith DemandSet (ArchReg arch)
-> DemandSet (ArchReg arch) -> Maybe (DemandSet (ArchReg arch))
forall (r :: Type -> Type).
OrdF r =>
DemandSet r -> DemandSet r -> Maybe (DemandSet r)
diff Map (DemandType (ArchReg arch)) (DemandSet (ArchReg arch))
demands' Map (DemandType (ArchReg arch)) (DemandSet (ArchReg arch))
seenDemands

  -- If no new entries are seen, then just return pendingMap
  if Map (DemandType (ArchReg arch)) (DemandSet (ArchReg arch)) -> Bool
forall k a. Map k a -> Bool
Map.null Map (DemandType (ArchReg arch)) (DemandSet (ArchReg arch))
d then
    Map
  (MemSegmentOff (ArchAddrWidth arch)) (BlockDemands (ArchReg arch))
-> FunctionArgsM
     arch
     ids
     (Map
        (MemSegmentOff (ArchAddrWidth arch)) (BlockDemands (ArchReg arch)))
forall a.
a
-> StateT
     (FunctionArgsState arch ids)
     (ReaderT
        (FunArgContext arch)
        (Except (FunctionArgAnalysisFailure (ArchAddrWidth arch))))
     a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Map
   (MemSegmentOff (ArchAddrWidth arch)) (BlockDemands (ArchReg arch))
 -> FunctionArgsM
      arch
      ids
      (Map
         (MemSegmentOff (ArchAddrWidth arch))
         (BlockDemands (ArchReg arch))))
-> Map
     (MemSegmentOff (ArchAddrWidth arch)) (BlockDemands (ArchReg arch))
-> FunctionArgsM
     arch
     ids
     (Map
        (MemSegmentOff (ArchAddrWidth arch)) (BlockDemands (ArchReg arch)))
forall a b. (a -> b) -> a -> b
$! Map
  (MemSegmentOff (ArchAddrWidth arch)) (BlockDemands (ArchReg arch))
pendingMap
   else do
    (Map
   (MemSegmentOff (ArchAddrWidth arch)) (BlockDemands (ArchReg arch))
 -> Identity
      (Map
         (MemSegmentOff (ArchAddrWidth arch))
         (BlockDemands (ArchReg arch))))
-> FunctionArgsState arch ids
-> Identity (FunctionArgsState arch ids)
forall arch ids (f :: Type -> Type).
Functor f =>
(Map (ArchSegmentOff arch) (BlockDemands (ArchReg arch))
 -> f (Map (ArchSegmentOff arch) (BlockDemands (ArchReg arch))))
-> FunctionArgsState arch ids -> f (FunctionArgsState arch ids)
blockDemandMap ((Map
    (MemSegmentOff (ArchAddrWidth arch)) (BlockDemands (ArchReg arch))
  -> Identity
       (Map
          (MemSegmentOff (ArchAddrWidth arch))
          (BlockDemands (ArchReg arch))))
 -> FunctionArgsState arch ids
 -> Identity (FunctionArgsState arch ids))
-> (Map
      (MemSegmentOff (ArchAddrWidth arch)) (BlockDemands (ArchReg arch))
    -> Map
         (MemSegmentOff (ArchAddrWidth arch)) (BlockDemands (ArchReg arch)))
-> StateT
     (FunctionArgsState arch ids)
     (ReaderT
        (FunArgContext arch)
        (Except (FunctionArgAnalysisFailure (ArchAddrWidth arch))))
     ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= MemSegmentOff (ArchAddrWidth arch)
-> BlockDemands (ArchReg arch)
-> Map
     (MemSegmentOff (ArchAddrWidth arch)) (BlockDemands (ArchReg arch))
-> Map
     (MemSegmentOff (ArchAddrWidth arch)) (BlockDemands (ArchReg arch))
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert MemSegmentOff (ArchAddrWidth arch)
predAddr (BlockDemands (ArchReg arch)
-> BlockDemands (ArchReg arch) -> BlockDemands (ArchReg arch)
forall (r :: Type -> Type).
OrdF r =>
BlockDemands r -> BlockDemands r -> BlockDemands r
unionBlockDemands (Map (DemandType (ArchReg arch)) (DemandSet (ArchReg arch))
-> BlockDemands (ArchReg arch)
forall (r :: Type -> Type).
Map (DemandType r) (DemandSet r) -> BlockDemands r
BD Map (DemandType (ArchReg arch)) (DemandSet (ArchReg arch))
seenDemands) (Map (DemandType (ArchReg arch)) (DemandSet (ArchReg arch))
-> BlockDemands (ArchReg arch)
forall (r :: Type -> Type).
Map (DemandType r) (DemandSet r) -> BlockDemands r
BD Map (DemandType (ArchReg arch)) (DemandSet (ArchReg arch))
demands'))
    Map
  (MemSegmentOff (ArchAddrWidth arch)) (BlockDemands (ArchReg arch))
-> FunctionArgsM
     arch
     ids
     (Map
        (MemSegmentOff (ArchAddrWidth arch)) (BlockDemands (ArchReg arch)))
forall a.
a
-> StateT
     (FunctionArgsState arch ids)
     (ReaderT
        (FunArgContext arch)
        (Except (FunctionArgAnalysisFailure (ArchAddrWidth arch))))
     a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Map
   (MemSegmentOff (ArchAddrWidth arch)) (BlockDemands (ArchReg arch))
 -> FunctionArgsM
      arch
      ids
      (Map
         (MemSegmentOff (ArchAddrWidth arch))
         (BlockDemands (ArchReg arch))))
-> Map
     (MemSegmentOff (ArchAddrWidth arch)) (BlockDemands (ArchReg arch))
-> FunctionArgsM
     arch
     ids
     (Map
        (MemSegmentOff (ArchAddrWidth arch)) (BlockDemands (ArchReg arch)))
forall a b. (a -> b) -> a -> b
$! (BlockDemands (ArchReg arch)
 -> BlockDemands (ArchReg arch) -> BlockDemands (ArchReg arch))
-> MemSegmentOff (ArchAddrWidth arch)
-> BlockDemands (ArchReg arch)
-> Map
     (MemSegmentOff (ArchAddrWidth arch)) (BlockDemands (ArchReg arch))
-> Map
     (MemSegmentOff (ArchAddrWidth arch)) (BlockDemands (ArchReg arch))
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith BlockDemands (ArchReg arch)
-> BlockDemands (ArchReg arch) -> BlockDemands (ArchReg arch)
forall (r :: Type -> Type).
OrdF r =>
BlockDemands r -> BlockDemands r -> BlockDemands r
unionBlockDemands MemSegmentOff (ArchAddrWidth arch)
predAddr (Map (DemandType (ArchReg arch)) (DemandSet (ArchReg arch))
-> BlockDemands (ArchReg arch)
forall (r :: Type -> Type).
Map (DemandType r) (DemandSet r) -> BlockDemands r
BD Map (DemandType (ArchReg arch)) (DemandSet (ArchReg arch))
d) Map
  (MemSegmentOff (ArchAddrWidth arch)) (BlockDemands (ArchReg arch))
pendingMap

-- | This back-propagates demands sets from blocks to their
-- predecessors until we each a fixpoint.
calculateLocalFixpoint :: forall arch ids
                       .  ( MemWidth (ArchAddrWidth arch)
                          , OrdF (ArchReg arch)
                          , ShowF (ArchReg arch)
                          )
                       => PredBlockMap arch
                          -- ^ Predecessor block map for function.
                       -> Map (ArchSegmentOff arch) (FinalRegisterDemands (ArchReg arch))
                       -> Map (ArchSegmentOff arch) (BlockDemands (ArchReg arch))
                          -- ^ Maps each block starting address to demands that
                          -- have not yet been back propagated.
                       -> FunctionArgsM arch ids ()
calculateLocalFixpoint :: forall arch ids.
(MemWidth (ArchAddrWidth arch), OrdF (ArchReg arch),
 ShowF (ArchReg arch)) =>
PredBlockMap arch
-> Map (ArchSegmentOff arch) (FinalRegisterDemands (ArchReg arch))
-> Map (ArchSegmentOff arch) (BlockDemands (ArchReg arch))
-> FunctionArgsM arch ids ()
calculateLocalFixpoint Map
  (MemSegmentOff (ArchAddrWidth arch))
  [MemSegmentOff (ArchAddrWidth arch)]
predMap Map
  (MemSegmentOff (ArchAddrWidth arch))
  (FinalRegisterDemands (ArchReg arch))
xferMap Map
  (MemSegmentOff (ArchAddrWidth arch)) (BlockDemands (ArchReg arch))
new =
   case Map
  (MemSegmentOff (ArchAddrWidth arch)) (BlockDemands (ArchReg arch))
-> Maybe
     ((MemSegmentOff (ArchAddrWidth arch), BlockDemands (ArchReg arch)),
      Map
        (MemSegmentOff (ArchAddrWidth arch)) (BlockDemands (ArchReg arch)))
forall k a. Map k a -> Maybe ((k, a), Map k a)
Map.maxViewWithKey Map
  (MemSegmentOff (ArchAddrWidth arch)) (BlockDemands (ArchReg arch))
new of
     Maybe
  ((MemSegmentOff (ArchAddrWidth arch), BlockDemands (ArchReg arch)),
   Map
     (MemSegmentOff (ArchAddrWidth arch)) (BlockDemands (ArchReg arch)))
Nothing -> () -> FunctionArgsM arch ids ()
forall a.
a
-> StateT
     (FunctionArgsState arch ids)
     (ReaderT
        (FunArgContext arch)
        (Except (FunctionArgAnalysisFailure (ArchAddrWidth arch))))
     a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ()
     Just ((MemSegmentOff (ArchAddrWidth arch)
currAddr, BlockDemands (ArchReg arch)
newDemands), Map
  (MemSegmentOff (ArchAddrWidth arch)) (BlockDemands (ArchReg arch))
rest) -> do
       -- propagate new demands bacl to predecessors of this block.
       Map
  (MemSegmentOff (ArchAddrWidth arch)) (BlockDemands (ArchReg arch))
next <- (Map
   (MemSegmentOff (ArchAddrWidth arch)) (BlockDemands (ArchReg arch))
 -> MemSegmentOff (ArchAddrWidth arch)
 -> StateT
      (FunctionArgsState arch ids)
      (ReaderT
         (FunArgContext arch)
         (Except (FunctionArgAnalysisFailure (ArchAddrWidth arch))))
      (Map
         (MemSegmentOff (ArchAddrWidth arch))
         (BlockDemands (ArchReg arch))))
-> Map
     (MemSegmentOff (ArchAddrWidth arch)) (BlockDemands (ArchReg arch))
-> [MemSegmentOff (ArchAddrWidth arch)]
-> StateT
     (FunctionArgsState arch ids)
     (ReaderT
        (FunArgContext arch)
        (Except (FunctionArgAnalysisFailure (ArchAddrWidth arch))))
     (Map
        (MemSegmentOff (ArchAddrWidth arch)) (BlockDemands (ArchReg arch)))
forall (t :: Type -> Type) (m :: Type -> Type) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM (Map
  (MemSegmentOff (ArchAddrWidth arch))
  (FinalRegisterDemands (ArchReg arch))
-> BlockDemands (ArchReg arch)
-> Map
     (MemSegmentOff (ArchAddrWidth arch)) (BlockDemands (ArchReg arch))
-> MemSegmentOff (ArchAddrWidth arch)
-> StateT
     (FunctionArgsState arch ids)
     (ReaderT
        (FunArgContext arch)
        (Except (FunctionArgAnalysisFailure (ArchAddrWidth arch))))
     (Map
        (MemSegmentOff (ArchAddrWidth arch)) (BlockDemands (ArchReg arch)))
forall arch ids.
(MemWidth (ArchAddrWidth arch), OrdF (ArchReg arch),
 ShowF (ArchReg arch)) =>
Map (ArchSegmentOff arch) (FinalRegisterDemands (ArchReg arch))
-> BlockDemands (ArchReg arch)
-> Map (ArchSegmentOff arch) (BlockDemands (ArchReg arch))
-> ArchSegmentOff arch
-> FunctionArgsM
     arch ids (Map (ArchSegmentOff arch) (BlockDemands (ArchReg arch)))
calculateOnePred Map
  (MemSegmentOff (ArchAddrWidth arch))
  (FinalRegisterDemands (ArchReg arch))
xferMap BlockDemands (ArchReg arch)
newDemands) Map
  (MemSegmentOff (ArchAddrWidth arch)) (BlockDemands (ArchReg arch))
rest (Map
  (MemSegmentOff (ArchAddrWidth arch))
  [MemSegmentOff (ArchAddrWidth arch)]
predMapMap
  (MemSegmentOff (ArchAddrWidth arch))
  [MemSegmentOff (ArchAddrWidth arch)]
-> Getting
     [MemSegmentOff (ArchAddrWidth arch)]
     (Map
        (MemSegmentOff (ArchAddrWidth arch))
        [MemSegmentOff (ArchAddrWidth arch)])
     [MemSegmentOff (ArchAddrWidth arch)]
-> [MemSegmentOff (ArchAddrWidth arch)]
forall s a. s -> Getting a s a -> a
^.Index
  (Map
     (MemSegmentOff (ArchAddrWidth arch))
     [MemSegmentOff (ArchAddrWidth arch)])
-> Traversal'
     (Map
        (MemSegmentOff (ArchAddrWidth arch))
        [MemSegmentOff (ArchAddrWidth arch)])
     (IxValue
        (Map
           (MemSegmentOff (ArchAddrWidth arch))
           [MemSegmentOff (ArchAddrWidth arch)]))
forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Index
  (Map
     (MemSegmentOff (ArchAddrWidth arch))
     [MemSegmentOff (ArchAddrWidth arch)])
MemSegmentOff (ArchAddrWidth arch)
currAddr)
       Map
  (MemSegmentOff (ArchAddrWidth arch))
  [MemSegmentOff (ArchAddrWidth arch)]
-> Map
     (MemSegmentOff (ArchAddrWidth arch))
     (FinalRegisterDemands (ArchReg arch))
-> Map
     (MemSegmentOff (ArchAddrWidth arch)) (BlockDemands (ArchReg arch))
-> FunctionArgsM arch ids ()
forall arch ids.
(MemWidth (ArchAddrWidth arch), OrdF (ArchReg arch),
 ShowF (ArchReg arch)) =>
PredBlockMap arch
-> Map (ArchSegmentOff arch) (FinalRegisterDemands (ArchReg arch))
-> Map (ArchSegmentOff arch) (BlockDemands (ArchReg arch))
-> FunctionArgsM arch ids ()
calculateLocalFixpoint Map
  (MemSegmentOff (ArchAddrWidth arch))
  [MemSegmentOff (ArchAddrWidth arch)]
predMap Map
  (MemSegmentOff (ArchAddrWidth arch))
  (FinalRegisterDemands (ArchReg arch))
xferMap Map
  (MemSegmentOff (ArchAddrWidth arch)) (BlockDemands (ArchReg arch))
next

-- | Map function entry points that fail to reasons why we could not infer arguments.
type FunctionSummaryFailureMap r = Map (RegSegmentOff r) (FunctionArgAnalysisFailure (RegAddrWidth r))

-- | Intermediate information used to infer global demands.
data FunctionSummaries r = FunctionSummaries {
    forall (r :: Type -> Type). FunctionSummaries r -> ArgDemandsMap r
_funArgMap       :: !(ArgDemandsMap r)
  , forall (r :: Type -> Type).
FunctionSummaries r
-> Map (RegSegmentOff r) (FinalRegisterDemands r)
_funResMap       :: !(Map (RegSegmentOff r) (FinalRegisterDemands r))
  , forall (r :: Type -> Type).
FunctionSummaries r -> Map (RegSegmentOff r) (DemandSet r)
_alwaysDemandMap :: !(Map (RegSegmentOff r) (DemandSet r))
    -- | Map from function starting addresses to reason why initial argument analysis failed.
  , forall (r :: Type -> Type).
FunctionSummaries r -> FunctionSummaryFailureMap r
inferenceFails   :: !(FunctionSummaryFailureMap r)
  }

funArgMap :: Simple Lens (FunctionSummaries r) (ArgDemandsMap r)
funArgMap :: forall (r :: Type -> Type) (f :: Type -> Type).
Functor f =>
(ArgDemandsMap r -> f (ArgDemandsMap r))
-> FunctionSummaries r -> f (FunctionSummaries r)
funArgMap = (FunctionSummaries r
 -> Map
      (MemSegmentOff (RegAddrWidth r), Some r)
      (Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r)))
-> (FunctionSummaries r
    -> Map
         (MemSegmentOff (RegAddrWidth r), Some r)
         (Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r))
    -> FunctionSummaries r)
-> Lens
     (FunctionSummaries r)
     (FunctionSummaries r)
     (Map
        (MemSegmentOff (RegAddrWidth r), Some r)
        (Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r)))
     (Map
        (MemSegmentOff (RegAddrWidth r), Some r)
        (Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r)))
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens FunctionSummaries r
-> Map
     (MemSegmentOff (RegAddrWidth r), Some r)
     (Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r))
forall (r :: Type -> Type). FunctionSummaries r -> ArgDemandsMap r
_funArgMap (\FunctionSummaries r
s Map
  (MemSegmentOff (RegAddrWidth r), Some r)
  (Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r))
v -> FunctionSummaries r
s { _funArgMap = v })

-- | Get the map from function addresses to what results are demanded.
funResMap :: Simple Lens (FunctionSummaries r) (Map (RegSegmentOff r) (FinalRegisterDemands r))
funResMap :: forall (r :: Type -> Type) (f :: Type -> Type).
Functor f =>
(Map (RegSegmentOff r) (FinalRegisterDemands r)
 -> f (Map (RegSegmentOff r) (FinalRegisterDemands r)))
-> FunctionSummaries r -> f (FunctionSummaries r)
funResMap = (FunctionSummaries r
 -> Map (MemSegmentOff (RegAddrWidth r)) (FinalRegisterDemands r))
-> (FunctionSummaries r
    -> Map (MemSegmentOff (RegAddrWidth r)) (FinalRegisterDemands r)
    -> FunctionSummaries r)
-> Lens
     (FunctionSummaries r)
     (FunctionSummaries r)
     (Map (MemSegmentOff (RegAddrWidth r)) (FinalRegisterDemands r))
     (Map (MemSegmentOff (RegAddrWidth r)) (FinalRegisterDemands r))
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens FunctionSummaries r
-> Map (MemSegmentOff (RegAddrWidth r)) (FinalRegisterDemands r)
forall (r :: Type -> Type).
FunctionSummaries r
-> Map (RegSegmentOff r) (FinalRegisterDemands r)
_funResMap (\FunctionSummaries r
s Map (MemSegmentOff (RegAddrWidth r)) (FinalRegisterDemands r)
v -> FunctionSummaries r
s { _funResMap = v })

-- | Get the map from function adderesses to what results are demanded.
alwaysDemandMap :: Simple Lens (FunctionSummaries r) (Map (RegSegmentOff r)  (DemandSet r))
alwaysDemandMap :: forall (r :: Type -> Type) (f :: Type -> Type).
Functor f =>
(Map (RegSegmentOff r) (DemandSet r)
 -> f (Map (RegSegmentOff r) (DemandSet r)))
-> FunctionSummaries r -> f (FunctionSummaries r)
alwaysDemandMap = (FunctionSummaries r
 -> Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r))
-> (FunctionSummaries r
    -> Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r)
    -> FunctionSummaries r)
-> Lens
     (FunctionSummaries r)
     (FunctionSummaries r)
     (Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r))
     (Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r))
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens FunctionSummaries r
-> Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r)
forall (r :: Type -> Type).
FunctionSummaries r -> Map (RegSegmentOff r) (DemandSet r)
_alwaysDemandMap (\FunctionSummaries r
s Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r)
v -> FunctionSummaries r
s { _alwaysDemandMap = v })

decomposeMap :: OrdF r
             => RegisterSet r
                -- ^ Registers to exclude from always demandMap because the
                -- function ABI guarantees they are only read so that the callee
                -- can prserve their value.
             -> RegSegmentOff r -- ^ Address of this function.
             -> FunctionSummaries r
                -- ^ Current global maps from function addresses to their demands.
             -> DemandType r
             -> DemandSet r
             -> FunctionSummaries r
decomposeMap :: forall (r :: Type -> Type).
OrdF r =>
RegisterSet r
-> RegSegmentOff r
-> FunctionSummaries r
-> DemandType r
-> DemandSet r
-> FunctionSummaries r
decomposeMap RegisterSet r
_ MemSegmentOff (RegAddrWidth r)
addr FunctionSummaries r
acc (DemandFunctionArg MemSegmentOff (RegAddrWidth r)
f r tp
r) DemandSet r
v =
  -- Record that if the function @f@ needs register @r@ initialized, then function @addr@
  -- demands @v@.
  FunctionSummaries r
acc FunctionSummaries r
-> (FunctionSummaries r -> FunctionSummaries r)
-> FunctionSummaries r
forall a b. a -> (a -> b) -> b
& (ArgDemandsMap r -> Identity (ArgDemandsMap r))
-> FunctionSummaries r -> Identity (FunctionSummaries r)
forall (r :: Type -> Type) (f :: Type -> Type).
Functor f =>
(ArgDemandsMap r -> f (ArgDemandsMap r))
-> FunctionSummaries r -> f (FunctionSummaries r)
funArgMap ((ArgDemandsMap r -> Identity (ArgDemandsMap r))
 -> FunctionSummaries r -> Identity (FunctionSummaries r))
-> (ArgDemandsMap r -> ArgDemandsMap r)
-> FunctionSummaries r
-> FunctionSummaries r
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r)
 -> Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r)
 -> Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r))
-> (MemSegmentOff (RegAddrWidth r), Some r)
-> Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r)
-> ArgDemandsMap r
-> ArgDemandsMap r
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith ((DemandSet r -> DemandSet r -> DemandSet r)
-> Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r)
-> Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r)
-> Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r)
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith DemandSet r -> DemandSet r -> DemandSet r
forall a. Monoid a => a -> a -> a
mappend) (MemSegmentOff (RegAddrWidth r)
f, r tp -> Some r
forall k (f :: k -> Type) (x :: k). f x -> Some f
Some r tp
r) (MemSegmentOff (RegAddrWidth r)
-> DemandSet r
-> Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r)
forall k a. k -> a -> Map k a
Map.singleton MemSegmentOff (RegAddrWidth r)
addr DemandSet r
v)
decomposeMap RegisterSet r
_ MemSegmentOff (RegAddrWidth r)
addr FunctionSummaries r
acc (DemandFunctionResult r tp
r) DemandSet r
v =
  FunctionSummaries r
acc FunctionSummaries r
-> (FunctionSummaries r -> FunctionSummaries r)
-> FunctionSummaries r
forall a b. a -> (a -> b) -> b
& (Map (MemSegmentOff (RegAddrWidth r)) (FinalRegisterDemands r)
 -> Identity
      (Map (MemSegmentOff (RegAddrWidth r)) (FinalRegisterDemands r)))
-> FunctionSummaries r -> Identity (FunctionSummaries r)
forall (r :: Type -> Type) (f :: Type -> Type).
Functor f =>
(Map (RegSegmentOff r) (FinalRegisterDemands r)
 -> f (Map (RegSegmentOff r) (FinalRegisterDemands r)))
-> FunctionSummaries r -> f (FunctionSummaries r)
funResMap ((Map (MemSegmentOff (RegAddrWidth r)) (FinalRegisterDemands r)
  -> Identity
       (Map (MemSegmentOff (RegAddrWidth r)) (FinalRegisterDemands r)))
 -> FunctionSummaries r -> Identity (FunctionSummaries r))
-> (Map (MemSegmentOff (RegAddrWidth r)) (FinalRegisterDemands r)
    -> Map (MemSegmentOff (RegAddrWidth r)) (FinalRegisterDemands r))
-> FunctionSummaries r
-> FunctionSummaries r
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (FinalRegisterDemands r
 -> FinalRegisterDemands r -> FinalRegisterDemands r)
-> MemSegmentOff (RegAddrWidth r)
-> FinalRegisterDemands r
-> Map (MemSegmentOff (RegAddrWidth r)) (FinalRegisterDemands r)
-> Map (MemSegmentOff (RegAddrWidth r)) (FinalRegisterDemands r)
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith FinalRegisterDemands r
-> FinalRegisterDemands r -> FinalRegisterDemands r
forall a. Monoid a => a -> a -> a
mappend MemSegmentOff (RegAddrWidth r)
addr (Map (Some r) (DemandSet r) -> FinalRegisterDemands r
forall (r :: Type -> Type).
Map (Some r) (DemandSet r) -> FinalRegisterDemands r
FRD (Some r -> DemandSet r -> Map (Some r) (DemandSet r)
forall k a. k -> a -> Map k a
Map.singleton (r tp -> Some r
forall k (f :: k -> Type) (x :: k). f x -> Some f
Some r tp
r) DemandSet r
v))
-- Strip out callee saved registers as well.
decomposeMap RegisterSet r
ds MemSegmentOff (RegAddrWidth r)
addr FunctionSummaries r
acc DemandType r
DemandAlways DemandSet r
v =
  let v' :: DemandSet r
v' = DemandSet r
v { registerDemands = registerDemands v `Set.difference` ds }
   in FunctionSummaries r
acc FunctionSummaries r
-> (FunctionSummaries r -> FunctionSummaries r)
-> FunctionSummaries r
forall a b. a -> (a -> b) -> b
& (Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r)
 -> Identity (Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r)))
-> FunctionSummaries r -> Identity (FunctionSummaries r)
forall (r :: Type -> Type) (f :: Type -> Type).
Functor f =>
(Map (RegSegmentOff r) (DemandSet r)
 -> f (Map (RegSegmentOff r) (DemandSet r)))
-> FunctionSummaries r -> f (FunctionSummaries r)
alwaysDemandMap ((Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r)
  -> Identity (Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r)))
 -> FunctionSummaries r -> Identity (FunctionSummaries r))
-> (Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r)
    -> Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r))
-> FunctionSummaries r
-> FunctionSummaries r
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (DemandSet r -> DemandSet r -> DemandSet r)
-> MemSegmentOff (RegAddrWidth r)
-> DemandSet r
-> Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r)
-> Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r)
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith DemandSet r -> DemandSet r -> DemandSet r
forall a. Monoid a => a -> a -> a
mappend MemSegmentOff (RegAddrWidth r)
addr DemandSet r
v'

-- | This records the registers a function demands in the global state after
-- being inferred from definition.
recordInferredFunctionDemands :: ArchConstraints arch
                              => ArchDemandInfo arch
                                 -- ^ Contextual information about architecture
                              -> ArchSegmentOff arch
                              -- ^ Function address
                              -> BlockDemands (ArchReg arch)
                              -- ^ Demands of the initial entry block for
                              -- the function after propagation.
                              -> FunctionSummaries (ArchReg arch)
                                 -- ^ Current global state for functions
                              -> FunctionSummaries (ArchReg arch)
recordInferredFunctionDemands :: forall arch.
ArchConstraints arch =>
ArchDemandInfo arch
-> ArchSegmentOff arch
-> BlockDemands (ArchReg arch)
-> FunctionSummaries (ArchReg arch)
-> FunctionSummaries (ArchReg arch)
recordInferredFunctionDemands ArchDemandInfo arch
ainfo ArchSegmentOff arch
fnAddr (BD Map (DemandType (ArchReg arch)) (DemandSet (ArchReg arch))
fnDemands) FunctionSummaries (ArchReg arch)
globalState =
    -- A function may demand on callee saved register only because
    -- it will store them for use later.  We drop these and the
    -- stack pointer as a demand.
  let spuriousDemands :: Set (Some (ArchReg arch))
spuriousDemands = Some (ArchReg arch)
-> Set (Some (ArchReg arch)) -> Set (Some (ArchReg arch))
forall a. Ord a => a -> Set a -> Set a
Set.insert (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) (ArchDemandInfo arch -> Set (Some (ArchReg arch))
forall arch. ArchDemandInfo arch -> Set (Some (ArchReg arch))
calleeSavedRegs ArchDemandInfo arch
ainfo)
   in (FunctionSummaries (ArchReg arch)
 -> DemandType (ArchReg arch)
 -> DemandSet (ArchReg arch)
 -> FunctionSummaries (ArchReg arch))
-> FunctionSummaries (ArchReg arch)
-> Map (DemandType (ArchReg arch)) (DemandSet (ArchReg arch))
-> FunctionSummaries (ArchReg arch)
forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
Map.foldlWithKey' (Set (Some (ArchReg arch))
-> ArchSegmentOff arch
-> FunctionSummaries (ArchReg arch)
-> DemandType (ArchReg arch)
-> DemandSet (ArchReg arch)
-> FunctionSummaries (ArchReg arch)
forall (r :: Type -> Type).
OrdF r =>
RegisterSet r
-> RegSegmentOff r
-> FunctionSummaries r
-> DemandType r
-> DemandSet r
-> FunctionSummaries r
decomposeMap Set (Some (ArchReg arch))
spuriousDemands ArchSegmentOff arch
fnAddr) FunctionSummaries (ArchReg arch)
globalState Map (DemandType (ArchReg arch)) (DemandSet (ArchReg arch))
fnDemands

-- This function computes the following 3 pieces of information:
-- 1. Initial function arguments (ignoring function calls)
-- 2. Function arguments to function arguments
-- 3. Function results to function arguments.
summarizeFunction :: forall arch
              .  ArchConstraints arch
              => FunArgContext arch
              -> FunctionSummaries (ArchReg arch)
                 -- ^ Current function args stat
              -> Some (DiscoveryFunInfo arch)
              -> FunctionSummaries (ArchReg arch)
summarizeFunction :: forall arch.
ArchConstraints arch =>
FunArgContext arch
-> FunctionSummaries (ArchReg arch)
-> Some (DiscoveryFunInfo arch)
-> FunctionSummaries (ArchReg arch)
summarizeFunction FunArgContext arch
ctx FunctionSummaries (ArchReg arch)
acc (Some DiscoveryFunInfo arch x
finfo) = do
  let addr :: MemSegmentOff (RegAddrWidth (ArchReg arch))
addr = DiscoveryFunInfo arch x
-> MemSegmentOff (RegAddrWidth (ArchReg arch))
forall arch ids. DiscoveryFunInfo arch ids -> ArchSegmentOff arch
discoveredFunAddr DiscoveryFunInfo arch x
finfo
  FunArgContext arch
-> FunctionSummaries (ArchReg arch)
-> MemSegmentOff (RegAddrWidth (ArchReg arch))
-> FunctionArgsM arch x (FunctionSummaries (ArchReg arch))
-> FunctionSummaries (ArchReg arch)
forall arch ids.
FunArgContext arch
-> FunctionSummaries (ArchReg arch)
-> ArchSegmentOff arch
-> FunctionArgsM arch ids (FunctionSummaries (ArchReg arch))
-> FunctionSummaries (ArchReg arch)
evalFunctionArgsM FunArgContext arch
ctx FunctionSummaries (ArchReg arch)
acc MemSegmentOff (RegAddrWidth (ArchReg arch))
addr (FunctionArgsM arch x (FunctionSummaries (ArchReg arch))
 -> FunctionSummaries (ArchReg arch))
-> FunctionArgsM arch x (FunctionSummaries (ArchReg arch))
-> FunctionSummaries (ArchReg arch)
forall a b. (a -> b) -> a -> b
$ do
    -- Summarize blocks
    Map
  (MemSegmentOff (RegAddrWidth (ArchReg arch)))
  (FinalRegisterDemands (ArchReg arch))
xferMap <- (ParsedBlock arch x
 -> StateT
      (FunctionArgsState arch x)
      (ReaderT
         (FunArgContext arch)
         (Except
            (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
      (FinalRegisterDemands (ArchReg arch)))
-> Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch))) (ParsedBlock arch x)
-> StateT
     (FunctionArgsState arch x)
     (ReaderT
        (FunArgContext arch)
        (Except
           (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
     (Map
        (MemSegmentOff (RegAddrWidth (ArchReg arch)))
        (FinalRegisterDemands (ArchReg arch)))
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 x
-> StateT
     (FunctionArgsState arch x)
     (ReaderT
        (FunArgContext arch)
        (Except
           (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
     (FinalRegisterDemands (ArchReg arch))
forall arch ids.
ArchConstraints arch =>
ParsedBlock arch ids
-> FunctionArgsM arch ids (FinalRegisterDemands (ArchReg arch))
summarizeBlock (DiscoveryFunInfo arch x
finfoDiscoveryFunInfo arch x
-> Getting
     (Map
        (MemSegmentOff (RegAddrWidth (ArchReg arch))) (ParsedBlock arch x))
     (DiscoveryFunInfo arch x)
     (Map
        (MemSegmentOff (RegAddrWidth (ArchReg arch))) (ParsedBlock arch x))
-> Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch))) (ParsedBlock arch x)
forall s a. s -> Getting a s a -> a
^.Getting
  (Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch))) (ParsedBlock arch x))
  (DiscoveryFunInfo arch x)
  (Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch))) (ParsedBlock arch x))
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)
    -- Propagate block demands until we are done.
    Map
  (MemSegmentOff (RegAddrWidth (ArchReg arch)))
  (BlockDemands (ArchReg arch))
new <- Getting
  (Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (BlockDemands (ArchReg arch)))
  (FunctionArgsState arch x)
  (Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (BlockDemands (ArchReg arch)))
-> StateT
     (FunctionArgsState arch x)
     (ReaderT
        (FunArgContext arch)
        (Except
           (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
     (Map
        (MemSegmentOff (RegAddrWidth (ArchReg arch)))
        (BlockDemands (ArchReg arch)))
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
use Getting
  (Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (BlockDemands (ArchReg arch)))
  (FunctionArgsState arch x)
  (Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (BlockDemands (ArchReg arch)))
forall arch ids (f :: Type -> Type).
Functor f =>
(Map (ArchSegmentOff arch) (BlockDemands (ArchReg arch))
 -> f (Map (ArchSegmentOff arch) (BlockDemands (ArchReg arch))))
-> FunctionArgsState arch ids -> f (FunctionArgsState arch ids)
blockDemandMap
    PredBlockMap arch
-> Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (FinalRegisterDemands (ArchReg arch))
-> Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (BlockDemands (ArchReg arch))
-> StateT
     (FunctionArgsState arch x)
     (ReaderT
        (FunArgContext arch)
        (Except
           (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
     ()
forall arch ids.
(MemWidth (ArchAddrWidth arch), OrdF (ArchReg arch),
 ShowF (ArchReg arch)) =>
PredBlockMap arch
-> Map (ArchSegmentOff arch) (FinalRegisterDemands (ArchReg arch))
-> Map (ArchSegmentOff arch) (BlockDemands (ArchReg arch))
-> FunctionArgsM arch ids ()
calculateLocalFixpoint (DiscoveryFunInfo arch x -> PredBlockMap arch
forall arch ids. DiscoveryFunInfo arch ids -> PredBlockMap arch
predBlockMap DiscoveryFunInfo arch x
finfo) Map
  (MemSegmentOff (RegAddrWidth (ArchReg arch)))
  (FinalRegisterDemands (ArchReg arch))
xferMap Map
  (MemSegmentOff (RegAddrWidth (ArchReg arch)))
  (BlockDemands (ArchReg arch))
new
    -- Get registers demanded by initial block map.
    BlockDemands (ArchReg arch)
entryDemands <- Getting
  (BlockDemands (ArchReg arch))
  (FunctionArgsState arch x)
  (BlockDemands (ArchReg arch))
-> StateT
     (FunctionArgsState arch x)
     (ReaderT
        (FunArgContext arch)
        (Except
           (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
     (BlockDemands (ArchReg arch))
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
use (Getting
   (BlockDemands (ArchReg arch))
   (FunctionArgsState arch x)
   (BlockDemands (ArchReg arch))
 -> StateT
      (FunctionArgsState arch x)
      (ReaderT
         (FunArgContext arch)
         (Except
            (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
      (BlockDemands (ArchReg arch)))
-> Getting
     (BlockDemands (ArchReg arch))
     (FunctionArgsState arch x)
     (BlockDemands (ArchReg arch))
-> StateT
     (FunctionArgsState arch x)
     (ReaderT
        (FunArgContext arch)
        (Except
           (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
     (BlockDemands (ArchReg arch))
forall a b. (a -> b) -> a -> b
$ (Map
   (MemSegmentOff (RegAddrWidth (ArchReg arch)))
   (BlockDemands (ArchReg arch))
 -> Const
      (BlockDemands (ArchReg arch))
      (Map
         (MemSegmentOff (RegAddrWidth (ArchReg arch)))
         (BlockDemands (ArchReg arch))))
-> FunctionArgsState arch x
-> Const (BlockDemands (ArchReg arch)) (FunctionArgsState arch x)
forall arch ids (f :: Type -> Type).
Functor f =>
(Map (ArchSegmentOff arch) (BlockDemands (ArchReg arch))
 -> f (Map (ArchSegmentOff arch) (BlockDemands (ArchReg arch))))
-> FunctionArgsState arch ids -> f (FunctionArgsState arch ids)
blockDemandMap ((Map
    (MemSegmentOff (RegAddrWidth (ArchReg arch)))
    (BlockDemands (ArchReg arch))
  -> Const
       (BlockDemands (ArchReg arch))
       (Map
          (MemSegmentOff (RegAddrWidth (ArchReg arch)))
          (BlockDemands (ArchReg arch))))
 -> FunctionArgsState arch x
 -> Const (BlockDemands (ArchReg arch)) (FunctionArgsState arch x))
-> ((BlockDemands (ArchReg arch)
     -> Const
          (BlockDemands (ArchReg arch)) (BlockDemands (ArchReg arch)))
    -> Map
         (MemSegmentOff (RegAddrWidth (ArchReg arch)))
         (BlockDemands (ArchReg arch))
    -> Const
         (BlockDemands (ArchReg arch))
         (Map
            (MemSegmentOff (RegAddrWidth (ArchReg arch)))
            (BlockDemands (ArchReg arch))))
-> Getting
     (BlockDemands (ArchReg arch))
     (FunctionArgsState arch x)
     (BlockDemands (ArchReg arch))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index
  (Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (BlockDemands (ArchReg arch)))
-> Traversal'
     (Map
        (MemSegmentOff (RegAddrWidth (ArchReg arch)))
        (BlockDemands (ArchReg arch)))
     (IxValue
        (Map
           (MemSegmentOff (RegAddrWidth (ArchReg arch)))
           (BlockDemands (ArchReg arch))))
forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Index
  (Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (BlockDemands (ArchReg arch)))
MemSegmentOff (RegAddrWidth (ArchReg arch))
addr
    -- Record the demands in this function.
    FunctionSummaries (ArchReg arch)
-> FunctionArgsM arch x (FunctionSummaries (ArchReg arch))
forall a.
a
-> StateT
     (FunctionArgsState arch x)
     (ReaderT
        (FunArgContext arch)
        (Except
           (FunctionArgAnalysisFailure (RegAddrWidth (ArchReg arch)))))
     a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (FunctionSummaries (ArchReg arch)
 -> FunctionArgsM arch x (FunctionSummaries (ArchReg arch)))
-> FunctionSummaries (ArchReg arch)
-> FunctionArgsM arch x (FunctionSummaries (ArchReg arch))
forall a b. (a -> b) -> a -> b
$! ArchDemandInfo arch
-> MemSegmentOff (RegAddrWidth (ArchReg arch))
-> BlockDemands (ArchReg arch)
-> FunctionSummaries (ArchReg arch)
-> FunctionSummaries (ArchReg arch)
forall arch.
ArchConstraints arch =>
ArchDemandInfo arch
-> ArchSegmentOff arch
-> BlockDemands (ArchReg arch)
-> FunctionSummaries (ArchReg arch)
-> FunctionSummaries (ArchReg arch)
recordInferredFunctionDemands (FunArgContext arch -> ArchDemandInfo arch
forall arch. FunArgContext arch -> ArchDemandInfo arch
archDemandInfo FunArgContext arch
ctx) MemSegmentOff (RegAddrWidth (ArchReg arch))
addr BlockDemands (ArchReg arch)
entryDemands FunctionSummaries (ArchReg arch)
acc

-- | Return the demand set for the given registers at the given address.
postRegisterSetDemandsAtAddr :: OrdF r
                             => Map (RegSegmentOff r) (FinalRegisterDemands r)
                             -> RegSegmentOff r
                             -> Set (Some r)
                             -> DemandSet r
postRegisterSetDemandsAtAddr :: forall (r :: Type -> Type).
OrdF r =>
Map (RegSegmentOff r) (FinalRegisterDemands r)
-> RegSegmentOff r -> Set (Some r) -> DemandSet r
postRegisterSetDemandsAtAddr Map (RegSegmentOff r) (FinalRegisterDemands r)
m RegSegmentOff r
addr Set (Some r)
retRegs =
  (Some r -> DemandSet r) -> Set (Some r) -> DemandSet r
forall m a. Monoid m => (a -> m) -> Set a -> m
forall (t :: Type -> Type) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\(Some r x
r) -> FinalRegisterDemands r -> r x -> DemandSet r
forall (r :: Type -> Type) (tp :: Type).
OrdF r =>
FinalRegisterDemands r -> r tp -> DemandSet r
postRegisterDemands (Map (RegSegmentOff r) (FinalRegisterDemands r)
mMap (RegSegmentOff r) (FinalRegisterDemands r)
-> Getting
     (FinalRegisterDemands r)
     (Map (RegSegmentOff r) (FinalRegisterDemands r))
     (FinalRegisterDemands r)
-> FinalRegisterDemands r
forall s a. s -> Getting a s a -> a
^.Index (Map (RegSegmentOff r) (FinalRegisterDemands r))
-> Traversal'
     (Map (RegSegmentOff r) (FinalRegisterDemands r))
     (IxValue (Map (RegSegmentOff r) (FinalRegisterDemands r)))
forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Index (Map (RegSegmentOff r) (FinalRegisterDemands r))
RegSegmentOff r
addr) r x
r) Set (Some r)
retRegs

-- PERF: we can calculate the return types as we go (instead of doing
-- so at the end).
calculateGlobalFixpoint :: forall r
                        .  OrdF r
                        => FunctionSummaries r
                        -> AddrDemandMap r
calculateGlobalFixpoint :: forall (r :: Type -> Type).
OrdF r =>
FunctionSummaries r -> AddrDemandMap r
calculateGlobalFixpoint FunctionSummaries r
s = Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r)
-> Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r)
-> Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r)
go (FunctionSummaries r
sFunctionSummaries r
-> Getting
     (Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r))
     (FunctionSummaries r)
     (Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r))
-> Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r)
forall s a. s -> Getting a s a -> a
^.Getting
  (Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r))
  (FunctionSummaries r)
  (Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r))
forall (r :: Type -> Type) (f :: Type -> Type).
Functor f =>
(Map (RegSegmentOff r) (DemandSet r)
 -> f (Map (RegSegmentOff r) (DemandSet r)))
-> FunctionSummaries r -> f (FunctionSummaries r)
alwaysDemandMap) (FunctionSummaries r
sFunctionSummaries r
-> Getting
     (Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r))
     (FunctionSummaries r)
     (Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r))
-> Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r)
forall s a. s -> Getting a s a -> a
^.Getting
  (Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r))
  (FunctionSummaries r)
  (Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r))
forall (r :: Type -> Type) (f :: Type -> Type).
Functor f =>
(Map (RegSegmentOff r) (DemandSet r)
 -> f (Map (RegSegmentOff r) (DemandSet r)))
-> FunctionSummaries r -> f (FunctionSummaries r)
alwaysDemandMap)
  where
    argDemandsMap :: Map
  (MemSegmentOff (RegAddrWidth r), Some r)
  (Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r))
argDemandsMap = FunctionSummaries r
sFunctionSummaries r
-> Getting
     (Map
        (MemSegmentOff (RegAddrWidth r), Some r)
        (Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r)))
     (FunctionSummaries r)
     (Map
        (MemSegmentOff (RegAddrWidth r), Some r)
        (Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r)))
-> Map
     (MemSegmentOff (RegAddrWidth r), Some r)
     (Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r))
forall s a. s -> Getting a s a -> a
^.Getting
  (Map
     (MemSegmentOff (RegAddrWidth r), Some r)
     (Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r)))
  (FunctionSummaries r)
  (Map
     (MemSegmentOff (RegAddrWidth r), Some r)
     (Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r)))
forall (r :: Type -> Type) (f :: Type -> Type).
Functor f =>
(ArgDemandsMap r -> f (ArgDemandsMap r))
-> FunctionSummaries r -> f (FunctionSummaries r)
funArgMap

    go :: AddrDemandMap r
       -> AddrDemandMap r
       -- ^ Maps each function to the new elements
       -- in the demand set that need to be backpropagated to predecessors.
       -> AddrDemandMap r
    go :: Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r)
-> Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r)
-> Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r)
go Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r)
acc Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r)
new
      | Just ((MemSegmentOff (RegAddrWidth r)
fun, DemandSet r
newDemands), Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r)
rest) <- Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r)
-> Maybe
     ((MemSegmentOff (RegAddrWidth r), DemandSet r),
      Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r))
forall k a. Map k a -> Maybe ((k, a), Map k a)
Map.maxViewWithKey Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r)
new =
          let (Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r)
nexts, Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r)
acc') = Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r)
-> MemSegmentOff (RegAddrWidth r)
-> DemandSet r
-> (Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r),
    Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r))
backPropagate Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r)
acc MemSegmentOff (RegAddrWidth r)
fun DemandSet r
newDemands
           in Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r)
-> Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r)
-> Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r)
go Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r)
acc' ((DemandSet r -> DemandSet r -> DemandSet r)
-> Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r)
-> Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r)
-> Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r)
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith DemandSet r -> DemandSet r -> DemandSet r
forall a. Monoid a => a -> a -> a
mappend Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r)
rest Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r)
nexts)
      | Bool
otherwise = Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r)
acc

    backPropagate :: AddrDemandMap r
                  -> RegSegmentOff r
                  -> DemandSet r
                  -> (AddrDemandMap r, AddrDemandMap r)
    backPropagate :: Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r)
-> MemSegmentOff (RegAddrWidth r)
-> DemandSet r
-> (Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r),
    Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r))
backPropagate Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r)
acc MemSegmentOff (RegAddrWidth r)
fun (DemandSet RegisterSet r
regs Map (MemSegmentOff (RegAddrWidth r)) (RegisterSet r)
rets) =
      -- We need to push rets through the corresponding functions, and
      -- notify all functions which call fun regs.
      let retDemands :: AddrDemandMap r
          retDemands :: Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r)
retDemands = (MemSegmentOff (RegAddrWidth r) -> RegisterSet r -> DemandSet r)
-> Map (MemSegmentOff (RegAddrWidth r)) (RegisterSet r)
-> Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r)
forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey (Map (MemSegmentOff (RegAddrWidth r)) (FinalRegisterDemands r)
-> MemSegmentOff (RegAddrWidth r) -> RegisterSet r -> DemandSet r
forall (r :: Type -> Type).
OrdF r =>
Map (RegSegmentOff r) (FinalRegisterDemands r)
-> RegSegmentOff r -> Set (Some r) -> DemandSet r
postRegisterSetDemandsAtAddr (FunctionSummaries r
sFunctionSummaries r
-> Getting
     (Map (MemSegmentOff (RegAddrWidth r)) (FinalRegisterDemands r))
     (FunctionSummaries r)
     (Map (MemSegmentOff (RegAddrWidth r)) (FinalRegisterDemands r))
-> Map (MemSegmentOff (RegAddrWidth r)) (FinalRegisterDemands r)
forall s a. s -> Getting a s a -> a
^.Getting
  (Map (MemSegmentOff (RegAddrWidth r)) (FinalRegisterDemands r))
  (FunctionSummaries r)
  (Map (MemSegmentOff (RegAddrWidth r)) (FinalRegisterDemands r))
forall (r :: Type -> Type) (f :: Type -> Type).
Functor f =>
(Map (RegSegmentOff r) (FinalRegisterDemands r)
 -> f (Map (RegSegmentOff r) (FinalRegisterDemands r)))
-> FunctionSummaries r -> f (FunctionSummaries r)
funResMap)) Map (MemSegmentOff (RegAddrWidth r)) (RegisterSet r)
rets

          regsDemands :: AddrDemandMap r
          regsDemands :: Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r)
regsDemands =
            (DemandSet r -> DemandSet r -> DemandSet r)
-> [Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r)]
-> Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r)
forall (f :: Type -> Type) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
Map.unionsWith DemandSet r -> DemandSet r -> DemandSet r
forall a. Monoid a => a -> a -> a
mappend [ Map
  (MemSegmentOff (RegAddrWidth r), Some r)
  (Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r))
argDemandsMap Map
  (MemSegmentOff (RegAddrWidth r), Some r)
  (Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r))
-> Getting
     (Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r))
     (Map
        (MemSegmentOff (RegAddrWidth r), Some r)
        (Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r)))
     (Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r))
-> Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r)
forall s a. s -> Getting a s a -> a
^. Index
  (Map
     (MemSegmentOff (RegAddrWidth r), Some r)
     (Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r)))
-> Traversal'
     (Map
        (MemSegmentOff (RegAddrWidth r), Some r)
        (Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r)))
     (IxValue
        (Map
           (MemSegmentOff (RegAddrWidth r), Some r)
           (Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r))))
forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix (MemSegmentOff (RegAddrWidth r)
fun, Some r
r) | Some r
r <- RegisterSet r -> [Some r]
forall a. Set a -> [a]
Set.toList RegisterSet r
regs ]

          newDemands :: Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r)
newDemands = (DemandSet r -> DemandSet r -> DemandSet r)
-> Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r)
-> Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r)
-> Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r)
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith DemandSet r -> DemandSet r -> DemandSet r
forall a. Monoid a => a -> a -> a
mappend Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r)
regsDemands Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r)
retDemands

          -- All this in newDemands but not in acc
          novelDemands :: Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r)
novelDemands = (DemandSet r -> DemandSet r -> Maybe (DemandSet r))
-> Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r)
-> Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r)
-> Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r)
forall k a b.
Ord k =>
(a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a
Map.differenceWith DemandSet r -> DemandSet r -> Maybe (DemandSet r)
forall (r :: Type -> Type).
OrdF r =>
DemandSet r -> DemandSet r -> Maybe (DemandSet r)
diff Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r)
newDemands Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r)
acc
      in (Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r)
novelDemands, (DemandSet r -> DemandSet r -> DemandSet r)
-> Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r)
-> Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r)
-> Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r)
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith DemandSet r -> DemandSet r -> DemandSet r
forall a. Monoid a => a -> a -> a
mappend Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r)
acc Map (MemSegmentOff (RegAddrWidth r)) (DemandSet r)
novelDemands )

    diff :: DemandSet r -> DemandSet r -> Maybe (DemandSet r)
diff DemandSet r
ds1 DemandSet r
ds2 =
        let ds' :: DemandSet r
ds' = DemandSet r
ds1 DemandSet r -> DemandSet r -> DemandSet r
forall (r :: Type -> Type).
OrdF r =>
DemandSet r -> DemandSet r -> DemandSet r
`demandSetDifference` DemandSet r
ds2 in
        if DemandSet r
ds' DemandSet r -> DemandSet r -> Bool
forall a. Eq a => a -> a -> Bool
== DemandSet r
forall a. Monoid a => a
mempty then Maybe (DemandSet r)
forall a. Maybe a
Nothing else DemandSet r -> Maybe (DemandSet r)
forall a. a -> Maybe a
Just DemandSet r
ds'

-- | This analyzes the discovered functions and returns a mapping from
-- each block to the registers demanded by that blog.
functionDemands :: forall arch
                .  ArchConstraints arch
                => ArchDemandInfo arch
                   -- ^ Architecture-specific demand information.
                -> Memory (ArchAddrWidth arch)
                   -- ^ State of memory for resolving segment offsets.
                -> ResolveCallArgsFn arch
                -> [Some (DiscoveryFunInfo arch)]
                   -- ^ List of function to compute demands for.
                -> (AddrDemandMap (ArchReg arch), FunctionSummaryFailureMap (ArchReg arch))
functionDemands :: forall arch.
ArchConstraints arch =>
ArchDemandInfo arch
-> Memory (ArchAddrWidth arch)
-> ResolveCallArgsFn arch
-> [Some (DiscoveryFunInfo arch)]
-> (AddrDemandMap (ArchReg arch),
    FunctionSummaryFailureMap (ArchReg arch))
functionDemands ArchDemandInfo arch
archFns Memory (RegAddrWidth (ArchReg arch))
mem ResolveCallArgsFn arch
resolveCallFn [Some (DiscoveryFunInfo arch)]
entries = do
  let m0 :: FunctionSummaries (ArchReg arch)
      m0 :: FunctionSummaries (ArchReg arch)
m0 = FunctionSummaries
           { _funArgMap :: ArgDemandsMap (ArchReg arch)
_funArgMap = ArgDemandsMap (ArchReg arch)
forall k a. Map k a
Map.empty
           , _funResMap :: Map
  (MemSegmentOff (RegAddrWidth (ArchReg arch)))
  (FinalRegisterDemands (ArchReg arch))
_funResMap = Map
  (MemSegmentOff (RegAddrWidth (ArchReg arch)))
  (FinalRegisterDemands (ArchReg arch))
forall k a. Map k a
Map.empty
           , _alwaysDemandMap :: AddrDemandMap (ArchReg arch)
_alwaysDemandMap = AddrDemandMap (ArchReg arch)
forall k a. Map k a
Map.empty
           , inferenceFails :: FunctionSummaryFailureMap (ArchReg arch)
inferenceFails = FunctionSummaryFailureMap (ArchReg arch)
forall k a. Map k a
Map.empty
           }
  let compAddrSet :: Set (MemSegmentOff (RegAddrWidth (ArchReg arch)))
compAddrSet = [MemSegmentOff (RegAddrWidth (ArchReg arch))]
-> Set (MemSegmentOff (RegAddrWidth (ArchReg arch)))
forall a. Ord a => [a] -> Set a
Set.fromList ([MemSegmentOff (RegAddrWidth (ArchReg arch))]
 -> Set (MemSegmentOff (RegAddrWidth (ArchReg arch))))
-> [MemSegmentOff (RegAddrWidth (ArchReg arch))]
-> Set (MemSegmentOff (RegAddrWidth (ArchReg arch)))
forall a b. (a -> b) -> a -> b
$ (forall tp.
 DiscoveryFunInfo arch tp
 -> MemSegmentOff (RegAddrWidth (ArchReg arch)))
-> Some (DiscoveryFunInfo arch)
-> MemSegmentOff (RegAddrWidth (ArchReg arch))
forall {k} (f :: k -> Type) r.
(forall (tp :: k). f tp -> r) -> Some f -> r
viewSome DiscoveryFunInfo arch tp
-> MemSegmentOff (RegAddrWidth (ArchReg arch))
forall tp.
DiscoveryFunInfo arch tp
-> MemSegmentOff (RegAddrWidth (ArchReg arch))
forall arch ids. DiscoveryFunInfo arch ids -> ArchSegmentOff arch
discoveredFunAddr (Some (DiscoveryFunInfo arch)
 -> MemSegmentOff (RegAddrWidth (ArchReg arch)))
-> [Some (DiscoveryFunInfo arch)]
-> [MemSegmentOff (RegAddrWidth (ArchReg arch))]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [Some (DiscoveryFunInfo arch)]
entries

  let ctx :: FunArgContext arch
ctx = FAC { archDemandInfo :: ArchDemandInfo arch
archDemandInfo = ArchDemandInfo arch
archFns
                , ctxMemory :: Memory (RegAddrWidth (ArchReg arch))
ctxMemory = Memory (RegAddrWidth (ArchReg arch))
mem
                , computedAddrSet :: Set (MemSegmentOff (RegAddrWidth (ArchReg arch)))
computedAddrSet = Set (MemSegmentOff (RegAddrWidth (ArchReg arch)))
compAddrSet
                , resolveCallArgs :: ResolveCallArgsFn arch
resolveCallArgs = MemSegmentOff (RegAddrWidth (ArchReg arch))
-> RegState (ArchReg arch) (Value arch ids)
-> Either String [Some (Value arch ids)]
ResolveCallArgsFn arch
resolveCallFn
                }
  let summaries :: FunctionSummaries (ArchReg arch)
summaries = (FunctionSummaries (ArchReg arch)
 -> Some (DiscoveryFunInfo arch)
 -> FunctionSummaries (ArchReg arch))
-> FunctionSummaries (ArchReg arch)
-> [Some (DiscoveryFunInfo arch)]
-> FunctionSummaries (ArchReg 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' (FunArgContext arch
-> FunctionSummaries (ArchReg arch)
-> Some (DiscoveryFunInfo arch)
-> FunctionSummaries (ArchReg arch)
forall arch.
ArchConstraints arch =>
FunArgContext arch
-> FunctionSummaries (ArchReg arch)
-> Some (DiscoveryFunInfo arch)
-> FunctionSummaries (ArchReg arch)
summarizeFunction FunArgContext arch
ctx) FunctionSummaries (ArchReg arch)
m0 [Some (DiscoveryFunInfo arch)]
entries
  (FunctionSummaries (ArchReg arch) -> AddrDemandMap (ArchReg arch)
forall (r :: Type -> Type).
OrdF r =>
FunctionSummaries r -> AddrDemandMap r
calculateGlobalFixpoint FunctionSummaries (ArchReg arch)
summaries, FunctionSummaries (ArchReg arch)
-> FunctionSummaryFailureMap (ArchReg arch)
forall (r :: Type -> Type).
FunctionSummaries r -> FunctionSummaryFailureMap r
inferenceFails FunctionSummaries (ArchReg arch)
summaries)