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

module GHC.Iface.UpdateCafInfos
  ( updateModDetailsCafInfos
  ) where

import GHC.Prelude

import GHC.Core
import GHC.Driver.Session
import GHC.Driver.Types
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Core.InstEnv
import GHC.Types.Name.Env
import GHC.Types.Name.Set
import GHC.Utils.Misc
import GHC.Types.Var
import GHC.Utils.Outputable

#include "HsVersions.h"

-- | Update CafInfos of all occurences (in rules, unfoldings, class instances)
updateModDetailsCafInfos
  :: DynFlags
  -> NonCaffySet -- ^ Non-CAFFY names in the module. Names not in this set are CAFFY.
  -> ModDetails -- ^ ModDetails to update
  -> ModDetails

updateModDetailsCafInfos :: DynFlags -> NonCaffySet -> ModDetails -> ModDetails
updateModDetailsCafInfos DynFlags
dflags NonCaffySet
_ ModDetails
mod_details
  | GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_OmitInterfacePragmas DynFlags
dflags
  = ModDetails
mod_details

updateModDetailsCafInfos DynFlags
_ (NonCaffySet NameSet
non_cafs) ModDetails
mod_details =
  {- pprTrace "updateModDetailsCafInfos" (text "non_cafs:" <+> ppr non_cafs) $ -}
  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
    ~TypeEnv
type_env' = (TyThing -> TyThing) -> TypeEnv -> TypeEnv
forall elt1 elt2. (elt1 -> elt2) -> NameEnv elt1 -> NameEnv elt2
mapNameEnv (TypeEnv -> NameSet -> TyThing -> TyThing
updateTyThingCafInfos TypeEnv
type_env' NameSet
non_cafs) TypeEnv
type_env
    -- Not strict!

    !insts' :: [ClsInst]
insts' = (ClsInst -> ClsInst) -> [ClsInst] -> [ClsInst]
forall a b. (a -> b) -> [a] -> [b]
strictMap (TypeEnv -> NameSet -> ClsInst -> ClsInst
updateInstCafInfos TypeEnv
type_env' NameSet
non_cafs) [ClsInst]
insts
    !rules' :: [CoreRule]
rules' = (CoreRule -> CoreRule) -> [CoreRule] -> [CoreRule]
forall a b. (a -> b) -> [a] -> [b]
strictMap (TypeEnv -> CoreRule -> CoreRule
updateRuleCafInfos 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
--------------------------------------------------------------------------------

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

updateInstCafInfos :: TypeEnv -> NameSet -> ClsInst -> ClsInst
updateInstCafInfos :: TypeEnv -> NameSet -> ClsInst -> ClsInst
updateInstCafInfos TypeEnv
type_env NameSet
non_cafs =
    (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
. NameSet -> Id -> Id
updateIdCafInfo NameSet
non_cafs)

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

updateTyThingCafInfos :: TypeEnv -> NameSet -> TyThing -> TyThing

updateTyThingCafInfos :: TypeEnv -> NameSet -> TyThing -> TyThing
updateTyThingCafInfos TypeEnv
type_env NameSet
non_cafs (AnId Id
id) =
    Id -> TyThing
AnId (TypeEnv -> Id -> Id
updateIdUnfolding TypeEnv
type_env (NameSet -> Id -> Id
updateIdCafInfo NameSet
non_cafs Id
id))

updateTyThingCafInfos TypeEnv
_ NameSet
_ 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
UnfoldingGuidance
UnfoldingSource
CoreExpr
uf_guidance :: Unfolding -> UnfoldingGuidance
uf_expandable :: Unfolding -> Bool
uf_is_work_free :: Unfolding -> Bool
uf_is_conlike :: Unfolding -> Bool
uf_is_value :: Unfolding -> Bool
uf_is_top :: Unfolding -> Bool
uf_src :: Unfolding -> UnfoldingSource
uf_tmpl :: Unfolding -> CoreExpr
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 :: CoreExpr
-> UnfoldingSource
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> UnfoldingGuidance
-> Unfolding
CoreUnfolding{ uf_tmpl :: CoreExpr
uf_tmpl = TypeEnv -> CoreExpr -> CoreExpr
updateGlobalIds TypeEnv
type_env CoreExpr
uf_tmpl, Bool
UnfoldingGuidance
UnfoldingSource
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_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_args :: Unfolding -> [CoreExpr]
df_con :: Unfolding -> DataCon
df_bndrs :: Unfolding -> [Id]
df_args :: [CoreExpr]
df_con :: DataCon
df_bndrs :: [Id]
.. } ->
        Id -> Unfolding -> Id
setIdUnfolding Id
id DFunUnfolding :: [Id] -> DataCon -> [CoreExpr] -> Unfolding
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
--------------------------------------------------------------------------------

updateIdCafInfo :: NameSet -> Id -> Id
updateIdCafInfo :: NameSet -> Id -> Id
updateIdCafInfo NameSet
non_cafs Id
id
  | Id -> Name
idName Id
id Name -> NameSet -> Bool
`elemNameSet` NameSet
non_cafs
  = -- pprTrace "updateIdCafInfo" (text "Marking" <+> ppr id <+> parens (ppr (idName id)) <+> text "as non-CAFFY") $
    Id
id Id -> CafInfo -> Id
`setIdCafInfo` CafInfo
NoCafRefs
  | Bool
otherwise
  = Id
id

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

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
"GHC.Iface.UpdateCafInfos.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
External instance of the constraint type Outputable Name
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
External instance of the constraint type Outputable Id
ppr Id
var SDoc -> SDoc -> SDoc
$$
                  String -> SDoc
text String
"TyThing:" SDoc -> SDoc -> SDoc
<+> TyThing -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable TyThing
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
forall {a}. (a, [Id], CoreExpr) -> (a, [Id], CoreExpr)
go_alt [Alt Id]
alts))
      where
         go_alt :: (a, [Id], CoreExpr) -> (a, [Id], CoreExpr)
go_alt (a
k,[Id]
bs,CoreExpr
e) = TypeEnv -> [Id] -> (a, [Id], CoreExpr) -> (a, [Id], CoreExpr)
forall a b. NameEnv a -> [Id] -> b -> b
assertNotInNameEnv TypeEnv
env [Id]
bs (a
k, [Id]
bs, TypeEnv -> CoreExpr -> CoreExpr
go TypeEnv
env CoreExpr
e)
    go TypeEnv
env (Cast CoreExpr
e Coercion
c) = CoreExpr -> Coercion -> CoreExpr
forall b. Expr b -> Coercion -> Expr b
Cast (TypeEnv -> CoreExpr -> CoreExpr
go TypeEnv
env CoreExpr
e) Coercion
c
    go TypeEnv
env (Tick Tickish Id
t CoreExpr
e) = Tickish Id -> CoreExpr -> CoreExpr
forall b. Tickish Id -> Expr b -> Expr b
Tick Tickish Id
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 :: NameEnv a -> [Id] -> b -> b
assertNotInNameEnv NameEnv a
env [Id]
ids b
x = ASSERT(not (any (\id -> elemNameEnv (idName id) env) ids)) x