{-# LANGUAGE CPP, BangPatterns, Strict, RecordWildCards #-}

module GHC.Iface.UpdateIdInfos
  ( updateModDetailsIdInfos
  ) where

import GHC.Prelude

import GHC.Core
import GHC.Core.InstEnv

import GHC.StgToCmm.Types (CgInfos (..))

import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Types.Name.Env
import GHC.Types.Name.Set
import GHC.Types.Var
import GHC.Types.TypeEnv
import GHC.Types.TyThing

import GHC.Unit.Module.ModDetails

import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic

#include "HsVersions.h"

-- | Update CafInfos and LFInfos of all occurrences (in rules, unfoldings, class
-- instances).
--
-- See Note [Conveying CAF-info and LFInfo between modules] in
-- GHC.StgToCmm.Types.
updateModDetailsIdInfos
  :: CgInfos
  -> ModDetails -- ^ ModDetails to update
  -> ModDetails

updateModDetailsIdInfos :: CgInfos -> ModDetails -> ModDetails
updateModDetailsIdInfos CgInfos
cg_infos ModDetails
mod_details =
  let
    ModDetails{ md_types :: ModDetails -> TypeEnv
md_types = TypeEnv
type_env -- for unfoldings
              , md_insts :: ModDetails -> [ClsInst]
md_insts = [ClsInst]
insts
              , md_rules :: ModDetails -> [CoreRule]
md_rules = [CoreRule]
rules
              } = ModDetails
mod_details

    -- type TypeEnv = NameEnv TyThing
    type_env' :: TypeEnv
type_env' = (TyThing -> TyThing) -> TypeEnv -> TypeEnv
forall elt1 elt2. (elt1 -> elt2) -> NameEnv elt1 -> NameEnv elt2
mapNameEnv (TypeEnv -> CgInfos -> TyThing -> TyThing
updateTyThingIdInfos TypeEnv
type_env' CgInfos
cg_infos) TypeEnv
type_env
    -- NB: Knot-tied! The result, type_env', is passed right back into into
    -- updateTyThingIdInfos, so that that occurrences of any Ids (e.g. in
    -- IdInfos, etc) can be looked up in the tidied env

    !insts' :: [ClsInst]
insts' = (ClsInst -> ClsInst) -> [ClsInst] -> [ClsInst]
forall a b. (a -> b) -> [a] -> [b]
strictMap (TypeEnv -> CgInfos -> ClsInst -> ClsInst
updateInstIdInfos TypeEnv
type_env' CgInfos
cg_infos) [ClsInst]
insts
    !rules' :: [CoreRule]
rules' = (CoreRule -> CoreRule) -> [CoreRule] -> [CoreRule]
forall a b. (a -> b) -> [a] -> [b]
strictMap (TypeEnv -> CoreRule -> CoreRule
updateRuleIdInfos TypeEnv
type_env') [CoreRule]
rules
  in
    ModDetails
mod_details{ md_types :: TypeEnv
md_types = TypeEnv
type_env'
               , md_insts :: [ClsInst]
md_insts = [ClsInst]
insts'
               , md_rules :: [CoreRule]
md_rules = [CoreRule]
rules'
               }

--------------------------------------------------------------------------------
-- Rules
--------------------------------------------------------------------------------

updateRuleIdInfos :: TypeEnv -> CoreRule -> CoreRule
updateRuleIdInfos :: TypeEnv -> CoreRule -> CoreRule
updateRuleIdInfos TypeEnv
_ rule :: CoreRule
rule@BuiltinRule{} = CoreRule
rule
updateRuleIdInfos TypeEnv
type_env Rule{ Bool
[Maybe Name]
[Id]
[CoreExpr]
Module
RuleName
Name
Activation
CoreExpr
IsOrphan
ru_rough :: CoreRule -> [Maybe Name]
ru_rhs :: CoreRule -> CoreExpr
ru_orphan :: CoreRule -> IsOrphan
ru_origin :: CoreRule -> Module
ru_name :: CoreRule -> RuleName
ru_local :: CoreRule -> Bool
ru_fn :: CoreRule -> Name
ru_bndrs :: CoreRule -> [Id]
ru_auto :: CoreRule -> Bool
ru_args :: CoreRule -> [CoreExpr]
ru_act :: CoreRule -> Activation
ru_local :: Bool
ru_orphan :: IsOrphan
ru_origin :: Module
ru_auto :: Bool
ru_rhs :: CoreExpr
ru_args :: [CoreExpr]
ru_bndrs :: [Id]
ru_rough :: [Maybe Name]
ru_fn :: Name
ru_act :: Activation
ru_name :: RuleName
.. } = Rule { ru_rhs :: CoreExpr
ru_rhs = TypeEnv -> CoreExpr -> CoreExpr
updateGlobalIds TypeEnv
type_env CoreExpr
ru_rhs, Bool
[Maybe Name]
[Id]
[CoreExpr]
Module
RuleName
Name
Activation
IsOrphan
ru_rough :: [Maybe Name]
ru_orphan :: IsOrphan
ru_origin :: Module
ru_name :: RuleName
ru_local :: Bool
ru_fn :: Name
ru_bndrs :: [Id]
ru_auto :: Bool
ru_args :: [CoreExpr]
ru_act :: Activation
ru_local :: Bool
ru_orphan :: IsOrphan
ru_origin :: Module
ru_auto :: Bool
ru_args :: [CoreExpr]
ru_bndrs :: [Id]
ru_rough :: [Maybe Name]
ru_fn :: Name
ru_act :: Activation
ru_name :: RuleName
.. }

--------------------------------------------------------------------------------
-- Instances
--------------------------------------------------------------------------------

updateInstIdInfos :: TypeEnv -> CgInfos -> ClsInst -> ClsInst
updateInstIdInfos :: TypeEnv -> CgInfos -> ClsInst -> ClsInst
updateInstIdInfos TypeEnv
type_env CgInfos
cg_infos =
    (Id -> Id) -> ClsInst -> ClsInst
updateClsInstDFun (TypeEnv -> Id -> Id
updateIdUnfolding TypeEnv
type_env (Id -> Id) -> (Id -> Id) -> Id -> Id
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CgInfos -> Id -> Id
updateIdInfo CgInfos
cg_infos)

--------------------------------------------------------------------------------
-- TyThings
--------------------------------------------------------------------------------

updateTyThingIdInfos :: TypeEnv -> CgInfos -> TyThing -> TyThing

updateTyThingIdInfos :: TypeEnv -> CgInfos -> TyThing -> TyThing
updateTyThingIdInfos TypeEnv
type_env CgInfos
cg_infos (AnId Id
id) =
    Id -> TyThing
AnId (TypeEnv -> Id -> Id
updateIdUnfolding TypeEnv
type_env (CgInfos -> Id -> Id
updateIdInfo CgInfos
cg_infos Id
id))

updateTyThingIdInfos TypeEnv
_ CgInfos
_ TyThing
other = TyThing
other -- AConLike, ATyCon, ACoAxiom

--------------------------------------------------------------------------------
-- Unfoldings
--------------------------------------------------------------------------------

updateIdUnfolding :: TypeEnv -> Id -> Id
updateIdUnfolding :: TypeEnv -> Id -> Id
updateIdUnfolding TypeEnv
type_env Id
id =
    case Id -> Unfolding
idUnfolding Id
id of
      CoreUnfolding{ Bool
CoreExpr
UnfoldingGuidance
UnfoldingSource
uf_tmpl :: Unfolding -> CoreExpr
uf_src :: Unfolding -> UnfoldingSource
uf_is_work_free :: Unfolding -> Bool
uf_is_value :: Unfolding -> Bool
uf_is_top :: Unfolding -> Bool
uf_is_conlike :: Unfolding -> Bool
uf_guidance :: Unfolding -> UnfoldingGuidance
uf_expandable :: Unfolding -> Bool
uf_guidance :: UnfoldingGuidance
uf_expandable :: Bool
uf_is_work_free :: Bool
uf_is_conlike :: Bool
uf_is_value :: Bool
uf_is_top :: Bool
uf_src :: UnfoldingSource
uf_tmpl :: CoreExpr
.. } ->
        Id -> Unfolding -> Id
setIdUnfolding Id
id CoreUnfolding{ uf_tmpl :: CoreExpr
uf_tmpl = TypeEnv -> CoreExpr -> CoreExpr
updateGlobalIds TypeEnv
type_env CoreExpr
uf_tmpl, Bool
UnfoldingGuidance
UnfoldingSource
uf_src :: UnfoldingSource
uf_is_work_free :: Bool
uf_is_value :: Bool
uf_is_top :: Bool
uf_is_conlike :: Bool
uf_guidance :: UnfoldingGuidance
uf_expandable :: Bool
uf_guidance :: UnfoldingGuidance
uf_expandable :: Bool
uf_is_work_free :: Bool
uf_is_conlike :: Bool
uf_is_value :: Bool
uf_is_top :: Bool
uf_src :: UnfoldingSource
.. }
      DFunUnfolding{ [Id]
[CoreExpr]
DataCon
df_con :: Unfolding -> DataCon
df_bndrs :: Unfolding -> [Id]
df_args :: Unfolding -> [CoreExpr]
df_args :: [CoreExpr]
df_con :: DataCon
df_bndrs :: [Id]
.. } ->
        Id -> Unfolding -> Id
setIdUnfolding Id
id DFunUnfolding{ df_args :: [CoreExpr]
df_args = (CoreExpr -> CoreExpr) -> [CoreExpr] -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map (TypeEnv -> CoreExpr -> CoreExpr
updateGlobalIds TypeEnv
type_env) [CoreExpr]
df_args, [Id]
DataCon
df_con :: DataCon
df_bndrs :: [Id]
df_con :: DataCon
df_bndrs :: [Id]
.. }
      Unfolding
_ -> Id
id

--------------------------------------------------------------------------------
-- Expressions
--------------------------------------------------------------------------------

updateIdInfo :: CgInfos -> Id -> Id
updateIdInfo :: CgInfos -> Id -> Id
updateIdInfo CgInfos{ cgNonCafs :: CgInfos -> NonCaffySet
cgNonCafs = NonCaffySet NameSet
non_cafs, cgLFInfos :: CgInfos -> ModuleLFInfos
cgLFInfos = ModuleLFInfos
lf_infos } Id
id =
    let
      not_caffy :: Bool
not_caffy = Name -> NameSet -> Bool
elemNameSet (Id -> Name
idName Id
id) NameSet
non_cafs
      mb_lf_info :: Maybe LambdaFormInfo
mb_lf_info = ModuleLFInfos -> Name -> Maybe LambdaFormInfo
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv ModuleLFInfos
lf_infos (Id -> Name
idName Id
id)

      id1 :: Id
id1 = if Bool
not_caffy then Id -> CafInfo -> Id
setIdCafInfo Id
id CafInfo
NoCafRefs else Id
id
      id2 :: Id
id2 = case Maybe LambdaFormInfo
mb_lf_info of
              Maybe LambdaFormInfo
Nothing -> Id
id1
              Just LambdaFormInfo
lf_info -> Id -> LambdaFormInfo -> Id
setIdLFInfo Id
id1 LambdaFormInfo
lf_info
    in
      Id
id2

--------------------------------------------------------------------------------

updateGlobalIds :: NameEnv TyThing -> CoreExpr -> CoreExpr
-- Update occurrences of GlobalIds as directed by 'env'
-- The 'env' maps a GlobalId to a version with accurate CAF info
-- (and in due course perhaps other back-end-related info)
updateGlobalIds :: TypeEnv -> CoreExpr -> CoreExpr
updateGlobalIds TypeEnv
env CoreExpr
e = TypeEnv -> CoreExpr -> CoreExpr
go TypeEnv
env CoreExpr
e
  where
    go_id :: NameEnv TyThing -> Id -> Id
    go_id :: TypeEnv -> Id -> Id
go_id TypeEnv
env Id
var =
      case TypeEnv -> Name -> Maybe TyThing
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv TypeEnv
env (Id -> Name
varName Id
var) of
        Maybe TyThing
Nothing -> Id
var
        Just (AnId Id
id) -> Id
id
        Just TyThing
other -> String -> SDoc -> Id
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"UpdateIdInfos.updateGlobalIds" (SDoc -> Id) -> SDoc -> Id
forall a b. (a -> b) -> a -> b
$
          String -> SDoc
text String
"Found a non-Id for Id Name" SDoc -> SDoc -> SDoc
<+> Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Id -> Name
varName Id
var) SDoc -> SDoc -> SDoc
$$
          Int -> SDoc -> SDoc
nest Int
4 (String -> SDoc
text String
"Id:" SDoc -> SDoc -> SDoc
<+> Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
var SDoc -> SDoc -> SDoc
$$
                  String -> SDoc
text String
"TyThing:" SDoc -> SDoc -> SDoc
<+> TyThing -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyThing
other)

    go :: NameEnv TyThing -> CoreExpr -> CoreExpr
    go :: TypeEnv -> CoreExpr -> CoreExpr
go TypeEnv
env (Var Id
v) = Id -> CoreExpr
forall b. Id -> Expr b
Var (TypeEnv -> Id -> Id
go_id TypeEnv
env Id
v)
    go TypeEnv
_ e :: CoreExpr
e@Lit{} = CoreExpr
e
    go TypeEnv
env (App CoreExpr
e1 CoreExpr
e2) = CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App (TypeEnv -> CoreExpr -> CoreExpr
go TypeEnv
env CoreExpr
e1) (TypeEnv -> CoreExpr -> CoreExpr
go TypeEnv
env CoreExpr
e2)
    go TypeEnv
env (Lam Id
b CoreExpr
e) = TypeEnv -> [Id] -> CoreExpr -> CoreExpr
forall a b. NameEnv a -> [Id] -> b -> b
assertNotInNameEnv TypeEnv
env [Id
b] (Id -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam Id
b (TypeEnv -> CoreExpr -> CoreExpr
go TypeEnv
env CoreExpr
e))
    go TypeEnv
env (Let Bind Id
bs CoreExpr
e) = Bind Id -> CoreExpr -> CoreExpr
forall b. Bind b -> Expr b -> Expr b
Let (TypeEnv -> Bind Id -> Bind Id
go_binds TypeEnv
env Bind Id
bs) (TypeEnv -> CoreExpr -> CoreExpr
go TypeEnv
env CoreExpr
e)
    go TypeEnv
env (Case CoreExpr
e Id
b Type
ty [Alt Id]
alts) =
        TypeEnv -> [Id] -> CoreExpr -> CoreExpr
forall a b. NameEnv a -> [Id] -> b -> b
assertNotInNameEnv TypeEnv
env [Id
b] (CoreExpr -> Id -> Type -> [Alt Id] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case (TypeEnv -> CoreExpr -> CoreExpr
go TypeEnv
env CoreExpr
e) Id
b Type
ty ((Alt Id -> Alt Id) -> [Alt Id] -> [Alt Id]
forall a b. (a -> b) -> [a] -> [b]
map Alt Id -> Alt Id
go_alt [Alt Id]
alts))
      where
         go_alt :: Alt Id -> Alt Id
go_alt (Alt AltCon
k [Id]
bs CoreExpr
e) = TypeEnv -> [Id] -> Alt Id -> Alt Id
forall a b. NameEnv a -> [Id] -> b -> b
assertNotInNameEnv TypeEnv
env [Id]
bs (AltCon -> [Id] -> CoreExpr -> Alt Id
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
k [Id]
bs (TypeEnv -> CoreExpr -> CoreExpr
go TypeEnv
env CoreExpr
e))
    go TypeEnv
env (Cast CoreExpr
e CoercionR
c) = CoreExpr -> CoercionR -> CoreExpr
forall b. Expr b -> CoercionR -> Expr b
Cast (TypeEnv -> CoreExpr -> CoreExpr
go TypeEnv
env CoreExpr
e) CoercionR
c
    go TypeEnv
env (Tick CoreTickish
t CoreExpr
e) = CoreTickish -> CoreExpr -> CoreExpr
forall b. CoreTickish -> Expr b -> Expr b
Tick CoreTickish
t (TypeEnv -> CoreExpr -> CoreExpr
go TypeEnv
env CoreExpr
e)
    go TypeEnv
_ e :: CoreExpr
e@Type{} = CoreExpr
e
    go TypeEnv
_ e :: CoreExpr
e@Coercion{} = CoreExpr
e

    go_binds :: NameEnv TyThing -> CoreBind -> CoreBind
    go_binds :: TypeEnv -> Bind Id -> Bind Id
go_binds TypeEnv
env (NonRec Id
b CoreExpr
e) =
      TypeEnv -> [Id] -> Bind Id -> Bind Id
forall a b. NameEnv a -> [Id] -> b -> b
assertNotInNameEnv TypeEnv
env [Id
b] (Id -> CoreExpr -> Bind Id
forall b. b -> Expr b -> Bind b
NonRec Id
b (TypeEnv -> CoreExpr -> CoreExpr
go TypeEnv
env CoreExpr
e))
    go_binds TypeEnv
env (Rec [(Id, CoreExpr)]
prs) =
      TypeEnv -> [Id] -> Bind Id -> Bind Id
forall a b. NameEnv a -> [Id] -> b -> b
assertNotInNameEnv TypeEnv
env (((Id, CoreExpr) -> Id) -> [(Id, CoreExpr)] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map (Id, CoreExpr) -> Id
forall a b. (a, b) -> a
fst [(Id, CoreExpr)]
prs) ([(Id, CoreExpr)] -> Bind Id
forall b. [(b, Expr b)] -> Bind b
Rec ((CoreExpr -> CoreExpr) -> [(Id, CoreExpr)] -> [(Id, CoreExpr)]
forall b c a. (b -> c) -> [(a, b)] -> [(a, c)]
mapSnd (TypeEnv -> CoreExpr -> CoreExpr
go TypeEnv
env) [(Id, CoreExpr)]
prs))

-- In `updateGlobaLIds` Names of local binders should not shadow Name of
-- globals. This assertion is to check that.
assertNotInNameEnv :: NameEnv a -> [Id] -> b -> b
assertNotInNameEnv :: forall a b. NameEnv a -> [Id] -> b -> b
assertNotInNameEnv NameEnv a
env [Id]
ids b
x = ASSERT(not (any (\id -> elemNameEnv (idName id) env) ids)) x