{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
{-# 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,
addAliasesToPattern,
mkAliasedLetStm,
mkAliasedBody,
mkPatternAliases,
mkBodyAliases,
removeProgAliases,
removeFunDefAliases,
removeExpAliases,
removeStmAliases,
removeLambdaAliases,
removePatternAliases,
removeScopeAliases,
AliasesAndConsumed,
trackAliases,
mkStmsAliases,
)
where
import Control.Monad.Identity
import Control.Monad.Reader
import qualified Data.Map.Strict as M
import Data.Maybe
import Futhark.Analysis.Rephrase
import Futhark.Binder
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 qualified Futhark.Util.Pretty as PP
data Aliases rep
newtype AliasDec = AliasDec {AliasDec -> Names
unAliases :: Names}
deriving (Int -> AliasDec -> ShowS
[AliasDec] -> ShowS
AliasDec -> String
(Int -> AliasDec -> ShowS)
-> (AliasDec -> String) -> ([AliasDec] -> ShowS) -> Show AliasDec
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 (Names -> AliasDec) -> Names -> AliasDec
forall a b. (a -> b) -> a -> b
$ AliasDec -> Names
unAliases AliasDec
x Names -> Names -> Names
forall a. Semigroup a => a -> a -> a
<> AliasDec -> Names
unAliases AliasDec
y
instance Monoid AliasDec where
mempty :: AliasDec
mempty = Names -> AliasDec
AliasDec Names
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 (Names -> AliasDec) -> RenameM Names -> RenameM AliasDec
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Names -> RenameM Names
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 (Names -> AliasDec) -> Names -> AliasDec
forall a b. (a -> b) -> a -> b
$ Map VName VName -> Names -> Names
forall a. Substitute a => Map VName VName -> a -> a
substituteNames Map VName VName
substs Names
names
instance FreeIn AliasDec where
freeIn' :: AliasDec -> FV
freeIn' = FV -> AliasDec -> FV
forall a b. a -> b -> a
const FV
forall a. Monoid a => a
mempty
instance PP.Pretty AliasDec where
ppr :: AliasDec -> Doc
ppr = Doc -> Doc
PP.braces (Doc -> Doc) -> (AliasDec -> Doc) -> AliasDec -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc] -> Doc
PP.commasep ([Doc] -> Doc) -> (AliasDec -> [Doc]) -> AliasDec -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (VName -> Doc) -> [VName] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map VName -> Doc
forall a. Pretty a => a -> Doc
PP.ppr ([VName] -> [Doc]) -> (AliasDec -> [VName]) -> AliasDec -> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Names -> [VName]
namesToList (Names -> [VName]) -> (AliasDec -> Names) -> AliasDec -> [VName]
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 (AliasDec -> Names)
-> ((AliasDec, dec) -> AliasDec) -> (AliasDec, dec) -> Names
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AliasDec, dec) -> AliasDec
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 <- (Scope (Aliases rep) -> Scope rep) -> m (Scope rep)
forall rep (m :: * -> *) a.
HasScope rep m =>
(Scope rep -> a) -> m a
asksScope Scope (Aliases rep) -> Scope rep
forall rep. Scope (Aliases rep) -> Scope rep
removeScopeAliases
ReaderT (Scope rep) m a -> Scope rep -> m a
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
expTypesFromPattern :: forall (m :: * -> *).
(HasScope (Aliases rep) m, Monad m) =>
Pattern (Aliases rep) -> m [BranchType (Aliases rep)]
expTypesFromPattern =
ReaderT (Scope rep) m [BranchType rep] -> m [BranchType rep]
forall rep (m :: * -> *) a.
(HasScope (Aliases rep) m, Monad m) =>
ReaderT (Scope rep) m a -> m a
withoutAliases (ReaderT (Scope rep) m [BranchType rep] -> m [BranchType rep])
-> (PatternT (AliasDec, LetDec rep)
-> ReaderT (Scope rep) m [BranchType rep])
-> PatternT (AliasDec, LetDec rep)
-> m [BranchType rep]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatternT (LetDec rep) -> ReaderT (Scope rep) m [BranchType rep]
forall rep (m :: * -> *).
(ASTRep rep, HasScope rep m, Monad m) =>
Pattern rep -> m [BranchType rep]
expTypesFromPattern (PatternT (LetDec rep) -> ReaderT (Scope rep) m [BranchType rep])
-> (PatternT (AliasDec, LetDec rep) -> PatternT (LetDec rep))
-> PatternT (AliasDec, LetDec rep)
-> ReaderT (Scope rep) m [BranchType rep]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatternT (AliasDec, LetDec rep) -> PatternT (LetDec rep)
forall a. PatternT (AliasDec, a) -> PatternT a
removePatternAliases
instance (ASTRep rep, CanBeAliased (Op rep)) => Aliased (Aliases rep) where
bodyAliases :: Body (Aliases rep) -> [Names]
bodyAliases = (AliasDec -> Names) -> [AliasDec] -> [Names]
forall a b. (a -> b) -> [a] -> [b]
map AliasDec -> Names
unAliases ([AliasDec] -> [Names])
-> (Body (Aliases rep) -> [AliasDec])
-> Body (Aliases rep)
-> [Names]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BodyAliasing -> [AliasDec]
forall a b. (a, b) -> a
fst (BodyAliasing -> [AliasDec])
-> (Body (Aliases rep) -> BodyAliasing)
-> Body (Aliases rep)
-> [AliasDec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (BodyAliasing, BodyDec rep) -> BodyAliasing
forall a b. (a, b) -> a
fst ((BodyAliasing, BodyDec rep) -> BodyAliasing)
-> (Body (Aliases rep) -> (BodyAliasing, BodyDec rep))
-> Body (Aliases rep)
-> BodyAliasing
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Body (Aliases rep) -> (BodyAliasing, BodyDec rep)
forall rep. BodyT rep -> BodyDec rep
bodyDec
consumedInBody :: Body (Aliases rep) -> Names
consumedInBody = AliasDec -> Names
unAliases (AliasDec -> Names)
-> (Body (Aliases rep) -> AliasDec) -> Body (Aliases rep) -> Names
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BodyAliasing -> AliasDec
forall a b. (a, b) -> b
snd (BodyAliasing -> AliasDec)
-> (Body (Aliases rep) -> BodyAliasing)
-> Body (Aliases rep)
-> AliasDec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (BodyAliasing, BodyDec rep) -> BodyAliasing
forall a b. (a, b) -> a
fst ((BodyAliasing, BodyDec rep) -> BodyAliasing)
-> (Body (Aliases rep) -> (BodyAliasing, BodyDec rep))
-> Body (Aliases rep)
-> BodyAliasing
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Body (Aliases rep) -> (BodyAliasing, BodyDec rep)
forall rep. BodyT rep -> BodyDec rep
bodyDec
instance (ASTRep rep, CanBeAliased (Op rep)) => PrettyRep (Aliases rep) where
ppExpDec :: ExpDec (Aliases rep) -> Exp (Aliases rep) -> Maybe Doc
ppExpDec (AliasDec
consumed, ExpDec rep
inner) Exp (Aliases rep)
e =
[Doc] -> Maybe Doc
maybeComment ([Doc] -> Maybe Doc) -> [Doc] -> Maybe Doc
forall a b. (a -> b) -> a -> b
$
[Maybe Doc] -> [Doc]
forall a. [Maybe a] -> [a]
catMaybes
[ Maybe Doc
exp_dec,
Maybe Doc
merge_dec,
ExpDec rep -> Exp rep -> Maybe Doc
forall rep. PrettyRep rep => ExpDec rep -> Exp rep -> Maybe Doc
ppExpDec ExpDec rep
inner (Exp rep -> Maybe Doc) -> Exp rep -> Maybe Doc
forall a b. (a -> b) -> a -> b
$ Exp (Aliases rep) -> Exp rep
forall rep. CanBeAliased (Op rep) => Exp (Aliases rep) -> Exp rep
removeExpAliases Exp (Aliases rep)
e
]
where
merge_dec :: Maybe Doc
merge_dec =
case Exp (Aliases rep)
e of
DoLoop [(FParam (Aliases rep), SubExp)]
_ [(FParam (Aliases rep), SubExp)]
merge LoopForm (Aliases rep)
_ BodyT (Aliases rep)
body ->
let mergeParamAliases :: Param dec -> Names -> Maybe Doc
mergeParamAliases Param dec
fparam Names
als
| TypeBase Shape NoUniqueness -> Bool
forall shape u. TypeBase shape u -> Bool
primType (Param dec -> TypeBase Shape NoUniqueness
forall dec. Typed dec => Param dec -> TypeBase Shape NoUniqueness
paramType Param dec
fparam) =
Maybe Doc
forall a. Maybe a
Nothing
| Bool
otherwise =
VName -> Names -> Maybe Doc
forall a. Pretty a => a -> Names -> Maybe Doc
resultAliasComment (Param dec -> VName
forall dec. Param dec -> VName
paramName Param dec
fparam) Names
als
in [Doc] -> Maybe Doc
maybeComment ([Doc] -> Maybe Doc) -> [Doc] -> Maybe Doc
forall a b. (a -> b) -> a -> b
$
[Maybe Doc] -> [Doc]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe Doc] -> [Doc]) -> [Maybe Doc] -> [Doc]
forall a b. (a -> b) -> a -> b
$
(Param (FParamInfo rep) -> Names -> Maybe Doc)
-> [Param (FParamInfo rep)] -> [Names] -> [Maybe Doc]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Param (FParamInfo rep) -> Names -> Maybe Doc
forall {dec}. Typed dec => Param dec -> Names -> Maybe Doc
mergeParamAliases (((Param (FParamInfo rep), SubExp) -> Param (FParamInfo rep))
-> [(Param (FParamInfo rep), SubExp)] -> [Param (FParamInfo rep)]
forall a b. (a -> b) -> [a] -> [b]
map (Param (FParamInfo rep), SubExp) -> Param (FParamInfo rep)
forall a b. (a, b) -> a
fst [(Param (FParamInfo rep), SubExp)]
[(FParam (Aliases rep), SubExp)]
merge) ([Names] -> [Maybe Doc]) -> [Names] -> [Maybe Doc]
forall a b. (a -> b) -> a -> b
$
BodyT (Aliases rep) -> [Names]
forall rep. Aliased rep => Body rep -> [Names]
bodyAliases BodyT (Aliases rep)
body
Exp (Aliases rep)
_ -> Maybe Doc
forall a. Maybe a
Nothing
exp_dec :: Maybe Doc
exp_dec = case Names -> [VName]
namesToList (Names -> [VName]) -> Names -> [VName]
forall a b. (a -> b) -> a -> b
$ AliasDec -> Names
unAliases AliasDec
consumed of
[] -> Maybe Doc
forall a. Maybe a
Nothing
[VName]
als ->
Doc -> Maybe Doc
forall a. a -> Maybe a
Just (Doc -> Maybe Doc) -> Doc -> Maybe Doc
forall a b. (a -> b) -> a -> b
$
Doc -> Doc
PP.oneLine (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
String -> Doc
PP.text String
"-- Consumes " Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> [Doc] -> Doc
PP.commasep ((VName -> Doc) -> [VName] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map VName -> Doc
forall a. Pretty a => a -> Doc
PP.ppr [VName]
als)
maybeComment :: [PP.Doc] -> Maybe PP.Doc
[] = Maybe Doc
forall a. Maybe a
Nothing
maybeComment [Doc]
cs = Doc -> Maybe Doc
forall a. a -> Maybe a
Just (Doc -> Maybe Doc) -> Doc -> Maybe Doc
forall a b. (a -> b) -> a -> b
$ (Doc -> Doc -> Doc) -> [Doc] -> Doc
PP.folddoc Doc -> Doc -> Doc
(PP.</>) [Doc]
cs
resultAliasComment :: PP.Pretty a => a -> Names -> Maybe PP.Doc
a
name Names
als =
case Names -> [VName]
namesToList Names
als of
[] -> Maybe Doc
forall a. Maybe a
Nothing
[VName]
als' ->
Doc -> Maybe Doc
forall a. a -> Maybe a
Just (Doc -> Maybe Doc) -> Doc -> Maybe Doc
forall a b. (a -> b) -> a -> b
$
Doc -> Doc
PP.oneLine (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
String -> Doc
PP.text String
"-- Result of " Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> a -> Doc
forall a. Pretty a => a -> Doc
PP.ppr a
name Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> String -> Doc
PP.text String
" aliases "
Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> [Doc] -> Doc
PP.commasep ((VName -> Doc) -> [VName] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map VName -> Doc
forall a. Pretty a => a -> Doc
PP.ppr [VName]
als')
removeAliases :: CanBeAliased (Op rep) => Rephraser Identity (Aliases rep) rep
removeAliases :: forall rep.
CanBeAliased (Op rep) =>
Rephraser Identity (Aliases rep) rep
removeAliases =
Rephraser :: forall (m :: * -> *) from to.
(ExpDec from -> m (ExpDec to))
-> (LetDec from -> m (LetDec to))
-> (FParamInfo from -> m (FParamInfo to))
-> (LParamInfo from -> m (LParamInfo to))
-> (BodyDec from -> m (BodyDec to))
-> (RetType from -> m (RetType to))
-> (BranchType from -> m (BranchType to))
-> (Op from -> m (Op to))
-> Rephraser m from to
Rephraser
{ rephraseExpDec :: ExpDec (Aliases rep) -> Identity (ExpDec rep)
rephraseExpDec = ExpDec rep -> Identity (ExpDec rep)
forall (m :: * -> *) a. Monad m => a -> m a
return (ExpDec rep -> Identity (ExpDec rep))
-> ((AliasDec, ExpDec rep) -> ExpDec rep)
-> (AliasDec, ExpDec rep)
-> Identity (ExpDec rep)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AliasDec, ExpDec rep) -> ExpDec rep
forall a b. (a, b) -> b
snd,
rephraseLetBoundDec :: LetDec (Aliases rep) -> Identity (LetDec rep)
rephraseLetBoundDec = LetDec rep -> Identity (LetDec rep)
forall (m :: * -> *) a. Monad m => a -> m a
return (LetDec rep -> Identity (LetDec rep))
-> ((AliasDec, LetDec rep) -> LetDec rep)
-> (AliasDec, LetDec rep)
-> Identity (LetDec rep)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AliasDec, LetDec rep) -> LetDec rep
forall a b. (a, b) -> b
snd,
rephraseBodyDec :: BodyDec (Aliases rep) -> Identity (BodyDec rep)
rephraseBodyDec = BodyDec rep -> Identity (BodyDec rep)
forall (m :: * -> *) a. Monad m => a -> m a
return (BodyDec rep -> Identity (BodyDec rep))
-> ((BodyAliasing, BodyDec rep) -> BodyDec rep)
-> (BodyAliasing, BodyDec rep)
-> Identity (BodyDec rep)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (BodyAliasing, BodyDec rep) -> BodyDec rep
forall a b. (a, b) -> b
snd,
rephraseFParamDec :: FParamInfo (Aliases rep) -> Identity (FParamInfo rep)
rephraseFParamDec = FParamInfo (Aliases rep) -> Identity (FParamInfo rep)
forall (m :: * -> *) a. Monad m => a -> m a
return,
rephraseLParamDec :: LParamInfo (Aliases rep) -> Identity (LParamInfo rep)
rephraseLParamDec = LParamInfo (Aliases rep) -> Identity (LParamInfo rep)
forall (m :: * -> *) a. Monad m => a -> m a
return,
rephraseRetType :: RetType (Aliases rep) -> Identity (RetType rep)
rephraseRetType = RetType (Aliases rep) -> Identity (RetType rep)
forall (m :: * -> *) a. Monad m => a -> m a
return,
rephraseBranchType :: BranchType (Aliases rep) -> Identity (BranchType rep)
rephraseBranchType = BranchType (Aliases rep) -> Identity (BranchType rep)
forall (m :: * -> *) a. Monad m => a -> m a
return,
rephraseOp :: Op (Aliases rep) -> Identity (Op rep)
rephraseOp = Op rep -> Identity (Op rep)
forall (m :: * -> *) a. Monad m => a -> m a
return (Op rep -> Identity (Op rep))
-> (OpWithAliases (Op rep) -> Op rep)
-> OpWithAliases (Op rep)
-> Identity (Op rep)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OpWithAliases (Op rep) -> Op rep
forall op. CanBeAliased op => OpWithAliases op -> op
removeOpAliases
}
removeScopeAliases :: Scope (Aliases rep) -> Scope rep
removeScopeAliases :: forall rep. Scope (Aliases rep) -> Scope rep
removeScopeAliases = (NameInfo (Aliases rep) -> NameInfo rep)
-> Map VName (NameInfo (Aliases rep)) -> Map VName (NameInfo rep)
forall a b k. (a -> b) -> Map k a -> Map k b
M.map NameInfo (Aliases rep) -> NameInfo rep
forall {rep} {a} {rep}.
(LetDec rep ~ (a, LetDec rep), FParamInfo rep ~ FParamInfo rep,
LParamInfo rep ~ LParamInfo rep) =>
NameInfo rep -> NameInfo rep
unAlias
where
unAlias :: NameInfo rep -> NameInfo rep
unAlias (LetName (a
_, LetDec rep
dec)) = LetDec rep -> NameInfo rep
forall rep. LetDec rep -> NameInfo rep
LetName LetDec rep
dec
unAlias (FParamName FParamInfo rep
dec) = FParamInfo rep -> NameInfo rep
forall rep. FParamInfo rep -> NameInfo rep
FParamName FParamInfo rep
FParamInfo rep
dec
unAlias (LParamName LParamInfo rep
dec) = LParamInfo rep -> NameInfo rep
forall rep. LParamInfo rep -> NameInfo rep
LParamName LParamInfo rep
LParamInfo rep
dec
unAlias (IndexName IntType
it) = IntType -> NameInfo rep
forall rep. IntType -> NameInfo rep
IndexName IntType
it
removeProgAliases ::
CanBeAliased (Op rep) =>
Prog (Aliases rep) ->
Prog rep
removeProgAliases :: forall rep. CanBeAliased (Op rep) => Prog (Aliases rep) -> Prog rep
removeProgAliases = Identity (Prog rep) -> Prog rep
forall a. Identity a -> a
runIdentity (Identity (Prog rep) -> Prog rep)
-> (Prog (Aliases rep) -> Identity (Prog rep))
-> Prog (Aliases rep)
-> Prog rep
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rephraser Identity (Aliases rep) rep
-> Prog (Aliases rep) -> Identity (Prog rep)
forall (m :: * -> *) from to.
Monad m =>
Rephraser m from to -> Prog from -> m (Prog to)
rephraseProg Rephraser Identity (Aliases rep) rep
forall rep.
CanBeAliased (Op rep) =>
Rephraser Identity (Aliases rep) rep
removeAliases
removeFunDefAliases ::
CanBeAliased (Op rep) =>
FunDef (Aliases rep) ->
FunDef rep
removeFunDefAliases :: forall rep.
CanBeAliased (Op rep) =>
FunDef (Aliases rep) -> FunDef rep
removeFunDefAliases = Identity (FunDef rep) -> FunDef rep
forall a. Identity a -> a
runIdentity (Identity (FunDef rep) -> FunDef rep)
-> (FunDef (Aliases rep) -> Identity (FunDef rep))
-> FunDef (Aliases rep)
-> FunDef rep
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rephraser Identity (Aliases rep) rep
-> FunDef (Aliases rep) -> Identity (FunDef rep)
forall (m :: * -> *) from to.
Monad m =>
Rephraser m from to -> FunDef from -> m (FunDef to)
rephraseFunDef Rephraser Identity (Aliases rep) rep
forall rep.
CanBeAliased (Op rep) =>
Rephraser Identity (Aliases rep) rep
removeAliases
removeExpAliases ::
CanBeAliased (Op rep) =>
Exp (Aliases rep) ->
Exp rep
removeExpAliases :: forall rep. CanBeAliased (Op rep) => Exp (Aliases rep) -> Exp rep
removeExpAliases = Identity (Exp rep) -> Exp rep
forall a. Identity a -> a
runIdentity (Identity (Exp rep) -> Exp rep)
-> (Exp (Aliases rep) -> Identity (Exp rep))
-> Exp (Aliases rep)
-> Exp rep
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rephraser Identity (Aliases rep) rep
-> Exp (Aliases rep) -> Identity (Exp rep)
forall (m :: * -> *) from to.
Monad m =>
Rephraser m from to -> Exp from -> m (Exp to)
rephraseExp Rephraser Identity (Aliases rep) rep
forall rep.
CanBeAliased (Op rep) =>
Rephraser Identity (Aliases rep) rep
removeAliases
removeStmAliases ::
CanBeAliased (Op rep) =>
Stm (Aliases rep) ->
Stm rep
removeStmAliases :: forall rep. CanBeAliased (Op rep) => Stm (Aliases rep) -> Stm rep
removeStmAliases = Identity (Stm rep) -> Stm rep
forall a. Identity a -> a
runIdentity (Identity (Stm rep) -> Stm rep)
-> (Stm (Aliases rep) -> Identity (Stm rep))
-> Stm (Aliases rep)
-> Stm rep
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rephraser Identity (Aliases rep) rep
-> Stm (Aliases rep) -> Identity (Stm rep)
forall (m :: * -> *) from to.
Monad m =>
Rephraser m from to -> Stm from -> m (Stm to)
rephraseStm Rephraser Identity (Aliases rep) rep
forall rep.
CanBeAliased (Op rep) =>
Rephraser Identity (Aliases rep) rep
removeAliases
removeLambdaAliases ::
CanBeAliased (Op rep) =>
Lambda (Aliases rep) ->
Lambda rep
removeLambdaAliases :: forall rep.
CanBeAliased (Op rep) =>
Lambda (Aliases rep) -> Lambda rep
removeLambdaAliases = Identity (Lambda rep) -> Lambda rep
forall a. Identity a -> a
runIdentity (Identity (Lambda rep) -> Lambda rep)
-> (Lambda (Aliases rep) -> Identity (Lambda rep))
-> Lambda (Aliases rep)
-> Lambda rep
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rephraser Identity (Aliases rep) rep
-> Lambda (Aliases rep) -> Identity (Lambda rep)
forall (m :: * -> *) from to.
Monad m =>
Rephraser m from to -> Lambda from -> m (Lambda to)
rephraseLambda Rephraser Identity (Aliases rep) rep
forall rep.
CanBeAliased (Op rep) =>
Rephraser Identity (Aliases rep) rep
removeAliases
removePatternAliases ::
PatternT (AliasDec, a) ->
PatternT a
removePatternAliases :: forall a. PatternT (AliasDec, a) -> PatternT a
removePatternAliases = Identity (PatternT a) -> PatternT a
forall a. Identity a -> a
runIdentity (Identity (PatternT a) -> PatternT a)
-> (PatternT (AliasDec, a) -> Identity (PatternT a))
-> PatternT (AliasDec, a)
-> PatternT a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((AliasDec, a) -> Identity a)
-> PatternT (AliasDec, a) -> Identity (PatternT a)
forall (m :: * -> *) from to.
Monad m =>
(from -> m to) -> PatternT from -> m (PatternT to)
rephrasePattern (a -> Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Identity a)
-> ((AliasDec, a) -> a) -> (AliasDec, a) -> Identity a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AliasDec, a) -> a
forall a b. (a, b) -> b
snd)
addAliasesToPattern ::
(ASTRep rep, CanBeAliased (Op rep), Typed dec) =>
PatternT dec ->
Exp (Aliases rep) ->
PatternT (VarAliases, dec)
addAliasesToPattern :: forall rep dec.
(ASTRep rep, CanBeAliased (Op rep), Typed dec) =>
PatternT dec -> Exp (Aliases rep) -> PatternT (AliasDec, dec)
addAliasesToPattern PatternT dec
pat Exp (Aliases rep)
e =
([PatElemT (AliasDec, dec)]
-> [PatElemT (AliasDec, dec)] -> PatternT (AliasDec, dec))
-> ([PatElemT (AliasDec, dec)], [PatElemT (AliasDec, dec)])
-> PatternT (AliasDec, dec)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [PatElemT (AliasDec, dec)]
-> [PatElemT (AliasDec, dec)] -> PatternT (AliasDec, dec)
forall dec. [PatElemT dec] -> [PatElemT dec] -> PatternT dec
Pattern (([PatElemT (AliasDec, dec)], [PatElemT (AliasDec, dec)])
-> PatternT (AliasDec, dec))
-> ([PatElemT (AliasDec, dec)], [PatElemT (AliasDec, dec)])
-> PatternT (AliasDec, dec)
forall a b. (a -> b) -> a -> b
$ PatternT dec
-> Exp (Aliases rep)
-> ([PatElemT (AliasDec, dec)], [PatElemT (AliasDec, dec)])
forall rep dec.
(Aliased rep, Typed dec) =>
PatternT dec
-> Exp rep
-> ([PatElemT (AliasDec, dec)], [PatElemT (AliasDec, dec)])
mkPatternAliases PatternT dec
pat Exp (Aliases rep)
e
mkAliasedBody ::
(ASTRep rep, CanBeAliased (Op rep)) =>
BodyDec rep ->
Stms (Aliases rep) ->
Result ->
Body (Aliases rep)
mkAliasedBody :: forall rep.
(ASTRep rep, CanBeAliased (Op rep)) =>
BodyDec rep -> Stms (Aliases rep) -> Result -> Body (Aliases rep)
mkAliasedBody BodyDec rep
dec Stms (Aliases rep)
bnds Result
res =
BodyDec (Aliases rep)
-> Stms (Aliases rep) -> Result -> BodyT (Aliases rep)
forall rep. BodyDec rep -> Stms rep -> Result -> BodyT rep
Body (Stms (Aliases rep) -> Result -> BodyAliasing
forall rep. Aliased rep => Stms rep -> Result -> BodyAliasing
mkBodyAliases Stms (Aliases rep)
bnds Result
res, BodyDec rep
dec) Stms (Aliases rep)
bnds Result
res
mkPatternAliases ::
(Aliased rep, Typed dec) =>
PatternT dec ->
Exp rep ->
( [PatElemT (VarAliases, dec)],
[PatElemT (VarAliases, dec)]
)
mkPatternAliases :: forall rep dec.
(Aliased rep, Typed dec) =>
PatternT dec
-> Exp rep
-> ([PatElemT (AliasDec, dec)], [PatElemT (AliasDec, dec)])
mkPatternAliases PatternT dec
pat Exp rep
e =
let als :: [Names]
als = Exp rep -> [Names]
forall rep. Aliased rep => Exp rep -> [Names]
expAliases Exp rep
e [Names] -> [Names] -> [Names]
forall a. [a] -> [a] -> [a]
++ Names -> [Names]
forall a. a -> [a]
repeat Names
forall a. Monoid a => a
mempty
context_als :: [Names]
context_als = PatternT dec -> Exp rep -> [Names]
forall rep dec. Aliased rep => PatternT dec -> Exp rep -> [Names]
mkContextAliases PatternT dec
pat Exp rep
e
in ( (PatElemT dec -> Names -> PatElemT (AliasDec, dec))
-> [PatElemT dec] -> [Names] -> [PatElemT (AliasDec, dec)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith PatElemT dec -> Names -> PatElemT (AliasDec, dec)
forall {b}.
Typed b =>
PatElemT b -> Names -> PatElemT (AliasDec, b)
annotateBindee (PatternT dec -> [PatElemT dec]
forall dec. PatternT dec -> [PatElemT dec]
patternContextElements PatternT dec
pat) [Names]
context_als,
(PatElemT dec -> Names -> PatElemT (AliasDec, dec))
-> [PatElemT dec] -> [Names] -> [PatElemT (AliasDec, dec)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith PatElemT dec -> Names -> PatElemT (AliasDec, dec)
forall {b}.
Typed b =>
PatElemT b -> Names -> PatElemT (AliasDec, b)
annotateBindee (PatternT dec -> [PatElemT dec]
forall dec. PatternT dec -> [PatElemT dec]
patternValueElements PatternT dec
pat) [Names]
als
)
where
annotateBindee :: PatElemT b -> Names -> PatElemT (AliasDec, b)
annotateBindee PatElemT b
bindee Names
names =
PatElemT b
bindee PatElemT b -> (AliasDec, b) -> PatElemT (AliasDec, b)
forall oldattr newattr.
PatElemT oldattr -> newattr -> PatElemT newattr
`setPatElemDec` (Names -> AliasDec
AliasDec Names
names', PatElemT b -> b
forall dec. PatElemT dec -> dec
patElemDec PatElemT b
bindee)
where
names' :: Names
names' =
case PatElemT b -> TypeBase Shape NoUniqueness
forall dec.
Typed dec =>
PatElemT dec -> TypeBase Shape NoUniqueness
patElemType PatElemT b
bindee of
Array {} -> Names
names
Mem Space
_ -> Names
names
TypeBase Shape NoUniqueness
_ -> Names
forall a. Monoid a => a
mempty
mkContextAliases ::
Aliased rep =>
PatternT dec ->
Exp rep ->
[Names]
mkContextAliases :: forall rep dec. Aliased rep => PatternT dec -> Exp rep -> [Names]
mkContextAliases PatternT dec
pat (DoLoop [(FParam rep, SubExp)]
ctxmerge [(FParam rep, SubExp)]
valmerge LoopForm rep
_ BodyT rep
body) =
let ctx :: [FParam rep]
ctx = ((FParam rep, SubExp) -> FParam rep)
-> [(FParam rep, SubExp)] -> [FParam rep]
forall a b. (a -> b) -> [a] -> [b]
map (FParam rep, SubExp) -> FParam rep
forall a b. (a, b) -> a
fst [(FParam rep, SubExp)]
ctxmerge
init_als :: [(VName, Names)]
init_als = [VName] -> [Names] -> [(VName, Names)]
forall a b. [a] -> [b] -> [(a, b)]
zip [VName]
mergenames ([Names] -> [(VName, Names)]) -> [Names] -> [(VName, Names)]
forall a b. (a -> b) -> a -> b
$ ((FParam rep, SubExp) -> Names)
-> [(FParam rep, SubExp)] -> [Names]
forall a b. (a -> b) -> [a] -> [b]
map (SubExp -> Names
subExpAliases (SubExp -> Names)
-> ((FParam rep, SubExp) -> SubExp)
-> (FParam rep, SubExp)
-> Names
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FParam rep, SubExp) -> SubExp
forall a b. (a, b) -> b
snd) ([(FParam rep, SubExp)] -> [Names])
-> [(FParam rep, SubExp)] -> [Names]
forall a b. (a -> b) -> a -> b
$ [(FParam rep, SubExp)]
ctxmerge [(FParam rep, SubExp)]
-> [(FParam rep, SubExp)] -> [(FParam rep, SubExp)]
forall a. [a] -> [a] -> [a]
++ [(FParam rep, SubExp)]
valmerge
expand :: Names -> Names
expand Names
als = Names
als Names -> Names -> Names
forall a. Semigroup a => a -> a -> a
<> [Names] -> Names
forall a. Monoid a => [a] -> a
mconcat ((VName -> Maybe Names) -> [VName] -> [Names]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (VName -> [(VName, Names)] -> Maybe Names
forall a b. Eq a => a -> [(a, b)] -> Maybe b
`lookup` [(VName, Names)]
init_als) (Names -> [VName]
namesToList Names
als))
merge_als :: [(VName, Names)]
merge_als =
[VName] -> [Names] -> [(VName, Names)]
forall a b. [a] -> [b] -> [(a, b)]
zip [VName]
mergenames ([Names] -> [(VName, Names)]) -> [Names] -> [(VName, Names)]
forall a b. (a -> b) -> a -> b
$
(Names -> Names) -> [Names] -> [Names]
forall a b. (a -> b) -> [a] -> [b]
map ((Names -> Names -> Names
`namesSubtract` Names
mergenames_set) (Names -> Names) -> (Names -> Names) -> Names -> Names
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Names -> Names
expand) ([Names] -> [Names]) -> [Names] -> [Names]
forall a b. (a -> b) -> a -> b
$
BodyT rep -> [Names]
forall rep. Aliased rep => Body rep -> [Names]
bodyAliases BodyT rep
body
in if [FParam rep] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [FParam rep]
ctx Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [PatElemT dec] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (PatternT dec -> [PatElemT dec]
forall dec. PatternT dec -> [PatElemT dec]
patternContextElements PatternT dec
pat)
then (FParam rep -> Names) -> [FParam rep] -> [Names]
forall a b. (a -> b) -> [a] -> [b]
map (Names -> Maybe Names -> Names
forall a. a -> Maybe a -> a
fromMaybe Names
forall a. Monoid a => a
mempty (Maybe Names -> Names)
-> (FParam rep -> Maybe Names) -> FParam rep -> Names
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (VName -> [(VName, Names)] -> Maybe Names)
-> [(VName, Names)] -> VName -> Maybe Names
forall a b c. (a -> b -> c) -> b -> a -> c
flip VName -> [(VName, Names)] -> Maybe Names
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup [(VName, Names)]
merge_als (VName -> Maybe Names)
-> (FParam rep -> VName) -> FParam rep -> Maybe Names
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FParam rep -> VName
forall dec. Param dec -> VName
paramName) [FParam rep]
ctx
else (PatElemT dec -> Names) -> [PatElemT dec] -> [Names]
forall a b. (a -> b) -> [a] -> [b]
map (Names -> PatElemT dec -> Names
forall a b. a -> b -> a
const Names
forall a. Monoid a => a
mempty) ([PatElemT dec] -> [Names]) -> [PatElemT dec] -> [Names]
forall a b. (a -> b) -> a -> b
$ PatternT dec -> [PatElemT dec]
forall dec. PatternT dec -> [PatElemT dec]
patternContextElements PatternT dec
pat
where
mergenames :: [VName]
mergenames = ((FParam rep, SubExp) -> VName)
-> [(FParam rep, SubExp)] -> [VName]
forall a b. (a -> b) -> [a] -> [b]
map (FParam rep -> VName
forall dec. Param dec -> VName
paramName (FParam rep -> VName)
-> ((FParam rep, SubExp) -> FParam rep)
-> (FParam rep, SubExp)
-> VName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FParam rep, SubExp) -> FParam rep
forall a b. (a, b) -> a
fst) ([(FParam rep, SubExp)] -> [VName])
-> [(FParam rep, SubExp)] -> [VName]
forall a b. (a -> b) -> a -> b
$ [(FParam rep, SubExp)]
ctxmerge [(FParam rep, SubExp)]
-> [(FParam rep, SubExp)] -> [(FParam rep, SubExp)]
forall a. [a] -> [a] -> [a]
++ [(FParam rep, SubExp)]
valmerge
mergenames_set :: Names
mergenames_set = [VName] -> Names
namesFromList [VName]
mergenames
mkContextAliases PatternT dec
pat (If SubExp
_ BodyT rep
tbranch BodyT rep
fbranch IfDec (BranchType rep)
_) =
Int -> [Names] -> [Names]
forall a. Int -> [a] -> [a]
take ([VName] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([VName] -> Int) -> [VName] -> Int
forall a b. (a -> b) -> a -> b
$ PatternT dec -> [VName]
forall dec. PatternT dec -> [VName]
patternContextNames PatternT dec
pat) ([Names] -> [Names]) -> [Names] -> [Names]
forall a b. (a -> b) -> a -> b
$
(Names -> Names -> Names) -> [Names] -> [Names] -> [Names]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Names -> Names -> Names
forall a. Semigroup a => a -> a -> a
(<>) (BodyT rep -> [Names]
forall rep. Aliased rep => Body rep -> [Names]
bodyAliases BodyT rep
tbranch) (BodyT rep -> [Names]
forall rep. Aliased rep => Body rep -> [Names]
bodyAliases BodyT rep
fbranch)
mkContextAliases PatternT dec
pat ExpT rep
_ =
Int -> Names -> [Names]
forall a. Int -> a -> [a]
replicate ([PatElemT dec] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([PatElemT dec] -> Int) -> [PatElemT dec] -> Int
forall a b. (a -> b) -> a -> b
$ PatternT dec -> [PatElemT dec]
forall dec. PatternT dec -> [PatElemT dec]
patternContextElements PatternT dec
pat) Names
forall a. Monoid a => a
mempty
mkBodyAliases ::
Aliased rep =>
Stms rep ->
Result ->
BodyAliasing
mkBodyAliases :: forall rep. Aliased rep => Stms rep -> Result -> BodyAliasing
mkBodyAliases Stms rep
bnds Result
res =
let ([Names]
aliases, Names
consumed) = Stms rep -> Result -> ([Names], Names)
forall rep. Aliased rep => Stms rep -> Result -> ([Names], Names)
mkStmsAliases Stms rep
bnds Result
res
boundNames :: Names
boundNames =
(Stm rep -> Names) -> Stms rep -> Names
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ([VName] -> Names
namesFromList ([VName] -> Names) -> (Stm rep -> [VName]) -> Stm rep -> Names
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatternT (LetDec rep) -> [VName]
forall dec. PatternT dec -> [VName]
patternNames (PatternT (LetDec rep) -> [VName])
-> (Stm rep -> PatternT (LetDec rep)) -> Stm rep -> [VName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stm rep -> PatternT (LetDec rep)
forall rep. Stm rep -> Pattern rep
stmPattern) Stms rep
bnds
aliases' :: [Names]
aliases' = (Names -> Names) -> [Names] -> [Names]
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 ((Names -> AliasDec) -> [Names] -> [AliasDec]
forall a b. (a -> b) -> [a] -> [b]
map Names -> AliasDec
AliasDec [Names]
aliases', Names -> AliasDec
AliasDec Names
consumed')
mkStmsAliases ::
Aliased rep =>
Stms rep ->
[SubExp] ->
([Names], Names)
mkStmsAliases :: forall rep. Aliased rep => Stms rep -> Result -> ([Names], Names)
mkStmsAliases Stms rep
bnds Result
res = AliasesAndConsumed -> [Stm rep] -> ([Names], Names)
delve AliasesAndConsumed
forall a. Monoid a => a
mempty ([Stm rep] -> ([Names], Names)) -> [Stm rep] -> ([Names], Names)
forall a b. (a -> b) -> a -> b
$ Stms rep -> [Stm rep]
forall rep. Stms rep -> [Stm rep]
stmsToList Stms rep
bnds
where
delve :: AliasesAndConsumed -> [Stm rep] -> ([Names], Names)
delve (Map VName Names
aliasmap, Names
consumed) [] =
( (SubExp -> Names) -> Result -> [Names]
forall a b. (a -> b) -> [a] -> [b]
map (Map VName Names -> Names -> Names
aliasClosure Map VName Names
aliasmap (Names -> Names) -> (SubExp -> Names) -> SubExp -> Names
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SubExp -> Names
subExpAliases) Result
res,
Names
consumed
)
delve (Map VName Names
aliasmap, Names
consumed) (Stm rep
bnd : [Stm rep]
bnds') =
AliasesAndConsumed -> [Stm rep] -> ([Names], Names)
delve (AliasesAndConsumed -> Stm rep -> AliasesAndConsumed
forall rep.
Aliased rep =>
AliasesAndConsumed -> Stm rep -> AliasesAndConsumed
trackAliases (Map VName Names
aliasmap, Names
consumed) Stm rep
bnd) [Stm rep]
bnds'
aliasClosure :: Map VName Names -> Names -> Names
aliasClosure Map VName Names
aliasmap Names
names =
Names
names Names -> Names -> Names
forall a. Semigroup a => a -> a -> a
<> [Names] -> Names
forall a. Monoid a => [a] -> a
mconcat ((VName -> Names) -> [VName] -> [Names]
forall a b. (a -> b) -> [a] -> [b]
map VName -> Names
look ([VName] -> [Names]) -> [VName] -> [Names]
forall a b. (a -> b) -> a -> b
$ Names -> [VName]
namesToList Names
names)
where
look :: VName -> Names
look VName
k = Names -> VName -> Map VName Names -> Names
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault Names
forall a. Monoid a => a
mempty VName
k Map VName Names
aliasmap
type AliasesAndConsumed =
( M.Map VName Names,
Names
)
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 :: Pattern rep
pat = Stm rep -> Pattern rep
forall rep. Stm rep -> Pattern rep
stmPattern Stm rep
stm
pe_als :: [(VName, Names)]
pe_als =
[VName] -> [Names] -> [(VName, Names)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Pattern rep -> [VName]
forall dec. PatternT dec -> [VName]
patternNames Pattern rep
pat) ([Names] -> [(VName, Names)]) -> [Names] -> [(VName, Names)]
forall a b. (a -> b) -> a -> b
$ (Names -> Names) -> [Names] -> [Names]
forall a b. (a -> b) -> [a] -> [b]
map Names -> Names
addAliasesOfAliases ([Names] -> [Names]) -> [Names] -> [Names]
forall a b. (a -> b) -> a -> b
$ Pattern rep -> [Names]
forall dec. AliasesOf dec => PatternT dec -> [Names]
patternAliases Pattern rep
pat
als :: Map VName Names
als = [(VName, Names)] -> Map VName Names
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(VName, Names)]
pe_als
rev_als :: Map VName Names
rev_als = ((VName, Names) -> Map VName Names)
-> [(VName, Names)] -> Map VName Names
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) =
[(VName, Names)] -> Map VName Names
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(VName, Names)] -> Map VName Names)
-> [(VName, Names)] -> Map VName Names
forall a b. (a -> b) -> a -> b
$ (VName -> (VName, Names)) -> [VName] -> [(VName, Names)]
forall a b. (a -> b) -> [a] -> [b]
map (,VName -> Names
oneName VName
v) ([VName] -> [(VName, Names)]) -> [VName] -> [(VName, Names)]
forall a b. (a -> b) -> a -> b
$ Names -> [VName]
namesToList Names
v_als
comb :: Map VName Names -> Map VName Names -> Map VName Names
comb = (Names -> Names -> Names)
-> Map VName Names -> Map VName Names -> Map VName Names
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith Names -> Names -> Names
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 Names -> Names -> Names
forall a. Semigroup a => a -> a -> a
<> Names -> Names
addAliasesOfAliases (Stm rep -> Names
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 Names -> Names -> Names
forall a. Semigroup a => a -> a -> a
<> Names -> Names
aliasesOfAliases Names
names
aliasesOfAliases :: Names -> Names
aliasesOfAliases = [Names] -> Names
forall a. Monoid a => [a] -> a
mconcat ([Names] -> Names) -> (Names -> [Names]) -> Names -> Names
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (VName -> Names) -> [VName] -> [Names]
forall a b. (a -> b) -> [a] -> [b]
map VName -> Names
look ([VName] -> [Names]) -> (Names -> [VName]) -> Names -> [Names]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Names -> [VName]
namesToList
look :: VName -> Names
look VName
k = Names -> VName -> Map VName Names -> Names
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault Names
forall a. Monoid a => a
mempty VName
k Map VName Names
aliasmap
mkAliasedLetStm ::
(ASTRep rep, CanBeAliased (Op rep)) =>
Pattern rep ->
StmAux (ExpDec rep) ->
Exp (Aliases rep) ->
Stm (Aliases rep)
mkAliasedLetStm :: forall rep.
(ASTRep rep, CanBeAliased (Op rep)) =>
Pattern rep
-> StmAux (ExpDec rep) -> Exp (Aliases rep) -> Stm (Aliases rep)
mkAliasedLetStm Pattern rep
pat (StmAux Certificates
cs Attrs
attrs ExpDec rep
dec) Exp (Aliases rep)
e =
Pattern (Aliases rep)
-> StmAux (ExpDec (Aliases rep))
-> Exp (Aliases rep)
-> Stm (Aliases rep)
forall rep.
Pattern rep -> StmAux (ExpDec rep) -> Exp rep -> Stm rep
Let
(Pattern rep -> Exp (Aliases rep) -> PatternT (AliasDec, LetDec rep)
forall rep dec.
(ASTRep rep, CanBeAliased (Op rep), Typed dec) =>
PatternT dec -> Exp (Aliases rep) -> PatternT (AliasDec, dec)
addAliasesToPattern Pattern rep
pat Exp (Aliases rep)
e)
(Certificates
-> Attrs -> (AliasDec, ExpDec rep) -> StmAux (AliasDec, ExpDec rep)
forall dec. Certificates -> Attrs -> dec -> StmAux dec
StmAux Certificates
cs Attrs
attrs (Names -> AliasDec
AliasDec (Names -> AliasDec) -> Names -> AliasDec
forall a b. (a -> b) -> a -> b
$ Exp (Aliases rep) -> Names
forall rep. Aliased rep => Exp rep -> Names
consumedInExp Exp (Aliases rep)
e, ExpDec rep
dec))
Exp (Aliases rep)
e
instance (Bindable rep, CanBeAliased (Op rep)) => Bindable (Aliases rep) where
mkExpDec :: Pattern (Aliases rep) -> Exp (Aliases rep) -> ExpDec (Aliases rep)
mkExpDec Pattern (Aliases rep)
pat Exp (Aliases rep)
e =
let dec :: ExpDec rep
dec = Pattern rep -> Exp rep -> ExpDec rep
forall rep. Bindable rep => Pattern rep -> Exp rep -> ExpDec rep
mkExpDec (PatternT (AliasDec, LetDec rep) -> Pattern rep
forall a. PatternT (AliasDec, a) -> PatternT a
removePatternAliases PatternT (AliasDec, LetDec rep)
Pattern (Aliases rep)
pat) (Exp rep -> ExpDec rep) -> Exp rep -> ExpDec rep
forall a b. (a -> b) -> a -> b
$ Exp (Aliases rep) -> Exp rep
forall rep. CanBeAliased (Op rep) => Exp (Aliases rep) -> Exp rep
removeExpAliases Exp (Aliases rep)
e
in (Names -> AliasDec
AliasDec (Names -> AliasDec) -> Names -> AliasDec
forall a b. (a -> b) -> a -> b
$ Exp (Aliases rep) -> Names
forall rep. Aliased rep => Exp rep -> Names
consumedInExp Exp (Aliases rep)
e, ExpDec rep
dec)
mkExpPat :: [Ident] -> [Ident] -> Exp (Aliases rep) -> Pattern (Aliases rep)
mkExpPat [Ident]
ctx [Ident]
val Exp (Aliases rep)
e =
Pattern rep -> Exp (Aliases rep) -> PatternT (AliasDec, LetDec rep)
forall rep dec.
(ASTRep rep, CanBeAliased (Op rep), Typed dec) =>
PatternT dec -> Exp (Aliases rep) -> PatternT (AliasDec, dec)
addAliasesToPattern ([Ident] -> [Ident] -> Exp rep -> Pattern rep
forall rep.
Bindable rep =>
[Ident] -> [Ident] -> Exp rep -> Pattern rep
mkExpPat [Ident]
ctx [Ident]
val (Exp rep -> Pattern rep) -> Exp rep -> Pattern rep
forall a b. (a -> b) -> a -> b
$ Exp (Aliases rep) -> Exp rep
forall rep. 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 <- (Scope (Aliases rep) -> Scope rep) -> m (Scope rep)
forall rep (m :: * -> *) a.
HasScope rep m =>
(Scope rep -> a) -> m a
asksScope Scope (Aliases rep) -> Scope rep
forall rep. Scope (Aliases rep) -> Scope rep
removeScopeAliases
(ReaderT (Scope rep) m (Stm (Aliases rep))
-> Scope rep -> m (Stm (Aliases rep)))
-> Scope rep
-> ReaderT (Scope rep) m (Stm (Aliases rep))
-> m (Stm (Aliases rep))
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT (Scope rep) m (Stm (Aliases rep))
-> Scope rep -> m (Stm (Aliases rep))
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT Scope rep
env (ReaderT (Scope rep) m (Stm (Aliases rep))
-> m (Stm (Aliases rep)))
-> ReaderT (Scope rep) m (Stm (Aliases rep))
-> m (Stm (Aliases rep))
forall a b. (a -> b) -> a -> b
$ do
Let Pattern rep
pat StmAux (ExpDec rep)
dec Exp rep
_ <- [VName] -> Exp rep -> ReaderT (Scope rep) m (Stm rep)
forall rep (m :: * -> *).
(Bindable rep, MonadFreshNames m, HasScope rep m) =>
[VName] -> Exp rep -> m (Stm rep)
mkLetNames [VName]
names (Exp rep -> ReaderT (Scope rep) m (Stm rep))
-> Exp rep -> ReaderT (Scope rep) m (Stm rep)
forall a b. (a -> b) -> a -> b
$ Exp (Aliases rep) -> Exp rep
forall rep. CanBeAliased (Op rep) => Exp (Aliases rep) -> Exp rep
removeExpAliases Exp (Aliases rep)
e
Stm (Aliases rep) -> ReaderT (Scope rep) m (Stm (Aliases rep))
forall (m :: * -> *) a. Monad m => a -> m a
return (Stm (Aliases rep) -> ReaderT (Scope rep) m (Stm (Aliases rep)))
-> Stm (Aliases rep) -> ReaderT (Scope rep) m (Stm (Aliases rep))
forall a b. (a -> b) -> a -> b
$ Pattern rep
-> StmAux (ExpDec rep) -> Exp (Aliases rep) -> Stm (Aliases rep)
forall rep.
(ASTRep rep, CanBeAliased (Op rep)) =>
Pattern rep
-> StmAux (ExpDec rep) -> Exp (Aliases rep) -> Stm (Aliases rep)
mkAliasedLetStm Pattern rep
pat StmAux (ExpDec rep)
dec Exp (Aliases rep)
e
mkBody :: Stms (Aliases rep) -> Result -> Body (Aliases rep)
mkBody Stms (Aliases rep)
bnds Result
res =
let Body BodyDec rep
bodyrep Stms rep
_ Result
_ = Stms rep -> Result -> BodyT rep
forall rep. Bindable rep => Stms rep -> Result -> Body rep
mkBody ((Stm (Aliases rep) -> Stm rep) -> Stms (Aliases rep) -> Stms rep
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Stm (Aliases rep) -> Stm rep
forall rep. CanBeAliased (Op rep) => Stm (Aliases rep) -> Stm rep
removeStmAliases Stms (Aliases rep)
bnds) Result
res
in BodyDec rep -> Stms (Aliases rep) -> Result -> Body (Aliases rep)
forall rep.
(ASTRep rep, CanBeAliased (Op rep)) =>
BodyDec rep -> Stms (Aliases rep) -> Result -> Body (Aliases rep)
mkAliasedBody BodyDec rep
bodyrep Stms (Aliases rep)
bnds Result
res
instance (ASTRep (Aliases rep), Bindable (Aliases rep)) => BinderOps (Aliases rep)