{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
module GHC.Core.Tidy (
tidyExpr, tidyRules, tidyUnfolding
) where
#include "HsVersions.h"
import GHC.Prelude
import GHC.Core
import GHC.Core.Seq ( seqUnfolding )
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Types.Demand ( zapDmdEnvSig )
import GHC.Core.Type ( tidyType, tidyVarBndr )
import GHC.Core.Coercion ( tidyCo )
import GHC.Types.Var
import GHC.Types.Var.Env
import GHC.Types.Unique (getUnique)
import GHC.Types.Unique.FM
import GHC.Types.Name hiding (tidyNameOcc)
import GHC.Types.SrcLoc
import GHC.Types.Tickish
import GHC.Data.Maybe
import Data.List (mapAccumL)
tidyBind :: TidyEnv
-> CoreBind
-> (TidyEnv, CoreBind)
tidyBind :: TidyEnv -> CoreBind -> (TidyEnv, CoreBind)
tidyBind TidyEnv
env (NonRec Id
bndr Expr Id
rhs)
= TidyEnv -> TidyEnv -> Id -> (TidyEnv, Id)
tidyLetBndr TidyEnv
env TidyEnv
env Id
bndr (TidyEnv, Id)
-> ((TidyEnv, Id) -> (TidyEnv, CoreBind)) -> (TidyEnv, CoreBind)
forall a b. a -> (a -> b) -> b
=: \ (TidyEnv
env', Id
bndr') ->
(TidyEnv
env', Id -> Expr Id -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
bndr' (TidyEnv -> Expr Id -> Expr Id
tidyExpr TidyEnv
env' Expr Id
rhs))
tidyBind TidyEnv
env (Rec [(Id, Expr Id)]
prs)
= let
([Id]
bndrs, [Expr Id]
rhss) = [(Id, Expr Id)] -> ([Id], [Expr Id])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Id, Expr Id)]
prs
(TidyEnv
env', [Id]
bndrs') = (TidyEnv -> Id -> (TidyEnv, Id))
-> TidyEnv -> [Id] -> (TidyEnv, [Id])
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumL (TidyEnv -> TidyEnv -> Id -> (TidyEnv, Id)
tidyLetBndr TidyEnv
env') TidyEnv
env [Id]
bndrs
in
(Expr Id -> Expr Id) -> [Expr Id] -> [Expr Id]
forall a b. (a -> b) -> [a] -> [b]
map (TidyEnv -> Expr Id -> Expr Id
tidyExpr TidyEnv
env') [Expr Id]
rhss [Expr Id]
-> ([Expr Id] -> (TidyEnv, CoreBind)) -> (TidyEnv, CoreBind)
forall a b. a -> (a -> b) -> b
=: \ [Expr Id]
rhss' ->
(TidyEnv
env', [(Id, Expr Id)] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
Rec ([Id] -> [Expr Id] -> [(Id, Expr Id)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Id]
bndrs' [Expr Id]
rhss'))
tidyExpr :: TidyEnv -> CoreExpr -> CoreExpr
tidyExpr :: TidyEnv -> Expr Id -> Expr Id
tidyExpr TidyEnv
env (Var Id
v) = Id -> Expr Id
forall b. Id -> Expr b
Var (TidyEnv -> Id -> Id
tidyVarOcc TidyEnv
env Id
v)
tidyExpr TidyEnv
env (Type Type
ty) = Type -> Expr Id
forall b. Type -> Expr b
Type (TidyEnv -> Type -> Type
tidyType TidyEnv
env Type
ty)
tidyExpr TidyEnv
env (Coercion Coercion
co) = Coercion -> Expr Id
forall b. Coercion -> Expr b
Coercion (TidyEnv -> Coercion -> Coercion
tidyCo TidyEnv
env Coercion
co)
tidyExpr TidyEnv
_ (Lit Literal
lit) = Literal -> Expr Id
forall b. Literal -> Expr b
Lit Literal
lit
tidyExpr TidyEnv
env (App Expr Id
f Expr Id
a) = Expr Id -> Expr Id -> Expr Id
forall b. Expr b -> Expr b -> Expr b
App (TidyEnv -> Expr Id -> Expr Id
tidyExpr TidyEnv
env Expr Id
f) (TidyEnv -> Expr Id -> Expr Id
tidyExpr TidyEnv
env Expr Id
a)
tidyExpr TidyEnv
env (Tick CoreTickish
t Expr Id
e) = CoreTickish -> Expr Id -> Expr Id
forall b. CoreTickish -> Expr b -> Expr b
Tick (TidyEnv -> CoreTickish -> CoreTickish
tidyTickish TidyEnv
env CoreTickish
t) (TidyEnv -> Expr Id -> Expr Id
tidyExpr TidyEnv
env Expr Id
e)
tidyExpr TidyEnv
env (Cast Expr Id
e Coercion
co) = Expr Id -> Coercion -> Expr Id
forall b. Expr b -> Coercion -> Expr b
Cast (TidyEnv -> Expr Id -> Expr Id
tidyExpr TidyEnv
env Expr Id
e) (TidyEnv -> Coercion -> Coercion
tidyCo TidyEnv
env Coercion
co)
tidyExpr TidyEnv
env (Let CoreBind
b Expr Id
e)
= TidyEnv -> CoreBind -> (TidyEnv, CoreBind)
tidyBind TidyEnv
env CoreBind
b (TidyEnv, CoreBind) -> ((TidyEnv, CoreBind) -> Expr Id) -> Expr Id
forall a b. a -> (a -> b) -> b
=: \ (TidyEnv
env', CoreBind
b') ->
CoreBind -> Expr Id -> Expr Id
forall b. Bind b -> Expr b -> Expr b
Let CoreBind
b' (TidyEnv -> Expr Id -> Expr Id
tidyExpr TidyEnv
env' Expr Id
e)
tidyExpr TidyEnv
env (Case Expr Id
e Id
b Type
ty [Alt Id]
alts)
= TidyEnv -> Id -> (TidyEnv, Id)
tidyBndr TidyEnv
env Id
b (TidyEnv, Id) -> ((TidyEnv, Id) -> Expr Id) -> Expr Id
forall a b. a -> (a -> b) -> b
=: \ (TidyEnv
env', Id
b) ->
Expr Id -> Id -> Type -> [Alt Id] -> Expr Id
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case (TidyEnv -> Expr Id -> Expr Id
tidyExpr TidyEnv
env Expr Id
e) Id
b (TidyEnv -> Type -> Type
tidyType TidyEnv
env Type
ty)
((Alt Id -> Alt Id) -> [Alt Id] -> [Alt Id]
forall a b. (a -> b) -> [a] -> [b]
map (TidyEnv -> Alt Id -> Alt Id
tidyAlt TidyEnv
env') [Alt Id]
alts)
tidyExpr TidyEnv
env (Lam Id
b Expr Id
e)
= TidyEnv -> Id -> (TidyEnv, Id)
tidyBndr TidyEnv
env Id
b (TidyEnv, Id) -> ((TidyEnv, Id) -> Expr Id) -> Expr Id
forall a b. a -> (a -> b) -> b
=: \ (TidyEnv
env', Id
b) ->
Id -> Expr Id -> Expr Id
forall b. b -> Expr b -> Expr b
Lam Id
b (TidyEnv -> Expr Id -> Expr Id
tidyExpr TidyEnv
env' Expr Id
e)
tidyAlt :: TidyEnv -> CoreAlt -> CoreAlt
tidyAlt :: TidyEnv -> Alt Id -> Alt Id
tidyAlt TidyEnv
env (Alt AltCon
con [Id]
vs Expr Id
rhs)
= TidyEnv -> [Id] -> (TidyEnv, [Id])
tidyBndrs TidyEnv
env [Id]
vs (TidyEnv, [Id]) -> ((TidyEnv, [Id]) -> Alt Id) -> Alt Id
forall a b. a -> (a -> b) -> b
=: \ (TidyEnv
env', [Id]
vs) ->
(AltCon -> [Id] -> Expr Id -> Alt Id
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
con [Id]
vs (TidyEnv -> Expr Id -> Expr Id
tidyExpr TidyEnv
env' Expr Id
rhs))
tidyTickish :: TidyEnv -> CoreTickish -> CoreTickish
tidyTickish :: TidyEnv -> CoreTickish -> CoreTickish
tidyTickish TidyEnv
env (Breakpoint XBreakpoint 'TickishPassCore
ext Int
ix [XTickishId 'TickishPassCore]
ids)
= XBreakpoint 'TickishPassCore
-> Int -> [XTickishId 'TickishPassCore] -> CoreTickish
forall (pass :: TickishPass).
XBreakpoint pass -> Int -> [XTickishId pass] -> GenTickish pass
Breakpoint XBreakpoint 'TickishPassCore
ext Int
ix ((Id -> Id) -> [Id] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map (TidyEnv -> Id -> Id
tidyVarOcc TidyEnv
env) [Id]
[XTickishId 'TickishPassCore]
ids)
tidyTickish TidyEnv
_ CoreTickish
other_tickish = CoreTickish
other_tickish
tidyRules :: TidyEnv -> [CoreRule] -> [CoreRule]
tidyRules :: TidyEnv -> [CoreRule] -> [CoreRule]
tidyRules TidyEnv
_ [] = []
tidyRules TidyEnv
env (CoreRule
rule : [CoreRule]
rules)
= TidyEnv -> CoreRule -> CoreRule
tidyRule TidyEnv
env CoreRule
rule CoreRule -> (CoreRule -> [CoreRule]) -> [CoreRule]
forall a b. a -> (a -> b) -> b
=: \ CoreRule
rule ->
TidyEnv -> [CoreRule] -> [CoreRule]
tidyRules TidyEnv
env [CoreRule]
rules [CoreRule] -> ([CoreRule] -> [CoreRule]) -> [CoreRule]
forall a b. a -> (a -> b) -> b
=: \ [CoreRule]
rules ->
(CoreRule
rule CoreRule -> [CoreRule] -> [CoreRule]
forall a. a -> [a] -> [a]
: [CoreRule]
rules)
tidyRule :: TidyEnv -> CoreRule -> CoreRule
tidyRule :: TidyEnv -> CoreRule -> CoreRule
tidyRule TidyEnv
_ rule :: CoreRule
rule@(BuiltinRule {}) = CoreRule
rule
tidyRule TidyEnv
env rule :: CoreRule
rule@(Rule { ru_bndrs :: CoreRule -> [Id]
ru_bndrs = [Id]
bndrs, ru_args :: CoreRule -> [Expr Id]
ru_args = [Expr Id]
args, ru_rhs :: CoreRule -> Expr Id
ru_rhs = Expr Id
rhs,
ru_fn :: CoreRule -> Name
ru_fn = Name
fn, ru_rough :: CoreRule -> [Maybe Name]
ru_rough = [Maybe Name]
mb_ns })
= TidyEnv -> [Id] -> (TidyEnv, [Id])
tidyBndrs TidyEnv
env [Id]
bndrs (TidyEnv, [Id]) -> ((TidyEnv, [Id]) -> CoreRule) -> CoreRule
forall a b. a -> (a -> b) -> b
=: \ (TidyEnv
env', [Id]
bndrs) ->
(Expr Id -> Expr Id) -> [Expr Id] -> [Expr Id]
forall a b. (a -> b) -> [a] -> [b]
map (TidyEnv -> Expr Id -> Expr Id
tidyExpr TidyEnv
env') [Expr Id]
args [Expr Id] -> ([Expr Id] -> CoreRule) -> CoreRule
forall a b. a -> (a -> b) -> b
=: \ [Expr Id]
args ->
CoreRule
rule { ru_bndrs :: [Id]
ru_bndrs = [Id]
bndrs, ru_args :: [Expr Id]
ru_args = [Expr Id]
args,
ru_rhs :: Expr Id
ru_rhs = TidyEnv -> Expr Id -> Expr Id
tidyExpr TidyEnv
env' Expr Id
rhs,
ru_fn :: Name
ru_fn = TidyEnv -> Name -> Name
tidyNameOcc TidyEnv
env Name
fn,
ru_rough :: [Maybe Name]
ru_rough = (Maybe Name -> Maybe Name) -> [Maybe Name] -> [Maybe Name]
forall a b. (a -> b) -> [a] -> [b]
map ((Name -> Name) -> Maybe Name -> Maybe Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (TidyEnv -> Name -> Name
tidyNameOcc TidyEnv
env')) [Maybe Name]
mb_ns }
tidyNameOcc :: TidyEnv -> Name -> Name
tidyNameOcc :: TidyEnv -> Name -> Name
tidyNameOcc (TidyOccEnv
_, VarEnv Id
var_env) Name
n = case VarEnv Id -> Unique -> Maybe Id
forall key elt. UniqFM key elt -> Unique -> Maybe elt
lookupUFM_Directly VarEnv Id
var_env (Name -> Unique
forall a. Uniquable a => a -> Unique
getUnique Name
n) of
Maybe Id
Nothing -> Name
n
Just Id
v -> Id -> Name
idName Id
v
tidyVarOcc :: TidyEnv -> Var -> Var
tidyVarOcc :: TidyEnv -> Id -> Id
tidyVarOcc (TidyOccEnv
_, VarEnv Id
var_env) Id
v = VarEnv Id -> Id -> Maybe Id
forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv VarEnv Id
var_env Id
v Maybe Id -> Id -> Id
forall a. Maybe a -> a -> a
`orElse` Id
v
tidyBndr :: TidyEnv -> Var -> (TidyEnv, Var)
tidyBndr :: TidyEnv -> Id -> (TidyEnv, Id)
tidyBndr TidyEnv
env Id
var
| Id -> Bool
isTyCoVar Id
var = TidyEnv -> Id -> (TidyEnv, Id)
tidyVarBndr TidyEnv
env Id
var
| Bool
otherwise = TidyEnv -> Id -> (TidyEnv, Id)
tidyIdBndr TidyEnv
env Id
var
tidyBndrs :: TidyEnv -> [Var] -> (TidyEnv, [Var])
tidyBndrs :: TidyEnv -> [Id] -> (TidyEnv, [Id])
tidyBndrs TidyEnv
env [Id]
vars = (TidyEnv -> Id -> (TidyEnv, Id))
-> TidyEnv -> [Id] -> (TidyEnv, [Id])
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumL TidyEnv -> Id -> (TidyEnv, Id)
tidyBndr TidyEnv
env [Id]
vars
tidyIdBndr :: TidyEnv -> Id -> (TidyEnv, Id)
tidyIdBndr :: TidyEnv -> Id -> (TidyEnv, Id)
tidyIdBndr env :: TidyEnv
env@(TidyOccEnv
tidy_env, VarEnv Id
var_env) Id
id
=
case TidyOccEnv -> OccName -> (TidyOccEnv, OccName)
tidyOccName TidyOccEnv
tidy_env (Id -> OccName
forall a. NamedThing a => a -> OccName
getOccName Id
id) of { (TidyOccEnv
tidy_env', OccName
occ') ->
let
ty' :: Type
ty' = TidyEnv -> Type -> Type
tidyType TidyEnv
env (Id -> Type
idType Id
id)
mult' :: Type
mult' = TidyEnv -> Type -> Type
tidyType TidyEnv
env (Id -> Type
idMult Id
id)
name' :: Name
name' = Unique -> OccName -> SrcSpan -> Name
mkInternalName (Id -> Unique
idUnique Id
id) OccName
occ' SrcSpan
noSrcSpan
id' :: Id
id' = HasDebugCallStack => Name -> Type -> Type -> IdInfo -> Id
Name -> Type -> Type -> IdInfo -> Id
mkLocalIdWithInfo Name
name' Type
mult' Type
ty' IdInfo
new_info
var_env' :: VarEnv Id
var_env' = VarEnv Id -> Id -> Id -> VarEnv Id
forall a. VarEnv a -> Id -> a -> VarEnv a
extendVarEnv VarEnv Id
var_env Id
id Id
id'
new_info :: IdInfo
new_info = IdInfo
vanillaIdInfo IdInfo -> OccInfo -> IdInfo
`setOccInfo` IdInfo -> OccInfo
occInfo IdInfo
old_info
IdInfo -> Unfolding -> IdInfo
`setUnfoldingInfo` Unfolding
new_unf
IdInfo -> OneShotInfo -> IdInfo
`setOneShotInfo` IdInfo -> OneShotInfo
oneShotInfo IdInfo
old_info
old_info :: IdInfo
old_info = HasDebugCallStack => Id -> IdInfo
Id -> IdInfo
idInfo Id
id
old_unf :: Unfolding
old_unf = IdInfo -> Unfolding
unfoldingInfo IdInfo
old_info
new_unf :: Unfolding
new_unf = Unfolding -> Unfolding
zapUnfolding Unfolding
old_unf
in
((TidyOccEnv
tidy_env', VarEnv Id
var_env'), Id
id')
}
tidyLetBndr :: TidyEnv
-> TidyEnv
-> Id -> (TidyEnv, Id)
tidyLetBndr :: TidyEnv -> TidyEnv -> Id -> (TidyEnv, Id)
tidyLetBndr TidyEnv
rec_tidy_env env :: TidyEnv
env@(TidyOccEnv
tidy_env, VarEnv Id
var_env) Id
id
= case TidyOccEnv -> OccName -> (TidyOccEnv, OccName)
tidyOccName TidyOccEnv
tidy_env (Id -> OccName
forall a. NamedThing a => a -> OccName
getOccName Id
id) of { (TidyOccEnv
tidy_env', OccName
occ') ->
let
ty' :: Type
ty' = TidyEnv -> Type -> Type
tidyType TidyEnv
env (Id -> Type
idType Id
id)
mult' :: Type
mult' = TidyEnv -> Type -> Type
tidyType TidyEnv
env (Id -> Type
idMult Id
id)
name' :: Name
name' = Unique -> OccName -> SrcSpan -> Name
mkInternalName (Id -> Unique
idUnique Id
id) OccName
occ' SrcSpan
noSrcSpan
details :: IdDetails
details = Id -> IdDetails
idDetails Id
id
id' :: Id
id' = IdDetails -> Name -> Type -> Type -> IdInfo -> Id
mkLocalVar IdDetails
details Name
name' Type
mult' Type
ty' IdInfo
new_info
var_env' :: VarEnv Id
var_env' = VarEnv Id -> Id -> Id -> VarEnv Id
forall a. VarEnv a -> Id -> a -> VarEnv a
extendVarEnv VarEnv Id
var_env Id
id Id
id'
old_info :: IdInfo
old_info = HasDebugCallStack => Id -> IdInfo
Id -> IdInfo
idInfo Id
id
new_info :: IdInfo
new_info = IdInfo
vanillaIdInfo
IdInfo -> OccInfo -> IdInfo
`setOccInfo` IdInfo -> OccInfo
occInfo IdInfo
old_info
IdInfo -> Int -> IdInfo
`setArityInfo` IdInfo -> Int
arityInfo IdInfo
old_info
IdInfo -> StrictSig -> IdInfo
`setStrictnessInfo` StrictSig -> StrictSig
zapDmdEnvSig (IdInfo -> StrictSig
strictnessInfo IdInfo
old_info)
IdInfo -> Demand -> IdInfo
`setDemandInfo` IdInfo -> Demand
demandInfo IdInfo
old_info
IdInfo -> InlinePragma -> IdInfo
`setInlinePragInfo` IdInfo -> InlinePragma
inlinePragInfo IdInfo
old_info
IdInfo -> Unfolding -> IdInfo
`setUnfoldingInfo` Unfolding
new_unf
old_unf :: Unfolding
old_unf = IdInfo -> Unfolding
unfoldingInfo IdInfo
old_info
new_unf :: Unfolding
new_unf | Unfolding -> Bool
isStableUnfolding Unfolding
old_unf = TidyEnv -> Unfolding -> Unfolding -> Unfolding
tidyUnfolding TidyEnv
rec_tidy_env Unfolding
old_unf Unfolding
old_unf
| Bool
otherwise = Unfolding -> Unfolding
zapUnfolding Unfolding
old_unf
in
((TidyOccEnv
tidy_env', VarEnv Id
var_env'), Id
id') }
tidyUnfolding :: TidyEnv -> Unfolding -> Unfolding -> Unfolding
tidyUnfolding :: TidyEnv -> Unfolding -> Unfolding -> Unfolding
tidyUnfolding TidyEnv
tidy_env df :: Unfolding
df@(DFunUnfolding { df_bndrs :: Unfolding -> [Id]
df_bndrs = [Id]
bndrs, df_args :: Unfolding -> [Expr Id]
df_args = [Expr Id]
args }) Unfolding
_
= Unfolding
df { df_bndrs :: [Id]
df_bndrs = [Id]
bndrs', df_args :: [Expr Id]
df_args = (Expr Id -> Expr Id) -> [Expr Id] -> [Expr Id]
forall a b. (a -> b) -> [a] -> [b]
map (TidyEnv -> Expr Id -> Expr Id
tidyExpr TidyEnv
tidy_env') [Expr Id]
args }
where
(TidyEnv
tidy_env', [Id]
bndrs') = TidyEnv -> [Id] -> (TidyEnv, [Id])
tidyBndrs TidyEnv
tidy_env [Id]
bndrs
tidyUnfolding TidyEnv
tidy_env
unf :: Unfolding
unf@(CoreUnfolding { uf_tmpl :: Unfolding -> Expr Id
uf_tmpl = Expr Id
unf_rhs, uf_src :: Unfolding -> UnfoldingSource
uf_src = UnfoldingSource
src })
Unfolding
unf_from_rhs
| UnfoldingSource -> Bool
isStableSource UnfoldingSource
src
= Unfolding -> Unfolding
seqIt (Unfolding -> Unfolding) -> Unfolding -> Unfolding
forall a b. (a -> b) -> a -> b
$ Unfolding
unf { uf_tmpl :: Expr Id
uf_tmpl = TidyEnv -> Expr Id -> Expr Id
tidyExpr TidyEnv
tidy_env Expr Id
unf_rhs }
| Bool
otherwise
= Unfolding
unf_from_rhs
where seqIt :: Unfolding -> Unfolding
seqIt Unfolding
unf = Unfolding -> ()
seqUnfolding Unfolding
unf () -> Unfolding -> Unfolding
`seq` Unfolding
unf
tidyUnfolding TidyEnv
_ Unfolding
unf Unfolding
_ = Unfolding
unf
(=:) :: a -> (a -> b) -> b
a
m =: :: forall a b. a -> (a -> b) -> b
=: a -> b
k = a
m a -> b -> b
`seq` a -> b
k a
m