{-# 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,
removeProgAliases,
removeFunDefAliases,
removeExpAliases,
removeStmAliases,
removeBodyAliases,
removeLambdaAliases,
removePatAliases,
removeScopeAliases,
AliasesAndConsumed,
trackAliases,
mkStmsAliases,
consumedInStms,
)
where
import Control.Monad.Identity
import Control.Monad.Reader
import Data.Map.Strict qualified as M
import Data.Maybe
import Futhark.Analysis.Rephrase
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
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, CanBeAliased (Op 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 Op (Aliases rep) = OpWithAliases (Op 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 {k} (rep :: k) (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 {k} (rep :: k) (m :: * -> *) a.
HasScope rep m =>
(Scope rep -> a) -> m a
asksScope forall {k} (rep :: k). 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, CanBeAliased (Op rep)) => ASTRep (Aliases rep) where
expTypesFromPat :: forall (m :: * -> *).
(HasScope (Aliases rep) m, Monad m) =>
Pat (LetDec (Aliases rep)) -> m [BranchType (Aliases rep)]
expTypesFromPat =
forall {k} (rep :: k) (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 {k} (rep :: k) (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, CanBeAliased (Op 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 {k} (rep :: k). 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 {k} (rep :: k). Body rep -> BodyDec rep
bodyDec
instance (ASTRep rep, CanBeAliased (Op 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 {k} (rep :: k) a.
PrettyRep rep =>
ExpDec rep -> Exp rep -> Maybe (Doc a)
ppExpDec ExpDec rep
inner forall a b. (a -> b) -> a -> b
$ forall {k} (rep :: k).
CanBeAliased (Op 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 {k} (rep :: k). 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 :: CanBeAliased (Op rep) => Rephraser Identity (Aliases rep) rep
removeAliases :: forall {k1} (rep :: k1).
CanBeAliased (Op 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 (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall op. CanBeAliased op => OpWithAliases op -> op
removeOpAliases
}
removeScopeAliases :: Scope (Aliases rep) -> Scope rep
removeScopeAliases :: forall {k} (rep :: k). Scope (Aliases rep) -> Scope rep
removeScopeAliases = forall a b k. (a -> b) -> Map k a -> Map k b
M.map forall {k} {k} {rep :: k} {rep :: k} {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 {k} (rep :: k). LetDec rep -> NameInfo rep
LetName LetDec rep
dec
unAlias (FParamName FParamInfo rep
dec) = forall {k} (rep :: k). FParamInfo rep -> NameInfo rep
FParamName FParamInfo rep
dec
unAlias (LParamName LParamInfo rep
dec) = forall {k} (rep :: k). LParamInfo rep -> NameInfo rep
LParamName LParamInfo rep
dec
unAlias (IndexName IntType
it) = forall {k} (rep :: k). IntType -> NameInfo rep
IndexName IntType
it
removeProgAliases ::
CanBeAliased (Op rep) =>
Prog (Aliases rep) ->
Prog rep
removeProgAliases :: forall {k} (rep :: k).
CanBeAliased (Op rep) =>
Prog (Aliases rep) -> Prog rep
removeProgAliases = forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k1} {k2} (m :: * -> *) (from :: k1) (to :: k2).
Monad m =>
Rephraser m from to -> Prog from -> m (Prog to)
rephraseProg forall {k1} (rep :: k1).
CanBeAliased (Op rep) =>
Rephraser Identity (Aliases rep) rep
removeAliases
removeFunDefAliases ::
CanBeAliased (Op rep) =>
FunDef (Aliases rep) ->
FunDef rep
removeFunDefAliases :: forall {k} (rep :: k).
CanBeAliased (Op rep) =>
FunDef (Aliases rep) -> FunDef rep
removeFunDefAliases = forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k1} {k2} (m :: * -> *) (from :: k1) (to :: k2).
Monad m =>
Rephraser m from to -> FunDef from -> m (FunDef to)
rephraseFunDef forall {k1} (rep :: k1).
CanBeAliased (Op rep) =>
Rephraser Identity (Aliases rep) rep
removeAliases
removeExpAliases ::
CanBeAliased (Op rep) =>
Exp (Aliases rep) ->
Exp rep
removeExpAliases :: forall {k} (rep :: k).
CanBeAliased (Op rep) =>
Exp (Aliases rep) -> Exp rep
removeExpAliases = forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k1} {k2} (m :: * -> *) (from :: k1) (to :: k2).
Monad m =>
Rephraser m from to -> Exp from -> m (Exp to)
rephraseExp forall {k1} (rep :: k1).
CanBeAliased (Op rep) =>
Rephraser Identity (Aliases rep) rep
removeAliases
removeStmAliases ::
CanBeAliased (Op rep) =>
Stm (Aliases rep) ->
Stm rep
removeStmAliases :: forall {k} (rep :: k).
CanBeAliased (Op rep) =>
Stm (Aliases rep) -> Stm rep
removeStmAliases = forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k1} {k2} (m :: * -> *) (from :: k1) (to :: k2).
Monad m =>
Rephraser m from to -> Stm from -> m (Stm to)
rephraseStm forall {k1} (rep :: k1).
CanBeAliased (Op rep) =>
Rephraser Identity (Aliases rep) rep
removeAliases
removeBodyAliases ::
CanBeAliased (Op rep) =>
Body (Aliases rep) ->
Body rep
removeBodyAliases :: forall {k} (rep :: k).
CanBeAliased (Op rep) =>
Body (Aliases rep) -> Body rep
removeBodyAliases = forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k1} {k2} (m :: * -> *) (from :: k1) (to :: k2).
Monad m =>
Rephraser m from to -> Body from -> m (Body to)
rephraseBody forall {k1} (rep :: k1).
CanBeAliased (Op rep) =>
Rephraser Identity (Aliases rep) rep
removeAliases
removeLambdaAliases ::
CanBeAliased (Op rep) =>
Lambda (Aliases rep) ->
Lambda rep
removeLambdaAliases :: forall {k} (rep :: k).
CanBeAliased (Op rep) =>
Lambda (Aliases rep) -> Lambda rep
removeLambdaAliases = forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k1} {k2} (m :: * -> *) (from :: k1) (to :: k2).
Monad m =>
Rephraser m from to -> Lambda from -> m (Lambda to)
rephraseLambda forall {k1} (rep :: k1).
CanBeAliased (Op 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, CanBeAliased (Op rep)) =>
BodyDec rep ->
Stms (Aliases rep) ->
Result ->
Body (Aliases rep)
mkAliasedBody :: forall {k} (rep :: k).
(ASTRep rep, CanBeAliased (Op rep)) =>
BodyDec rep -> Stms (Aliases rep) -> Result -> Body (Aliases rep)
mkAliasedBody BodyDec rep
dec Stms (Aliases rep)
stms Result
res =
forall {k} (rep :: k).
BodyDec rep -> Stms rep -> Result -> Body rep
Body (forall {k} (rep :: k).
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 {k} (rep :: k) dec.
(Aliased rep, Typed dec) =>
Pat dec -> Exp rep -> Pat (AliasDec, dec)
mkAliasedPat Pat dec
pat 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)
annotatePatElem (forall dec. Pat dec -> [PatElem dec]
patElems Pat dec
pat) [Names]
als
where
als :: [Names]
als = forall {k} (rep :: k). Aliased rep => Exp rep -> [Names]
expAliases Exp rep
e forall a. [a] -> [a] -> [a]
++ forall a. a -> [a]
repeat forall a. Monoid a => a
mempty
annotatePatElem :: PatElem b -> Names -> PatElem (AliasDec, b)
annotatePatElem PatElem b
bindee Names
names =
PatElem b
bindee forall oldattr newattr.
PatElem oldattr -> newattr -> PatElem newattr
`setPatElemDec` (Names -> AliasDec
AliasDec Names
names', forall dec. PatElem dec -> dec
patElemDec PatElem b
bindee)
where
names' :: Names
names' =
case forall dec. Typed dec => PatElem dec -> Type
patElemType PatElem b
bindee of
Array {} -> Names
names
Mem Space
_ -> Names
names
Type
_ -> forall a. Monoid a => a
mempty
mkBodyAliasing ::
Aliased rep =>
Stms rep ->
Result ->
BodyAliasing
mkBodyAliasing :: forall {k} (rep :: k).
Aliased rep =>
Stms rep -> Result -> BodyAliasing
mkBodyAliasing Stms rep
stms Result
res =
let ([Names]
aliases, Names
consumed) = forall {k} (rep :: k).
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 {k} (rep :: k). Stm rep -> Pat (LetDec rep)
stmPat) Stms rep
stms
aliases' :: [Names]
aliases' = forall a b. (a -> b) -> [a] -> [b]
map (Names -> Names -> Names
`namesSubtract` Names
boundNames) [Names]
aliases
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 {k} (rep :: k).
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 {k} (rep :: k). 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 {k} (rep :: k).
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 {k} (rep :: k). 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 {k} (rep :: k).
Aliased rep =>
Stms rep -> Result -> ([Names], Names)
mkStmsAliases []
trackAliases ::
Aliased rep =>
AliasesAndConsumed ->
Stm rep ->
AliasesAndConsumed
trackAliases :: forall {k} (rep :: k).
Aliased rep =>
AliasesAndConsumed -> Stm rep -> AliasesAndConsumed
trackAliases (Map VName Names
aliasmap, Names
consumed) Stm rep
stm =
let pat :: Pat (LetDec rep)
pat = forall {k} (rep :: k). 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 {k} (rep :: k). 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, CanBeAliased (Op rep)) =>
Pat (LetDec rep) ->
StmAux (ExpDec rep) ->
Exp (Aliases rep) ->
Stm (Aliases rep)
mkAliasedStm :: forall {k} (rep :: k).
(ASTRep rep, CanBeAliased (Op 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 {k} (rep :: k).
Pat (LetDec rep) -> StmAux (ExpDec rep) -> Exp rep -> Stm rep
Let
(forall {k} (rep :: k) 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 {k} (rep :: k). Aliased rep => Exp rep -> Names
consumedInExp Exp (Aliases rep)
e, ExpDec rep
dec))
Exp (Aliases rep)
e
instance (Buildable rep, CanBeAliased (Op 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 {k} (rep :: k).
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 {k} (rep :: k).
CanBeAliased (Op rep) =>
Exp (Aliases rep) -> Exp rep
removeExpAliases Exp (Aliases rep)
e
in (Names -> AliasDec
AliasDec forall a b. (a -> b) -> a -> b
$ forall {k} (rep :: k). 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 {k} (rep :: k) dec.
(Aliased rep, Typed dec) =>
Pat dec -> Exp rep -> Pat (AliasDec, dec)
mkAliasedPat (forall {k} (rep :: k).
Buildable rep =>
[Ident] -> Exp rep -> Pat (LetDec rep)
mkExpPat [Ident]
ids forall a b. (a -> b) -> a -> b
$ forall {k} (rep :: k).
CanBeAliased (Op 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 {k} (rep :: k) (m :: * -> *) a.
HasScope rep m =>
(Scope rep -> a) -> m a
asksScope forall {k} (rep :: k). 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 {k} (rep :: k) (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 {k} (rep :: k).
CanBeAliased (Op 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 {k} (rep :: k).
(ASTRep rep, CanBeAliased (Op 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 {k} (rep :: k).
Buildable rep =>
Stms rep -> Result -> Body rep
mkBody (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {k} (rep :: k).
CanBeAliased (Op rep) =>
Stm (Aliases rep) -> Stm rep
removeStmAliases Stms (Aliases rep)
stms) Result
res
in forall {k} (rep :: k).
(ASTRep rep, CanBeAliased (Op rep)) =>
BodyDec rep -> Stms (Aliases rep) -> Result -> Body (Aliases rep)
mkAliasedBody BodyDec rep
bodyrep Stms (Aliases rep)
stms Result
res
instance
( ASTRep rep,
CanBeAliased (Op rep),
Buildable (Aliases rep)
) =>
BuilderOps (Aliases rep)