{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RankNTypes #-}
module Data.Macaw.CFG.DemandSet
( DemandComp
, AssignIdSet
, runDemandComp
, addValueDemands
, addStmtDemands
, DemandContext(..)
, hasSideEffects
, stmtNeeded
) where
import Control.Monad (when)
import Control.Monad.State.Strict (MonadState(..), State, execState, gets)
import Data.Parameterized.Some
import Data.Parameterized.TraversableF
import Data.Parameterized.TraversableFC
import Data.Parameterized.Map as MapF
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Macaw.CFG.Core
type AssignIdSet ids = Set (Some (AssignId ids))
data DemandContext arch
= DemandContext { forall arch.
DemandContext arch
-> forall (v :: Type -> Type) (tp :: Type).
ArchFn arch v tp -> Bool
archFnHasSideEffects :: !(forall v tp . ArchFn arch v tp -> Bool)
, forall arch.
DemandContext arch
-> forall a.
((FoldableFC (ArchFn arch), FoldableF (ArchStmt arch)) => a) -> a
demandConstraints :: !(forall a
. ((FoldableFC (ArchFn arch), FoldableF (ArchStmt arch))
=> a) -> a)
}
hasSideEffects :: DemandContext arch -> AssignRhs arch f tp -> Bool
hasSideEffects :: forall arch (f :: Type -> Type) (tp :: Type).
DemandContext arch -> AssignRhs arch f tp -> Bool
hasSideEffects DemandContext arch
ctx AssignRhs arch f tp
rhs =
case AssignRhs arch f tp
rhs of
EvalApp{} -> Bool
False
SetUndefined{} -> Bool
False
ReadMem{} -> Bool
True
CondReadMem{} -> Bool
True
EvalArchFn ArchFn arch f tp
fn TypeRepr tp
_ -> DemandContext arch
-> forall (v :: Type -> Type) (tp :: Type).
ArchFn arch v tp -> Bool
forall arch.
DemandContext arch
-> forall (v :: Type -> Type) (tp :: Type).
ArchFn arch v tp -> Bool
archFnHasSideEffects DemandContext arch
ctx ArchFn arch f tp
fn
data DemandState arch ids
= DemandState { forall arch ids. DemandState arch ids -> DemandContext arch
demandContext :: !(DemandContext arch)
, forall arch ids. DemandState arch ids -> AssignIdSet ids
demandedAssignIds :: !(AssignIdSet ids)
}
newtype DemandComp arch ids a = DemandComp { forall arch ids a.
DemandComp arch ids a -> State (DemandState arch ids) a
unDemandComp :: State (DemandState arch ids) a }
deriving ((forall a b.
(a -> b) -> DemandComp arch ids a -> DemandComp arch ids b)
-> (forall a b.
a -> DemandComp arch ids b -> DemandComp arch ids a)
-> Functor (DemandComp arch ids)
forall a b. a -> DemandComp arch ids b -> DemandComp arch ids a
forall a b.
(a -> b) -> DemandComp arch ids a -> DemandComp arch ids b
forall arch ids a b.
a -> DemandComp arch ids b -> DemandComp arch ids a
forall arch ids a b.
(a -> b) -> DemandComp arch ids a -> DemandComp arch ids b
forall (f :: Type -> Type).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall arch ids a b.
(a -> b) -> DemandComp arch ids a -> DemandComp arch ids b
fmap :: forall a b.
(a -> b) -> DemandComp arch ids a -> DemandComp arch ids b
$c<$ :: forall arch ids a b.
a -> DemandComp arch ids b -> DemandComp arch ids a
<$ :: forall a b. a -> DemandComp arch ids b -> DemandComp arch ids a
Functor, Functor (DemandComp arch ids)
Functor (DemandComp arch ids) =>
(forall a. a -> DemandComp arch ids a)
-> (forall a b.
DemandComp arch ids (a -> b)
-> DemandComp arch ids a -> DemandComp arch ids b)
-> (forall a b c.
(a -> b -> c)
-> DemandComp arch ids a
-> DemandComp arch ids b
-> DemandComp arch ids c)
-> (forall a b.
DemandComp arch ids a
-> DemandComp arch ids b -> DemandComp arch ids b)
-> (forall a b.
DemandComp arch ids a
-> DemandComp arch ids b -> DemandComp arch ids a)
-> Applicative (DemandComp arch ids)
forall a. a -> DemandComp arch ids a
forall arch ids. Functor (DemandComp arch ids)
forall a b.
DemandComp arch ids a
-> DemandComp arch ids b -> DemandComp arch ids a
forall a b.
DemandComp arch ids a
-> DemandComp arch ids b -> DemandComp arch ids b
forall a b.
DemandComp arch ids (a -> b)
-> DemandComp arch ids a -> DemandComp arch ids b
forall arch ids a. a -> DemandComp arch ids a
forall a b c.
(a -> b -> c)
-> DemandComp arch ids a
-> DemandComp arch ids b
-> DemandComp arch ids c
forall arch ids a b.
DemandComp arch ids a
-> DemandComp arch ids b -> DemandComp arch ids a
forall arch ids a b.
DemandComp arch ids a
-> DemandComp arch ids b -> DemandComp arch ids b
forall arch ids a b.
DemandComp arch ids (a -> b)
-> DemandComp arch ids a -> DemandComp arch ids b
forall arch ids a b c.
(a -> b -> c)
-> DemandComp arch ids a
-> DemandComp arch ids b
-> DemandComp arch ids c
forall (f :: Type -> Type).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall arch ids a. a -> DemandComp arch ids a
pure :: forall a. a -> DemandComp arch ids a
$c<*> :: forall arch ids a b.
DemandComp arch ids (a -> b)
-> DemandComp arch ids a -> DemandComp arch ids b
<*> :: forall a b.
DemandComp arch ids (a -> b)
-> DemandComp arch ids a -> DemandComp arch ids b
$cliftA2 :: forall arch ids a b c.
(a -> b -> c)
-> DemandComp arch ids a
-> DemandComp arch ids b
-> DemandComp arch ids c
liftA2 :: forall a b c.
(a -> b -> c)
-> DemandComp arch ids a
-> DemandComp arch ids b
-> DemandComp arch ids c
$c*> :: forall arch ids a b.
DemandComp arch ids a
-> DemandComp arch ids b -> DemandComp arch ids b
*> :: forall a b.
DemandComp arch ids a
-> DemandComp arch ids b -> DemandComp arch ids b
$c<* :: forall arch ids a b.
DemandComp arch ids a
-> DemandComp arch ids b -> DemandComp arch ids a
<* :: forall a b.
DemandComp arch ids a
-> DemandComp arch ids b -> DemandComp arch ids a
Applicative, Applicative (DemandComp arch ids)
Applicative (DemandComp arch ids) =>
(forall a b.
DemandComp arch ids a
-> (a -> DemandComp arch ids b) -> DemandComp arch ids b)
-> (forall a b.
DemandComp arch ids a
-> DemandComp arch ids b -> DemandComp arch ids b)
-> (forall a. a -> DemandComp arch ids a)
-> Monad (DemandComp arch ids)
forall a. a -> DemandComp arch ids a
forall arch ids. Applicative (DemandComp arch ids)
forall a b.
DemandComp arch ids a
-> DemandComp arch ids b -> DemandComp arch ids b
forall a b.
DemandComp arch ids a
-> (a -> DemandComp arch ids b) -> DemandComp arch ids b
forall arch ids a. a -> DemandComp arch ids a
forall arch ids a b.
DemandComp arch ids a
-> DemandComp arch ids b -> DemandComp arch ids b
forall arch ids a b.
DemandComp arch ids a
-> (a -> DemandComp arch ids b) -> DemandComp arch ids b
forall (m :: Type -> Type).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall arch ids a b.
DemandComp arch ids a
-> (a -> DemandComp arch ids b) -> DemandComp arch ids b
>>= :: forall a b.
DemandComp arch ids a
-> (a -> DemandComp arch ids b) -> DemandComp arch ids b
$c>> :: forall arch ids a b.
DemandComp arch ids a
-> DemandComp arch ids b -> DemandComp arch ids b
>> :: forall a b.
DemandComp arch ids a
-> DemandComp arch ids b -> DemandComp arch ids b
$creturn :: forall arch ids a. a -> DemandComp arch ids a
return :: forall a. a -> DemandComp arch ids a
Monad)
runDemandComp :: DemandContext arch -> DemandComp arch ids () -> AssignIdSet ids
runDemandComp :: forall arch ids.
DemandContext arch -> DemandComp arch ids () -> AssignIdSet ids
runDemandComp DemandContext arch
ctx DemandComp arch ids ()
comp = DemandState arch ids -> AssignIdSet ids
forall arch ids. DemandState arch ids -> AssignIdSet ids
demandedAssignIds (DemandState arch ids -> AssignIdSet ids)
-> DemandState arch ids -> AssignIdSet ids
forall a b. (a -> b) -> a -> b
$ State (DemandState arch ids) ()
-> DemandState arch ids -> DemandState arch ids
forall s a. State s a -> s -> s
execState (DemandComp arch ids () -> State (DemandState arch ids) ()
forall arch ids a.
DemandComp arch ids a -> State (DemandState arch ids) a
unDemandComp DemandComp arch ids ()
comp) DemandState arch ids
s
where s :: DemandState arch ids
s = DemandState { demandContext :: DemandContext arch
demandContext = DemandContext arch
ctx
, demandedAssignIds :: AssignIdSet ids
demandedAssignIds = AssignIdSet ids
forall a. Set a
Set.empty
}
addAssignmentDemands :: Assignment arch ids tp -> DemandComp arch ids ()
addAssignmentDemands :: forall arch ids (tp :: Type).
Assignment arch ids tp -> DemandComp arch ids ()
addAssignmentDemands Assignment arch ids tp
a = do
DemandState arch ids
s <- State (DemandState arch ids) (DemandState arch ids)
-> DemandComp arch ids (DemandState arch ids)
forall arch ids a.
State (DemandState arch ids) a -> DemandComp arch ids a
DemandComp State (DemandState arch ids) (DemandState arch ids)
forall s (m :: Type -> Type). MonadState s m => m s
get
let thisId :: Some (AssignId ids)
thisId = AssignId ids tp -> Some (AssignId ids)
forall k (f :: k -> Type) (x :: k). f x -> Some f
Some (Assignment arch ids tp -> AssignId ids tp
forall arch ids (tp :: Type).
Assignment arch ids tp -> AssignId ids tp
assignId Assignment arch ids tp
a)
Bool -> DemandComp arch ids () -> DemandComp arch ids ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Some (AssignId ids) -> Set (Some (AssignId ids)) -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.notMember Some (AssignId ids)
thisId (DemandState arch ids -> Set (Some (AssignId ids))
forall arch ids. DemandState arch ids -> AssignIdSet ids
demandedAssignIds DemandState arch ids
s)) (DemandComp arch ids () -> DemandComp arch ids ())
-> DemandComp arch ids () -> DemandComp arch ids ()
forall a b. (a -> b) -> a -> b
$ do
let s' :: DemandState arch ids
s' = DemandState arch ids
s { demandedAssignIds = Set.insert thisId (demandedAssignIds s) }
DemandState arch ids
-> DemandComp arch ids () -> DemandComp arch ids ()
forall a b. a -> b -> b
seq DemandState arch ids
s' (DemandComp arch ids () -> DemandComp arch ids ())
-> DemandComp arch ids () -> DemandComp arch ids ()
forall a b. (a -> b) -> a -> b
$ State (DemandState arch ids) () -> DemandComp arch ids ()
forall arch ids a.
State (DemandState arch ids) a -> DemandComp arch ids a
DemandComp (State (DemandState arch ids) () -> DemandComp arch ids ())
-> State (DemandState arch ids) () -> DemandComp arch ids ()
forall a b. (a -> b) -> a -> b
$ DemandState arch ids -> State (DemandState arch ids) ()
forall s (m :: Type -> Type). MonadState s m => s -> m ()
put DemandState arch ids
s'
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 (DemandState arch ids -> DemandContext arch
forall arch ids. DemandState arch ids -> DemandContext arch
demandContext DemandState arch ids
s) (((FoldableFC (ArchFn arch), FoldableF (ArchStmt arch)) =>
DemandComp arch ids ())
-> DemandComp arch ids ())
-> ((FoldableFC (ArchFn arch), FoldableF (ArchStmt arch)) =>
DemandComp arch ids ())
-> DemandComp arch ids ()
forall a b. (a -> b) -> a -> b
$
(forall (x :: Type). Value arch ids x -> DemandComp arch ids ())
-> forall (x :: Type).
AssignRhs arch (Value arch ids) x -> DemandComp arch ids ()
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_ Value arch ids x -> DemandComp arch ids ()
forall arch ids (tp :: Type).
Value arch ids tp -> DemandComp arch ids ()
forall (x :: Type). Value arch ids x -> DemandComp arch ids ()
addValueDemands (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)
addValueDemands :: Value arch ids tp -> DemandComp arch ids ()
addValueDemands :: forall arch ids (tp :: Type).
Value arch ids tp -> DemandComp arch ids ()
addValueDemands Value arch ids tp
v = do
case Value arch ids tp
v of
CValue{} -> () -> DemandComp arch ids ()
forall a. a -> DemandComp arch ids a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ()
AssignedValue Assignment arch ids tp
a -> Assignment arch ids tp -> DemandComp arch ids ()
forall arch ids (tp :: Type).
Assignment arch ids tp -> DemandComp arch ids ()
addAssignmentDemands Assignment arch ids tp
a
Initial{} -> () -> DemandComp arch ids ()
forall a. a -> DemandComp arch ids a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ()
addStmtDemands :: Stmt arch ids -> DemandComp arch ids ()
addStmtDemands :: forall arch ids. Stmt arch ids -> DemandComp arch ids ()
addStmtDemands Stmt arch ids
s =
case Stmt arch ids
s of
AssignStmt Assignment arch ids tp
a -> do
DemandContext arch
ctx <- State (DemandState arch ids) (DemandContext arch)
-> DemandComp arch ids (DemandContext arch)
forall arch ids a.
State (DemandState arch ids) a -> DemandComp arch ids a
DemandComp (State (DemandState arch ids) (DemandContext arch)
-> DemandComp arch ids (DemandContext arch))
-> State (DemandState arch ids) (DemandContext arch)
-> DemandComp arch ids (DemandContext arch)
forall a b. (a -> b) -> a -> b
$ (DemandState arch ids -> DemandContext arch)
-> State (DemandState arch ids) (DemandContext arch)
forall s (m :: Type -> Type) a. MonadState s m => (s -> a) -> m a
gets DemandState arch ids -> DemandContext arch
forall arch ids. DemandState arch ids -> DemandContext arch
demandContext
Bool -> DemandComp arch ids () -> DemandComp arch ids ()
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)) (DemandComp arch ids () -> DemandComp arch ids ())
-> DemandComp arch ids () -> DemandComp arch ids ()
forall a b. (a -> b) -> a -> b
$ do
Assignment arch ids tp -> DemandComp arch ids ()
forall arch ids (tp :: Type).
Assignment arch ids tp -> DemandComp arch ids ()
addAssignmentDemands Assignment arch ids tp
a
WriteMem ArchAddrValue arch ids
addr MemRepr tp
_repr Value arch ids tp
val -> do
ArchAddrValue arch ids -> DemandComp arch ids ()
forall arch ids (tp :: Type).
Value arch ids tp -> DemandComp arch ids ()
addValueDemands ArchAddrValue arch ids
addr
Value arch ids tp -> DemandComp arch ids ()
forall arch ids (tp :: Type).
Value arch ids tp -> DemandComp arch ids ()
addValueDemands Value arch ids tp
val
CondWriteMem Value arch ids BoolType
cond ArchAddrValue arch ids
addr MemRepr tp
_repr Value arch ids tp
val -> do
Value arch ids BoolType -> DemandComp arch ids ()
forall arch ids (tp :: Type).
Value arch ids tp -> DemandComp arch ids ()
addValueDemands Value arch ids BoolType
cond
ArchAddrValue arch ids -> DemandComp arch ids ()
forall arch ids (tp :: Type).
Value arch ids tp -> DemandComp arch ids ()
addValueDemands ArchAddrValue arch ids
addr
Value arch ids tp -> DemandComp arch ids ()
forall arch ids (tp :: Type).
Value arch ids tp -> DemandComp arch ids ()
addValueDemands Value arch ids tp
val
InstructionStart{} ->
() -> DemandComp arch ids ()
forall a. a -> DemandComp arch ids a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ()
Comment Text
_ ->
() -> DemandComp arch ids ()
forall a. a -> DemandComp arch ids a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ()
ExecArchStmt ArchStmt arch (Value arch ids)
astmt -> do
DemandContext arch
ctx <- State (DemandState arch ids) (DemandContext arch)
-> DemandComp arch ids (DemandContext arch)
forall arch ids a.
State (DemandState arch ids) a -> DemandComp arch ids a
DemandComp (State (DemandState arch ids) (DemandContext arch)
-> DemandComp arch ids (DemandContext arch))
-> State (DemandState arch ids) (DemandContext arch)
-> DemandComp arch ids (DemandContext arch)
forall a b. (a -> b) -> a -> b
$ (DemandState arch ids -> DemandContext arch)
-> State (DemandState arch ids) (DemandContext arch)
forall s (m :: Type -> Type) a. MonadState s m => (s -> a) -> m a
gets DemandState arch ids -> DemandContext arch
forall arch ids. DemandState arch ids -> DemandContext arch
demandContext
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)) =>
DemandComp arch ids ())
-> DemandComp arch ids ())
-> ((FoldableFC (ArchFn arch), FoldableF (ArchStmt arch)) =>
DemandComp arch ids ())
-> DemandComp arch ids ()
forall a b. (a -> b) -> a -> b
$
(forall (s :: Type). Value arch ids s -> DemandComp arch ids ())
-> ArchStmt arch (Value arch ids) -> DemandComp arch ids ()
forall {k} (t :: (k -> Type) -> Type) (f :: Type -> Type)
(e :: k -> Type) a.
(FoldableF t, Applicative f) =>
(forall (s :: k). e s -> f a) -> t e -> f ()
traverseF_ Value arch ids s -> DemandComp arch ids ()
forall arch ids (tp :: Type).
Value arch ids tp -> DemandComp arch ids ()
forall (s :: Type). Value arch ids s -> DemandComp arch ids ()
addValueDemands ArchStmt arch (Value arch ids)
astmt
ArchState ArchMemAddr arch
_a MapF (ArchReg arch) (Value arch ids)
updates ->
(forall (tp :: Type).
ArchReg arch tp -> Value arch ids tp -> DemandComp arch ids ())
-> MapF (ArchReg arch) (Value arch ids) -> DemandComp arch ids ()
forall {v} (m :: Type -> Type) (ktp :: v -> Type) (f :: v -> Type).
Applicative m =>
(forall (tp :: v). ktp tp -> f tp -> m ()) -> MapF ktp f -> m ()
MapF.traverseWithKey_ ((Value arch ids tp -> DemandComp arch ids ())
-> ArchReg arch tp -> Value arch ids tp -> DemandComp arch ids ()
forall a b. a -> b -> a
const Value arch ids tp -> DemandComp arch ids ()
forall arch ids (tp :: Type).
Value arch ids tp -> DemandComp arch ids ()
addValueDemands) MapF (ArchReg arch) (Value arch ids)
updates
stmtNeeded :: AssignIdSet ids -> Stmt arch ids -> Bool
stmtNeeded :: forall ids arch. AssignIdSet ids -> Stmt arch ids -> Bool
stmtNeeded AssignIdSet ids
demandSet Stmt arch ids
stmt =
case Stmt arch ids
stmt of
AssignStmt Assignment arch ids tp
a -> Some (AssignId ids) -> AssignIdSet ids -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member (AssignId ids tp -> Some (AssignId ids)
forall k (f :: k -> Type) (x :: k). f x -> Some f
Some (Assignment arch ids tp -> AssignId ids tp
forall arch ids (tp :: Type).
Assignment arch ids tp -> AssignId ids tp
assignId Assignment arch ids tp
a)) AssignIdSet ids
demandSet
CondWriteMem{} -> Bool
True
WriteMem{} -> Bool
True
InstructionStart{} -> Bool
True
Comment{} -> Bool
True
ExecArchStmt{} -> Bool
True
ArchState{} -> Bool
True