{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Futhark.IR.Aliases
(
Aliases,
AliasDec (..),
VarAliases,
ConsumedInExp,
BodyAliasing,
module Futhark.IR.Prop.Aliases,
module Futhark.IR.Prop,
module Futhark.IR.Traversals,
module Futhark.IR.Pretty,
module Futhark.IR.Syntax,
mkAliasedBody,
mkAliasedPat,
mkBodyAliasing,
CanBeAliased (..),
AliasableRep,
removeProgAliases,
removeFunDefAliases,
removeExpAliases,
removeStmAliases,
removeBodyAliases,
removeLambdaAliases,
removePatAliases,
removeScopeAliases,
AliasesAndConsumed,
trackAliases,
mkStmsAliases,
consumedInStms,
)
where
import Control.Monad.Identity
import Control.Monad.Reader
import Data.Kind qualified
import Data.Map.Strict qualified as M
import Data.Maybe
import Futhark.Builder
import Futhark.IR.Pretty
import Futhark.IR.Prop
import Futhark.IR.Prop.Aliases
import Futhark.IR.Syntax
import Futhark.IR.Traversals
import Futhark.Transform.Rename
import Futhark.Transform.Substitute
import Futhark.Util.Pretty qualified as PP
data Aliases (rep :: Data.Kind.Type)
newtype AliasDec = AliasDec {AliasDec -> Names
unAliases :: Names}
deriving (Int -> AliasDec -> ShowS
[AliasDec] -> ShowS
AliasDec -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AliasDec] -> ShowS
$cshowList :: [AliasDec] -> ShowS
show :: AliasDec -> String
$cshow :: AliasDec -> String
showsPrec :: Int -> AliasDec -> ShowS
$cshowsPrec :: Int -> AliasDec -> ShowS
Show)
instance Semigroup AliasDec where
AliasDec
x <> :: AliasDec -> AliasDec -> AliasDec
<> AliasDec
y = Names -> AliasDec
AliasDec forall a b. (a -> b) -> a -> b
$ AliasDec -> Names
unAliases AliasDec
x forall a. Semigroup a => a -> a -> a
<> AliasDec -> Names
unAliases AliasDec
y
instance Monoid AliasDec where
mempty :: AliasDec
mempty = Names -> AliasDec
AliasDec forall a. Monoid a => a
mempty
instance Eq AliasDec where
AliasDec
_ == :: AliasDec -> AliasDec -> Bool
== AliasDec
_ = Bool
True
instance Ord AliasDec where
AliasDec
_ compare :: AliasDec -> AliasDec -> Ordering
`compare` AliasDec
_ = Ordering
EQ
instance Rename AliasDec where
rename :: AliasDec -> RenameM AliasDec
rename (AliasDec Names
names) = Names -> AliasDec
AliasDec forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Rename a => a -> RenameM a
rename Names
names
instance Substitute AliasDec where
substituteNames :: Map VName VName -> AliasDec -> AliasDec
substituteNames Map VName VName
substs (AliasDec Names
names) = Names -> AliasDec
AliasDec forall a b. (a -> b) -> a -> b
$ forall a. Substitute a => Map VName VName -> a -> a
substituteNames Map VName VName
substs Names
names
instance FreeIn AliasDec where
freeIn' :: AliasDec -> FV
freeIn' = forall a b. a -> b -> a
const forall a. Monoid a => a
mempty
instance PP.Pretty AliasDec where
pretty :: forall ann. AliasDec -> Doc ann
pretty = forall ann. Doc ann -> Doc ann
PP.braces forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [Doc a] -> Doc a
PP.commasep forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a ann. Pretty a => a -> Doc ann
PP.pretty forall b c a. (b -> c) -> (a -> b) -> a -> c
. Names -> [VName]
namesToList forall b c a. (b -> c) -> (a -> b) -> a -> c
. AliasDec -> Names
unAliases
type VarAliases = AliasDec
type ConsumedInExp = AliasDec
type BodyAliasing = ([VarAliases], ConsumedInExp)
instance (RepTypes rep, ASTConstraints (OpC rep (Aliases rep))) => RepTypes (Aliases rep) where
type LetDec (Aliases rep) = (VarAliases, LetDec rep)
type ExpDec (Aliases rep) = (ConsumedInExp, ExpDec rep)
type BodyDec (Aliases rep) = (BodyAliasing, BodyDec rep)
type FParamInfo (Aliases rep) = FParamInfo rep
type LParamInfo (Aliases rep) = LParamInfo rep
type RetType (Aliases rep) = RetType rep
type BranchType (Aliases rep) = BranchType rep
type OpC (Aliases rep) = OpC rep
instance AliasesOf (VarAliases, dec) where
aliasesOf :: (AliasDec, dec) -> Names
aliasesOf = AliasDec -> Names
unAliases forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst
instance FreeDec AliasDec
withoutAliases ::
(HasScope (Aliases rep) m, Monad m) =>
ReaderT (Scope rep) m a ->
m a
withoutAliases :: forall rep (m :: * -> *) a.
(HasScope (Aliases rep) m, Monad m) =>
ReaderT (Scope rep) m a -> m a
withoutAliases ReaderT (Scope rep) m a
m = do
Scope rep
scope <- forall rep (m :: * -> *) a.
HasScope rep m =>
(Scope rep -> a) -> m a
asksScope forall rep. Scope (Aliases rep) -> Scope rep
removeScopeAliases
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT (Scope rep) m a
m Scope rep
scope
instance (ASTRep rep, AliasedOp (OpC rep (Aliases rep))) => ASTRep (Aliases rep) where
expTypesFromPat :: forall (m :: * -> *).
(HasScope (Aliases rep) m, Monad m) =>
Pat (LetDec (Aliases rep)) -> m [BranchType (Aliases rep)]
expTypesFromPat =
forall rep (m :: * -> *) a.
(HasScope (Aliases rep) m, Monad m) =>
ReaderT (Scope rep) m a -> m a
withoutAliases forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall rep (m :: * -> *).
(ASTRep rep, HasScope rep m, Monad m) =>
Pat (LetDec rep) -> m [BranchType rep]
expTypesFromPat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Pat (AliasDec, a) -> Pat a
removePatAliases
instance (ASTRep rep, AliasedOp (OpC rep (Aliases rep))) => Aliased (Aliases rep) where
bodyAliases :: Body (Aliases rep) -> [Names]
bodyAliases = forall a b. (a -> b) -> [a] -> [b]
map AliasDec -> Names
unAliases forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall rep. Body rep -> BodyDec rep
bodyDec
consumedInBody :: Body (Aliases rep) -> Names
consumedInBody = AliasDec -> Names
unAliases forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall rep. Body rep -> BodyDec rep
bodyDec
instance (ASTRep rep, AliasedOp (OpC rep (Aliases rep))) => PrettyRep (Aliases rep) where
ppExpDec :: forall a.
ExpDec (Aliases rep) -> Exp (Aliases rep) -> Maybe (Doc a)
ppExpDec (AliasDec
consumed, ExpDec rep
inner) Exp (Aliases rep)
e =
forall a. [Doc a] -> Maybe (Doc a)
maybeComment forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$
[Maybe (Doc a)
exp_dec, Maybe (Doc a)
merge_dec, forall rep a.
PrettyRep rep =>
ExpDec rep -> Exp rep -> Maybe (Doc a)
ppExpDec ExpDec rep
inner forall a b. (a -> b) -> a -> b
$ forall rep. RephraseOp (OpC rep) => Exp (Aliases rep) -> Exp rep
removeExpAliases Exp (Aliases rep)
e]
where
merge_dec :: Maybe (Doc a)
merge_dec =
case Exp (Aliases rep)
e of
DoLoop [(FParam (Aliases rep), SubExp)]
merge LoopForm (Aliases rep)
_ Body (Aliases rep)
body ->
let mergeParamAliases :: Param dec -> Names -> Maybe (Doc ann)
mergeParamAliases Param dec
fparam Names
als
| forall shape u. TypeBase shape u -> Bool
primType (forall dec. Typed dec => Param dec -> Type
paramType Param dec
fparam) =
forall a. Maybe a
Nothing
| Bool
otherwise =
forall a ann. Pretty a => a -> Names -> Maybe (Doc ann)
resultAliasComment (forall dec. Param dec -> VName
paramName Param dec
fparam) Names
als
in forall a. [Doc a] -> Maybe (Doc a)
maybeComment forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall {dec} {ann}.
Typed dec =>
Param dec -> Names -> Maybe (Doc ann)
mergeParamAliases (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(FParam (Aliases rep), SubExp)]
merge) forall a b. (a -> b) -> a -> b
$
forall rep. Aliased rep => Body rep -> [Names]
bodyAliases Body (Aliases rep)
body
Exp (Aliases rep)
_ -> forall a. Maybe a
Nothing
exp_dec :: Maybe (Doc a)
exp_dec = case Names -> [VName]
namesToList forall a b. (a -> b) -> a -> b
$ AliasDec -> Names
unAliases AliasDec
consumed of
[] -> forall a. Maybe a
Nothing
[VName]
als ->
forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
forall ann. Doc ann -> Doc ann
PP.oneLine forall a b. (a -> b) -> a -> b
$
Doc a
"-- Consumes " forall a. Semigroup a => a -> a -> a
<> forall a. [Doc a] -> Doc a
PP.commasep (forall a b. (a -> b) -> [a] -> [b]
map forall a ann. Pretty a => a -> Doc ann
PP.pretty [VName]
als)
maybeComment :: [PP.Doc a] -> Maybe (PP.Doc a)
[] = forall a. Maybe a
Nothing
maybeComment [Doc a]
cs = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. [Doc a] -> Doc a
PP.stack [Doc a]
cs
resultAliasComment :: PP.Pretty a => a -> Names -> Maybe (PP.Doc ann)
a
name Names
als =
case Names -> [VName]
namesToList Names
als of
[] -> forall a. Maybe a
Nothing
[VName]
als' ->
forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
forall ann. Doc ann -> Doc ann
PP.oneLine forall a b. (a -> b) -> a -> b
$
Doc ann
"-- Result for "
forall a. Semigroup a => a -> a -> a
<> forall a ann. Pretty a => a -> Doc ann
PP.pretty a
name
forall a. Semigroup a => a -> a -> a
<> Doc ann
" aliases "
forall a. Semigroup a => a -> a -> a
<> forall a. [Doc a] -> Doc a
PP.commasep (forall a b. (a -> b) -> [a] -> [b]
map forall a ann. Pretty a => a -> Doc ann
PP.pretty [VName]
als')
removeAliases :: RephraseOp (OpC rep) => Rephraser Identity (Aliases rep) rep
removeAliases :: forall rep.
RephraseOp (OpC rep) =>
Rephraser Identity (Aliases rep) rep
removeAliases =
Rephraser
{ rephraseExpDec :: ExpDec (Aliases rep) -> Identity (ExpDec rep)
rephraseExpDec = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd,
rephraseLetBoundDec :: LetDec (Aliases rep) -> Identity (LetDec rep)
rephraseLetBoundDec = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd,
rephraseBodyDec :: BodyDec (Aliases rep) -> Identity (BodyDec rep)
rephraseBodyDec = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd,
rephraseFParamDec :: FParamInfo (Aliases rep) -> Identity (FParamInfo rep)
rephraseFParamDec = forall (f :: * -> *) a. Applicative f => a -> f a
pure,
rephraseLParamDec :: LParamInfo (Aliases rep) -> Identity (LParamInfo rep)
rephraseLParamDec = forall (f :: * -> *) a. Applicative f => a -> f a
pure,
rephraseRetType :: RetType (Aliases rep) -> Identity (RetType rep)
rephraseRetType = forall (f :: * -> *) a. Applicative f => a -> f a
pure,
rephraseBranchType :: BranchType (Aliases rep) -> Identity (BranchType rep)
rephraseBranchType = forall (f :: * -> *) a. Applicative f => a -> f a
pure,
rephraseOp :: Op (Aliases rep) -> Identity (Op rep)
rephraseOp = forall (op :: * -> *) (m :: * -> *) from to.
(RephraseOp op, Monad m) =>
Rephraser m from to -> op from -> m (op to)
rephraseInOp forall rep.
RephraseOp (OpC rep) =>
Rephraser Identity (Aliases rep) rep
removeAliases
}
removeScopeAliases :: Scope (Aliases rep) -> Scope rep
removeScopeAliases :: forall rep. Scope (Aliases rep) -> Scope rep
removeScopeAliases = forall a b k. (a -> b) -> Map k a -> Map k b
M.map forall {rep} {rep} {a}.
(FParamInfo rep ~ FParamInfo rep, LetDec rep ~ (a, LetDec rep),
LParamInfo rep ~ LParamInfo rep) =>
NameInfo rep -> NameInfo rep
unAlias
where
unAlias :: NameInfo rep -> NameInfo rep
unAlias (LetName (a
_, LetDec rep
dec)) = forall rep. LetDec rep -> NameInfo rep
LetName LetDec rep
dec
unAlias (FParamName FParamInfo rep
dec) = forall rep. FParamInfo rep -> NameInfo rep
FParamName FParamInfo rep
dec
unAlias (LParamName LParamInfo rep
dec) = forall rep. LParamInfo rep -> NameInfo rep
LParamName LParamInfo rep
dec
unAlias (IndexName IntType
it) = forall rep. IntType -> NameInfo rep
IndexName IntType
it
removeProgAliases ::
RephraseOp (OpC rep) =>
Prog (Aliases rep) ->
Prog rep
removeProgAliases :: forall rep. RephraseOp (OpC rep) => Prog (Aliases rep) -> Prog rep
removeProgAliases = forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) from to.
Monad m =>
Rephraser m from to -> Prog from -> m (Prog to)
rephraseProg forall rep.
RephraseOp (OpC rep) =>
Rephraser Identity (Aliases rep) rep
removeAliases
removeFunDefAliases ::
RephraseOp (OpC rep) =>
FunDef (Aliases rep) ->
FunDef rep
removeFunDefAliases :: forall rep.
RephraseOp (OpC rep) =>
FunDef (Aliases rep) -> FunDef rep
removeFunDefAliases = forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) from to.
Monad m =>
Rephraser m from to -> FunDef from -> m (FunDef to)
rephraseFunDef forall rep.
RephraseOp (OpC rep) =>
Rephraser Identity (Aliases rep) rep
removeAliases
removeExpAliases ::
RephraseOp (OpC rep) =>
Exp (Aliases rep) ->
Exp rep
removeExpAliases :: forall rep. RephraseOp (OpC rep) => Exp (Aliases rep) -> Exp rep
removeExpAliases = forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) from to.
Monad m =>
Rephraser m from to -> Exp from -> m (Exp to)
rephraseExp forall rep.
RephraseOp (OpC rep) =>
Rephraser Identity (Aliases rep) rep
removeAliases
removeStmAliases ::
RephraseOp (OpC rep) =>
Stm (Aliases rep) ->
Stm rep
removeStmAliases :: forall rep. RephraseOp (OpC rep) => Stm (Aliases rep) -> Stm rep
removeStmAliases = forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) from to.
Monad m =>
Rephraser m from to -> Stm from -> m (Stm to)
rephraseStm forall rep.
RephraseOp (OpC rep) =>
Rephraser Identity (Aliases rep) rep
removeAliases
removeBodyAliases ::
RephraseOp (OpC rep) =>
Body (Aliases rep) ->
Body rep
removeBodyAliases :: forall rep. RephraseOp (OpC rep) => Body (Aliases rep) -> Body rep
removeBodyAliases = forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) from to.
Monad m =>
Rephraser m from to -> Body from -> m (Body to)
rephraseBody forall rep.
RephraseOp (OpC rep) =>
Rephraser Identity (Aliases rep) rep
removeAliases
removeLambdaAliases ::
RephraseOp (OpC rep) =>
Lambda (Aliases rep) ->
Lambda rep
removeLambdaAliases :: forall rep.
RephraseOp (OpC rep) =>
Lambda (Aliases rep) -> Lambda rep
removeLambdaAliases = forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) from to.
Monad m =>
Rephraser m from to -> Lambda from -> m (Lambda to)
rephraseLambda forall rep.
RephraseOp (OpC rep) =>
Rephraser Identity (Aliases rep) rep
removeAliases
removePatAliases ::
Pat (AliasDec, a) ->
Pat a
removePatAliases :: forall a. Pat (AliasDec, a) -> Pat a
removePatAliases = forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) from to.
Monad m =>
(from -> m to) -> Pat from -> m (Pat to)
rephrasePat (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd)
mkAliasedBody ::
(ASTRep rep, AliasedOp (OpC rep (Aliases rep))) =>
BodyDec rep ->
Stms (Aliases rep) ->
Result ->
Body (Aliases rep)
mkAliasedBody :: forall rep.
(ASTRep rep, AliasedOp (OpC rep (Aliases rep))) =>
BodyDec rep -> Stms (Aliases rep) -> Result -> Body (Aliases rep)
mkAliasedBody BodyDec rep
dec Stms (Aliases rep)
stms Result
res =
forall rep. BodyDec rep -> Stms rep -> Result -> Body rep
Body (forall rep. Aliased rep => Stms rep -> Result -> BodyAliasing
mkBodyAliasing Stms (Aliases rep)
stms Result
res, BodyDec rep
dec) Stms (Aliases rep)
stms Result
res
mkAliasedPat ::
(Aliased rep, Typed dec) =>
Pat dec ->
Exp rep ->
Pat (VarAliases, dec)
mkAliasedPat :: forall rep dec.
(Aliased rep, Typed dec) =>
Pat dec -> Exp rep -> Pat (AliasDec, dec)
mkAliasedPat (Pat [PatElem dec]
pes) Exp rep
e =
forall dec. [PatElem dec] -> Pat dec
Pat forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall {b}. Typed b => PatElem b -> Names -> PatElem (AliasDec, b)
annotate [PatElem dec]
pes forall a b. (a -> b) -> a -> b
$ forall rep dec. Aliased rep => [PatElem dec] -> Exp rep -> [Names]
expAliases [PatElem dec]
pes Exp rep
e
where
annotate :: PatElem b -> Names -> PatElem (AliasDec, b)
annotate (PatElem VName
v b
dec) Names
names = forall dec. VName -> dec -> PatElem dec
PatElem VName
v (Names -> AliasDec
AliasDec Names
names', b
dec)
where
names' :: Names
names' =
case forall t. Typed t => t -> Type
typeOf b
dec of
Array {} -> Names
names
Mem Space
_ -> Names
names
Type
_ -> forall a. Monoid a => a
mempty
mkBodyAliasing ::
Aliased rep =>
Stms rep ->
Result ->
BodyAliasing
mkBodyAliasing :: forall rep. Aliased rep => Stms rep -> Result -> BodyAliasing
mkBodyAliasing Stms rep
stms Result
res =
let ([Names]
aliases, Names
consumed) = forall rep. Aliased rep => Stms rep -> Result -> ([Names], Names)
mkStmsAliases Stms rep
stms Result
res
boundNames :: Names
boundNames = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ([VName] -> Names
namesFromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall dec. Pat dec -> [VName]
patNames forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall rep. Stm rep -> Pat (LetDec rep)
stmPat) Stms rep
stms
consumed' :: Names
consumed' = Names
consumed Names -> Names -> Names
`namesSubtract` Names
boundNames
in (forall a b. (a -> b) -> [a] -> [b]
map Names -> AliasDec
AliasDec [Names]
aliases, Names -> AliasDec
AliasDec Names
consumed')
mkStmsAliases ::
Aliased rep =>
Stms rep ->
Result ->
([Names], Names)
mkStmsAliases :: forall rep. Aliased rep => Stms rep -> Result -> ([Names], Names)
mkStmsAliases Stms rep
stms Result
res = AliasesAndConsumed -> [Stm rep] -> ([Names], Names)
delve forall a. Monoid a => a
mempty forall a b. (a -> b) -> a -> b
$ forall rep. Stms rep -> [Stm rep]
stmsToList Stms rep
stms
where
delve :: AliasesAndConsumed -> [Stm rep] -> ([Names], Names)
delve (Map VName Names
aliasmap, Names
consumed) [] =
( forall a b. (a -> b) -> [a] -> [b]
map (Map VName Names -> Names -> Names
aliasClosure Map VName Names
aliasmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. SubExp -> Names
subExpAliases forall b c a. (b -> c) -> (a -> b) -> a -> c
. SubExpRes -> SubExp
resSubExp) Result
res,
Names
consumed
)
delve (Map VName Names
aliasmap, Names
consumed) (Stm rep
stm : [Stm rep]
stms') =
AliasesAndConsumed -> [Stm rep] -> ([Names], Names)
delve (forall rep.
Aliased rep =>
AliasesAndConsumed -> Stm rep -> AliasesAndConsumed
trackAliases (Map VName Names
aliasmap, Names
consumed) Stm rep
stm) [Stm rep]
stms'
aliasClosure :: Map VName Names -> Names -> Names
aliasClosure Map VName Names
aliasmap Names
names =
Names
names forall a. Semigroup a => a -> a -> a
<> forall a. Monoid a => [a] -> a
mconcat (forall a b. (a -> b) -> [a] -> [b]
map VName -> Names
look forall a b. (a -> b) -> a -> b
$ Names -> [VName]
namesToList Names
names)
where
look :: VName -> Names
look VName
k = forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault forall a. Monoid a => a
mempty VName
k Map VName Names
aliasmap
type AliasesAndConsumed =
( M.Map VName Names,
Names
)
consumedInStms :: Aliased rep => Stms rep -> Names
consumedInStms :: forall rep. Aliased rep => Stms rep -> Names
consumedInStms = forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall rep. Aliased rep => Stms rep -> Result -> ([Names], Names)
mkStmsAliases []
trackAliases ::
Aliased rep =>
AliasesAndConsumed ->
Stm rep ->
AliasesAndConsumed
trackAliases :: forall rep.
Aliased rep =>
AliasesAndConsumed -> Stm rep -> AliasesAndConsumed
trackAliases (Map VName Names
aliasmap, Names
consumed) Stm rep
stm =
let pat :: Pat (LetDec rep)
pat = forall rep. Stm rep -> Pat (LetDec rep)
stmPat Stm rep
stm
pe_als :: [(VName, Names)]
pe_als =
forall a b. [a] -> [b] -> [(a, b)]
zip (forall dec. Pat dec -> [VName]
patNames Pat (LetDec rep)
pat) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Names -> Names
addAliasesOfAliases forall a b. (a -> b) -> a -> b
$ forall dec. AliasesOf dec => Pat dec -> [Names]
patAliases Pat (LetDec rep)
pat
als :: Map VName Names
als = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(VName, Names)]
pe_als
rev_als :: Map VName Names
rev_als = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (VName, Names) -> Map VName Names
revAls [(VName, Names)]
pe_als
revAls :: (VName, Names) -> Map VName Names
revAls (VName
v, Names
v_als) =
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (,VName -> Names
oneName VName
v) forall a b. (a -> b) -> a -> b
$ Names -> [VName]
namesToList Names
v_als
comb :: Map VName Names -> Map VName Names -> Map VName Names
comb = forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith forall a. Semigroup a => a -> a -> a
(<>)
aliasmap' :: Map VName Names
aliasmap' = Map VName Names
rev_als Map VName Names -> Map VName Names -> Map VName Names
`comb` Map VName Names
als Map VName Names -> Map VName Names -> Map VName Names
`comb` Map VName Names
aliasmap
consumed' :: Names
consumed' = Names
consumed forall a. Semigroup a => a -> a -> a
<> Names -> Names
addAliasesOfAliases (forall rep. Aliased rep => Stm rep -> Names
consumedInStm Stm rep
stm)
in (Map VName Names
aliasmap', Names
consumed')
where
addAliasesOfAliases :: Names -> Names
addAliasesOfAliases Names
names = Names
names forall a. Semigroup a => a -> a -> a
<> Names -> Names
aliasesOfAliases Names
names
aliasesOfAliases :: Names -> Names
aliasesOfAliases = forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map VName -> Names
look forall b c a. (b -> c) -> (a -> b) -> a -> c
. Names -> [VName]
namesToList
look :: VName -> Names
look VName
k = forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault forall a. Monoid a => a
mempty VName
k Map VName Names
aliasmap
mkAliasedStm ::
(ASTRep rep, AliasedOp (OpC rep (Aliases rep))) =>
Pat (LetDec rep) ->
StmAux (ExpDec rep) ->
Exp (Aliases rep) ->
Stm (Aliases rep)
mkAliasedStm :: forall rep.
(ASTRep rep, AliasedOp (OpC rep (Aliases rep))) =>
Pat (LetDec rep)
-> StmAux (ExpDec rep) -> Exp (Aliases rep) -> Stm (Aliases rep)
mkAliasedStm Pat (LetDec rep)
pat (StmAux Certs
cs Attrs
attrs ExpDec rep
dec) Exp (Aliases rep)
e =
forall rep.
Pat (LetDec rep) -> StmAux (ExpDec rep) -> Exp rep -> Stm rep
Let
(forall rep dec.
(Aliased rep, Typed dec) =>
Pat dec -> Exp rep -> Pat (AliasDec, dec)
mkAliasedPat Pat (LetDec rep)
pat Exp (Aliases rep)
e)
(forall dec. Certs -> Attrs -> dec -> StmAux dec
StmAux Certs
cs Attrs
attrs (Names -> AliasDec
AliasDec forall a b. (a -> b) -> a -> b
$ forall rep. Aliased rep => Exp rep -> Names
consumedInExp Exp (Aliases rep)
e, ExpDec rep
dec))
Exp (Aliases rep)
e
instance (Buildable rep, AliasedOp (OpC rep (Aliases rep))) => Buildable (Aliases rep) where
mkExpDec :: Pat (LetDec (Aliases rep))
-> Exp (Aliases rep) -> ExpDec (Aliases rep)
mkExpDec Pat (LetDec (Aliases rep))
pat Exp (Aliases rep)
e =
let dec :: ExpDec rep
dec = forall rep.
Buildable rep =>
Pat (LetDec rep) -> Exp rep -> ExpDec rep
mkExpDec (forall a. Pat (AliasDec, a) -> Pat a
removePatAliases Pat (LetDec (Aliases rep))
pat) forall a b. (a -> b) -> a -> b
$ forall rep. RephraseOp (OpC rep) => Exp (Aliases rep) -> Exp rep
removeExpAliases Exp (Aliases rep)
e
in (Names -> AliasDec
AliasDec forall a b. (a -> b) -> a -> b
$ forall rep. Aliased rep => Exp rep -> Names
consumedInExp Exp (Aliases rep)
e, ExpDec rep
dec)
mkExpPat :: [Ident] -> Exp (Aliases rep) -> Pat (LetDec (Aliases rep))
mkExpPat [Ident]
ids Exp (Aliases rep)
e =
forall rep dec.
(Aliased rep, Typed dec) =>
Pat dec -> Exp rep -> Pat (AliasDec, dec)
mkAliasedPat (forall rep. Buildable rep => [Ident] -> Exp rep -> Pat (LetDec rep)
mkExpPat [Ident]
ids forall a b. (a -> b) -> a -> b
$ forall rep. RephraseOp (OpC rep) => Exp (Aliases rep) -> Exp rep
removeExpAliases Exp (Aliases rep)
e) Exp (Aliases rep)
e
mkLetNames :: forall (m :: * -> *).
(MonadFreshNames m, HasScope (Aliases rep) m) =>
[VName] -> Exp (Aliases rep) -> m (Stm (Aliases rep))
mkLetNames [VName]
names Exp (Aliases rep)
e = do
Scope rep
env <- forall rep (m :: * -> *) a.
HasScope rep m =>
(Scope rep -> a) -> m a
asksScope forall rep. Scope (Aliases rep) -> Scope rep
removeScopeAliases
forall a b c. (a -> b -> c) -> b -> a -> c
flip forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT Scope rep
env forall a b. (a -> b) -> a -> b
$ do
Let Pat (LetDec rep)
pat StmAux (ExpDec rep)
dec Exp rep
_ <- forall rep (m :: * -> *).
(Buildable rep, MonadFreshNames m, HasScope rep m) =>
[VName] -> Exp rep -> m (Stm rep)
mkLetNames [VName]
names forall a b. (a -> b) -> a -> b
$ forall rep. RephraseOp (OpC rep) => Exp (Aliases rep) -> Exp rep
removeExpAliases Exp (Aliases rep)
e
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall rep.
(ASTRep rep, AliasedOp (OpC rep (Aliases rep))) =>
Pat (LetDec rep)
-> StmAux (ExpDec rep) -> Exp (Aliases rep) -> Stm (Aliases rep)
mkAliasedStm Pat (LetDec rep)
pat StmAux (ExpDec rep)
dec Exp (Aliases rep)
e
mkBody :: Stms (Aliases rep) -> Result -> Body (Aliases rep)
mkBody Stms (Aliases rep)
stms Result
res =
let Body BodyDec rep
bodyrep Stms rep
_ Result
_ = forall rep. Buildable rep => Stms rep -> Result -> Body rep
mkBody (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall rep. RephraseOp (OpC rep) => Stm (Aliases rep) -> Stm rep
removeStmAliases Stms (Aliases rep)
stms) Result
res
in forall rep.
(ASTRep rep, AliasedOp (OpC rep (Aliases rep))) =>
BodyDec rep -> Stms (Aliases rep) -> Result -> Body (Aliases rep)
mkAliasedBody BodyDec rep
bodyrep Stms (Aliases rep)
stms Result
res
instance
( ASTRep rep,
AliasedOp (OpC rep (Aliases rep)),
Buildable (Aliases rep)
) =>
BuilderOps (Aliases rep)
type AliasableRep rep =
( ASTRep rep,
RephraseOp (OpC rep),
CanBeAliased (OpC rep),
AliasedOp (OpC rep (Aliases rep))
)
class CanBeAliased op where
addOpAliases ::
AliasableRep rep => AliasTable -> op rep -> op (Aliases rep)
instance CanBeAliased NoOp where
addOpAliases :: forall rep.
AliasableRep rep =>
Map VName Names -> NoOp rep -> NoOp (Aliases rep)
addOpAliases Map VName Names
_ NoOp rep
NoOp = forall {k} (rep :: k). NoOp rep
NoOp