module GHC.CoreToIface
(
toIfaceTvBndr
, toIfaceTvBndrs
, toIfaceIdBndr
, toIfaceBndr
, toIfaceForAllBndr
, toIfaceTyCoVarBinders
, toIfaceTyVar
, toIfaceType, toIfaceTypeX
, toIfaceKind
, toIfaceTcArgs
, toIfaceTyCon
, toIfaceTyCon_name
, toIfaceTyLit
, tidyToIfaceType
, tidyToIfaceContext
, tidyToIfaceTcArgs
, toIfaceCoercion, toIfaceCoercionX
, patSynToIfaceDecl
, toIfaceExpr
, toIfaceBang
, toIfaceSrcBang
, toIfaceLetBndr
, toIfaceIdDetails
, toIfaceIdInfo
, toIfUnfolding
, toIfaceTickish
, toIfaceBind
, toIfaceAlt
, toIfaceCon
, toIfaceApp
, toIfaceVar
, toIfaceLFInfo
) where
#include "HsVersions.h"
import GHC.Prelude
import GHC.Iface.Syntax
import GHC.Core.DataCon
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.StgToCmm.Types
import GHC.Core
import GHC.Core.TyCon hiding ( pprPromotionQuote )
import GHC.Core.Coercion.Axiom
import GHC.Builtin.Types.Prim ( eqPrimTyCon, eqReprPrimTyCon )
import GHC.Builtin.Types ( heqTyCon )
import GHC.Types.Id.Make ( noinlineIdName )
import GHC.Builtin.Names
import GHC.Types.Name
import GHC.Types.Basic
import GHC.Core.Type
import GHC.Core.Multiplicity
import GHC.Core.PatSyn
import GHC.Utils.Outputable
import GHC.Data.FastString
import GHC.Utils.Misc
import GHC.Types.Var
import GHC.Types.Var.Env
import GHC.Types.Var.Set
import GHC.Core.TyCo.Rep
import GHC.Core.TyCo.Tidy ( tidyCo )
import GHC.Types.Demand ( isTopSig )
import GHC.Types.Cpr ( topCprSig )
import Data.Maybe ( catMaybes )
toIfaceTvBndr :: TyVar -> IfaceTvBndr
toIfaceTvBndr = toIfaceTvBndrX emptyVarSet
toIfaceTvBndrX :: VarSet -> TyVar -> IfaceTvBndr
toIfaceTvBndrX fr tyvar = ( occNameFS (getOccName tyvar)
, toIfaceTypeX fr (tyVarKind tyvar)
)
toIfaceTvBndrs :: [TyVar] -> [IfaceTvBndr]
toIfaceTvBndrs = map toIfaceTvBndr
toIfaceIdBndr :: Id -> IfaceIdBndr
toIfaceIdBndr = toIfaceIdBndrX emptyVarSet
toIfaceIdBndrX :: VarSet -> CoVar -> IfaceIdBndr
toIfaceIdBndrX fr covar = ( toIfaceType (idMult covar)
, occNameFS (getOccName covar)
, toIfaceTypeX fr (varType covar)
)
toIfaceBndr :: Var -> IfaceBndr
toIfaceBndr var
| isId var = IfaceIdBndr (toIfaceIdBndr var)
| otherwise = IfaceTvBndr (toIfaceTvBndr var)
toIfaceBndrX :: VarSet -> Var -> IfaceBndr
toIfaceBndrX fr var
| isId var = IfaceIdBndr (toIfaceIdBndrX fr var)
| otherwise = IfaceTvBndr (toIfaceTvBndrX fr var)
toIfaceTyCoVarBinder :: VarBndr Var vis -> VarBndr IfaceBndr vis
toIfaceTyCoVarBinder (Bndr tv vis) = Bndr (toIfaceBndr tv) vis
toIfaceTyCoVarBinders :: [VarBndr Var vis] -> [VarBndr IfaceBndr vis]
toIfaceTyCoVarBinders = map toIfaceTyCoVarBinder
toIfaceKind :: Type -> IfaceType
toIfaceKind = toIfaceType
toIfaceType :: Type -> IfaceType
toIfaceType = toIfaceTypeX emptyVarSet
toIfaceTypeX :: VarSet -> Type -> IfaceType
toIfaceTypeX fr (TyVarTy tv)
| tv `elemVarSet` fr = IfaceFreeTyVar tv
| otherwise = IfaceTyVar (toIfaceTyVar tv)
toIfaceTypeX fr ty@(AppTy {}) =
let (head, args) = splitAppTys ty
in IfaceAppTy (toIfaceTypeX fr head) (toIfaceAppTyArgsX fr head args)
toIfaceTypeX _ (LitTy n) = IfaceLitTy (toIfaceTyLit n)
toIfaceTypeX fr (ForAllTy b t) = IfaceForAllTy (toIfaceForAllBndrX fr b)
(toIfaceTypeX (fr `delVarSet` binderVar b) t)
toIfaceTypeX fr (FunTy { ft_arg = t1, ft_mult = w, ft_res = t2, ft_af = af })
= IfaceFunTy af (toIfaceTypeX fr w) (toIfaceTypeX fr t1) (toIfaceTypeX fr t2)
toIfaceTypeX fr (CastTy ty co) = IfaceCastTy (toIfaceTypeX fr ty) (toIfaceCoercionX fr co)
toIfaceTypeX fr (CoercionTy co) = IfaceCoercionTy (toIfaceCoercionX fr co)
toIfaceTypeX fr (TyConApp tc tys)
| Just sort <- tyConTuple_maybe tc
, n_tys == arity
= IfaceTupleTy sort NotPromoted (toIfaceTcArgsX fr tc tys)
| Just dc <- isPromotedDataCon_maybe tc
, isTupleDataCon dc
, n_tys == 2*arity
= IfaceTupleTy BoxedTuple IsPromoted (toIfaceTcArgsX fr tc (drop arity tys))
| tc `elem` [ eqPrimTyCon, eqReprPrimTyCon, heqTyCon ]
, (k1:k2:_) <- tys
= let info = IfaceTyConInfo NotPromoted sort
sort | k1 `eqType` k2 = IfaceEqualityTyCon
| otherwise = IfaceNormalTyCon
in IfaceTyConApp (IfaceTyCon (tyConName tc) info) (toIfaceTcArgsX fr tc tys)
| otherwise
= IfaceTyConApp (toIfaceTyCon tc) (toIfaceTcArgsX fr tc tys)
where
arity = tyConArity tc
n_tys = length tys
toIfaceTyVar :: TyVar -> FastString
toIfaceTyVar = occNameFS . getOccName
toIfaceCoVar :: CoVar -> FastString
toIfaceCoVar = occNameFS . getOccName
toIfaceForAllBndr :: (VarBndr TyCoVar flag) -> (VarBndr IfaceBndr flag)
toIfaceForAllBndr = toIfaceForAllBndrX emptyVarSet
toIfaceForAllBndrX :: VarSet -> (VarBndr TyCoVar flag) -> (VarBndr IfaceBndr flag)
toIfaceForAllBndrX fr (Bndr v vis) = Bndr (toIfaceBndrX fr v) vis
toIfaceTyCon :: TyCon -> IfaceTyCon
toIfaceTyCon tc
= IfaceTyCon tc_name info
where
tc_name = tyConName tc
info = IfaceTyConInfo promoted sort
promoted | isPromotedDataCon tc = IsPromoted
| otherwise = NotPromoted
tupleSort :: TyCon -> Maybe IfaceTyConSort
tupleSort tc' =
case tyConTuple_maybe tc' of
Just UnboxedTuple -> let arity = tyConArity tc' `div` 2
in Just $ IfaceTupleTyCon arity UnboxedTuple
Just sort -> let arity = tyConArity tc'
in Just $ IfaceTupleTyCon arity sort
Nothing -> Nothing
sort
| Just tsort <- tupleSort tc = tsort
| Just dcon <- isPromotedDataCon_maybe tc
, let tc' = dataConTyCon dcon
, Just tsort <- tupleSort tc' = tsort
| isUnboxedSumTyCon tc
, Just cons <- isDataSumTyCon_maybe tc = IfaceSumTyCon (length cons)
| otherwise = IfaceNormalTyCon
toIfaceTyCon_name :: Name -> IfaceTyCon
toIfaceTyCon_name n = IfaceTyCon n info
where info = IfaceTyConInfo NotPromoted IfaceNormalTyCon
toIfaceTyLit :: TyLit -> IfaceTyLit
toIfaceTyLit (NumTyLit x) = IfaceNumTyLit x
toIfaceTyLit (StrTyLit x) = IfaceStrTyLit x
toIfaceCoercion :: Coercion -> IfaceCoercion
toIfaceCoercion = toIfaceCoercionX emptyVarSet
toIfaceCoercionX :: VarSet -> Coercion -> IfaceCoercion
toIfaceCoercionX fr co
= go co
where
go_mco MRefl = IfaceMRefl
go_mco (MCo co) = IfaceMCo $ go co
go (Refl ty) = IfaceReflCo (toIfaceTypeX fr ty)
go (GRefl r ty mco) = IfaceGReflCo r (toIfaceTypeX fr ty) (go_mco mco)
go (CoVarCo cv)
| cv `elemVarSet` fr = IfaceFreeCoVar cv
| otherwise = IfaceCoVarCo (toIfaceCoVar cv)
go (HoleCo h) = IfaceHoleCo (coHoleCoVar h)
go (AppCo co1 co2) = IfaceAppCo (go co1) (go co2)
go (SymCo co) = IfaceSymCo (go co)
go (TransCo co1 co2) = IfaceTransCo (go co1) (go co2)
go (NthCo _r d co) = IfaceNthCo d (go co)
go (LRCo lr co) = IfaceLRCo lr (go co)
go (InstCo co arg) = IfaceInstCo (go co) (go arg)
go (KindCo c) = IfaceKindCo (go c)
go (SubCo co) = IfaceSubCo (go co)
go (AxiomRuleCo co cs) = IfaceAxiomRuleCo (coaxrName co) (map go cs)
go (AxiomInstCo c i cs) = IfaceAxiomInstCo (coAxiomName c) i (map go cs)
go (UnivCo p r t1 t2) = IfaceUnivCo (go_prov p) r
(toIfaceTypeX fr t1)
(toIfaceTypeX fr t2)
go (TyConAppCo r tc cos)
| tc `hasKey` funTyConKey
, [_,_,_,_, _] <- cos = pprPanic "toIfaceCoercion" empty
| otherwise =
IfaceTyConAppCo r (toIfaceTyCon tc) (map go cos)
go (FunCo r w co1 co2) = IfaceFunCo r (go w) (go co1) (go co2)
go (ForAllCo tv k co) = IfaceForAllCo (toIfaceBndr tv)
(toIfaceCoercionX fr' k)
(toIfaceCoercionX fr' co)
where
fr' = fr `delVarSet` tv
go_prov :: UnivCoProvenance -> IfaceUnivCoProv
go_prov (PhantomProv co) = IfacePhantomProv (go co)
go_prov (ProofIrrelProv co) = IfaceProofIrrelProv (go co)
go_prov (PluginProv str) = IfacePluginProv str
toIfaceTcArgs :: TyCon -> [Type] -> IfaceAppArgs
toIfaceTcArgs = toIfaceTcArgsX emptyVarSet
toIfaceTcArgsX :: VarSet -> TyCon -> [Type] -> IfaceAppArgs
toIfaceTcArgsX fr tc ty_args = toIfaceAppArgsX fr (tyConKind tc) ty_args
toIfaceAppTyArgsX :: VarSet -> Type -> [Type] -> IfaceAppArgs
toIfaceAppTyArgsX fr ty ty_args = toIfaceAppArgsX fr (typeKind ty) ty_args
toIfaceAppArgsX :: VarSet -> Kind -> [Type] -> IfaceAppArgs
toIfaceAppArgsX fr kind ty_args
= go (mkEmptyTCvSubst in_scope) kind ty_args
where
in_scope = mkInScopeSet (tyCoVarsOfTypes ty_args)
go _ _ [] = IA_Nil
go env ty ts
| Just ty' <- coreView ty
= go env ty' ts
go env (ForAllTy (Bndr tv vis) res) (t:ts)
= IA_Arg t' vis ts'
where
t' = toIfaceTypeX fr t
ts' = go (extendTCvSubst env tv t) res ts
go env (FunTy { ft_af = af, ft_res = res }) (t:ts)
= IA_Arg (toIfaceTypeX fr t) argf (go env res ts)
where
argf = case af of
VisArg -> Required
InvisArg -> Inferred
go env ty ts@(t1:ts1)
| not (isEmptyTCvSubst env)
= go (zapTCvSubst env) (substTy env ty) ts
| otherwise
=
WARN( True, ppr kind $$ ppr ty_args )
IA_Arg (toIfaceTypeX fr t1) Required (go env ty ts1)
tidyToIfaceType :: TidyEnv -> Type -> IfaceType
tidyToIfaceType env ty = toIfaceType (tidyType env ty)
tidyToIfaceTcArgs :: TidyEnv -> TyCon -> [Type] -> IfaceAppArgs
tidyToIfaceTcArgs env tc tys = toIfaceTcArgs tc (tidyTypes env tys)
tidyToIfaceContext :: TidyEnv -> ThetaType -> IfaceContext
tidyToIfaceContext env theta = map (tidyToIfaceType env) theta
patSynToIfaceDecl :: PatSyn -> IfaceDecl
patSynToIfaceDecl ps
= IfacePatSyn { ifName = getName $ ps
, ifPatMatcher = to_if_pr (patSynMatcher ps)
, ifPatBuilder = fmap to_if_pr (patSynBuilder ps)
, ifPatIsInfix = patSynIsInfix ps
, ifPatUnivBndrs = map toIfaceForAllBndr univ_bndrs'
, ifPatExBndrs = map toIfaceForAllBndr ex_bndrs'
, ifPatProvCtxt = tidyToIfaceContext env2 prov_theta
, ifPatReqCtxt = tidyToIfaceContext env2 req_theta
, ifPatArgs = map (tidyToIfaceType env2 . scaledThing) args
, ifPatTy = tidyToIfaceType env2 rhs_ty
, ifFieldLabels = (patSynFieldLabels ps)
}
where
(_univ_tvs, req_theta, _ex_tvs, prov_theta, args, rhs_ty) = patSynSig ps
univ_bndrs = patSynUnivTyVarBinders ps
ex_bndrs = patSynExTyVarBinders ps
(env1, univ_bndrs') = tidyTyCoVarBinders emptyTidyEnv univ_bndrs
(env2, ex_bndrs') = tidyTyCoVarBinders env1 ex_bndrs
to_if_pr (id, needs_dummy) = (idName id, needs_dummy)
toIfaceBang :: TidyEnv -> HsImplBang -> IfaceBang
toIfaceBang _ HsLazy = IfNoBang
toIfaceBang _ (HsUnpack Nothing) = IfUnpack
toIfaceBang env (HsUnpack (Just co)) = IfUnpackCo (toIfaceCoercion (tidyCo env co))
toIfaceBang _ HsStrict = IfStrict
toIfaceSrcBang :: HsSrcBang -> IfaceSrcBang
toIfaceSrcBang (HsSrcBang _ unpk bang) = IfSrcBang unpk bang
toIfaceLetBndr :: Id -> IfaceLetBndr
toIfaceLetBndr id = IfLetBndr (occNameFS (getOccName id))
(toIfaceType (idType id))
(toIfaceIdInfo (idInfo id))
(toIfaceJoinInfo (isJoinId_maybe id))
toIfaceIdDetails :: IdDetails -> IfaceIdDetails
toIfaceIdDetails VanillaId = IfVanillaId
toIfaceIdDetails (DFunId {}) = IfDFunId
toIfaceIdDetails (RecSelId { sel_naughty = n
, sel_tycon = tc }) =
let iface = case tc of
RecSelData ty_con -> Left (toIfaceTyCon ty_con)
RecSelPatSyn pat_syn -> Right (patSynToIfaceDecl pat_syn)
in IfRecSelId iface n
toIfaceIdDetails other = pprTrace "toIfaceIdDetails" (ppr other)
IfVanillaId
toIfaceIdInfo :: IdInfo -> IfaceIdInfo
toIfaceIdInfo id_info
= catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo, cpr_hsinfo,
inline_hsinfo, unfold_hsinfo, levity_hsinfo]
where
arity_info = arityInfo id_info
arity_hsinfo | arity_info == 0 = Nothing
| otherwise = Just (HsArity arity_info)
caf_info = cafInfo id_info
caf_hsinfo = case caf_info of
NoCafRefs -> Just HsNoCafRefs
_other -> Nothing
sig_info = strictnessInfo id_info
strict_hsinfo | not (isTopSig sig_info) = Just (HsStrictness sig_info)
| otherwise = Nothing
cpr_info = cprInfo id_info
cpr_hsinfo | cpr_info /= topCprSig = Just (HsCpr cpr_info)
| otherwise = Nothing
unfold_hsinfo = toIfUnfolding loop_breaker (unfoldingInfo id_info)
loop_breaker = isStrongLoopBreaker (occInfo id_info)
inline_prag = inlinePragInfo id_info
inline_hsinfo | isDefaultInlinePragma inline_prag = Nothing
| otherwise = Just (HsInline inline_prag)
levity_hsinfo | isNeverLevPolyIdInfo id_info = Just HsLevity
| otherwise = Nothing
toIfaceJoinInfo :: Maybe JoinArity -> IfaceJoinInfo
toIfaceJoinInfo (Just ar) = IfaceJoinPoint ar
toIfaceJoinInfo Nothing = IfaceNotJoinPoint
toIfUnfolding :: Bool -> Unfolding -> Maybe IfaceInfoItem
toIfUnfolding lb (CoreUnfolding { uf_tmpl = rhs
, uf_src = src
, uf_guidance = guidance })
= Just $ HsUnfold lb $
case src of
InlineStable
-> case guidance of
UnfWhen {ug_arity = arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok }
-> IfInlineRule arity unsat_ok boring_ok if_rhs
_other -> IfCoreUnfold True if_rhs
InlineCompulsory -> IfCompulsory if_rhs
InlineRhs -> IfCoreUnfold False if_rhs
where
if_rhs = toIfaceExpr rhs
toIfUnfolding lb (DFunUnfolding { df_bndrs = bndrs, df_args = args })
= Just (HsUnfold lb (IfDFunUnfold (map toIfaceBndr bndrs) (map toIfaceExpr args)))
toIfUnfolding _ (OtherCon {}) = Nothing
toIfUnfolding _ BootUnfolding = Nothing
toIfUnfolding _ NoUnfolding = Nothing
toIfaceExpr :: CoreExpr -> IfaceExpr
toIfaceExpr (Var v) = toIfaceVar v
toIfaceExpr (Lit l) = IfaceLit l
toIfaceExpr (Type ty) = IfaceType (toIfaceType ty)
toIfaceExpr (Coercion co) = IfaceCo (toIfaceCoercion co)
toIfaceExpr (Lam x b) = IfaceLam (toIfaceBndr x, toIfaceOneShot x) (toIfaceExpr b)
toIfaceExpr (App f a) = toIfaceApp f [a]
toIfaceExpr (Case s x ty as)
| null as = IfaceECase (toIfaceExpr s) (toIfaceType ty)
| otherwise = IfaceCase (toIfaceExpr s) (getOccFS x) (map toIfaceAlt as)
toIfaceExpr (Let b e) = IfaceLet (toIfaceBind b) (toIfaceExpr e)
toIfaceExpr (Cast e co) = IfaceCast (toIfaceExpr e) (toIfaceCoercion co)
toIfaceExpr (Tick t e)
| Just t' <- toIfaceTickish t = IfaceTick t' (toIfaceExpr e)
| otherwise = toIfaceExpr e
toIfaceOneShot :: Id -> IfaceOneShot
toIfaceOneShot id | isId id
, OneShotLam <- oneShotInfo (idInfo id)
= IfaceOneShot
| otherwise
= IfaceNoOneShot
toIfaceTickish :: Tickish Id -> Maybe IfaceTickish
toIfaceTickish (ProfNote cc tick push) = Just (IfaceSCC cc tick push)
toIfaceTickish (HpcTick modl ix) = Just (IfaceHpcTick modl ix)
toIfaceTickish (SourceNote src names) = Just (IfaceSource src names)
toIfaceTickish (Breakpoint {}) = Nothing
toIfaceBind :: Bind Id -> IfaceBinding
toIfaceBind (NonRec b r) = IfaceNonRec (toIfaceLetBndr b) (toIfaceExpr r)
toIfaceBind (Rec prs) = IfaceRec [(toIfaceLetBndr b, toIfaceExpr r) | (b,r) <- prs]
toIfaceAlt :: (AltCon, [Var], CoreExpr)
-> (IfaceConAlt, [FastString], IfaceExpr)
toIfaceAlt (c,bs,r) = (toIfaceCon c, map getOccFS bs, toIfaceExpr r)
toIfaceCon :: AltCon -> IfaceConAlt
toIfaceCon (DataAlt dc) = IfaceDataAlt (getName dc)
toIfaceCon (LitAlt l) = IfaceLitAlt l
toIfaceCon DEFAULT = IfaceDefault
toIfaceApp :: Expr CoreBndr -> [Arg CoreBndr] -> IfaceExpr
toIfaceApp (App f a) as = toIfaceApp f (a:as)
toIfaceApp (Var v) as
= case isDataConWorkId_maybe v of
Just dc | saturated
, Just tup_sort <- tyConTuple_maybe tc
-> IfaceTuple tup_sort tup_args
where
val_args = dropWhile isTypeArg as
saturated = val_args `lengthIs` idArity v
tup_args = map toIfaceExpr val_args
tc = dataConTyCon dc
_ -> mkIfaceApps (toIfaceVar v) as
toIfaceApp e as = mkIfaceApps (toIfaceExpr e) as
mkIfaceApps :: IfaceExpr -> [CoreExpr] -> IfaceExpr
mkIfaceApps f as = foldl' (\f a -> IfaceApp f (toIfaceExpr a)) f as
toIfaceVar :: Id -> IfaceExpr
toIfaceVar v
| isBootUnfolding (idUnfolding v)
=
IfaceApp (IfaceApp (IfaceExt noinlineIdName)
(IfaceType (toIfaceType (idType v))))
(IfaceExt name)
| Just fcall <- isFCallId_maybe v = IfaceFCall fcall (toIfaceType (idType v))
| isExternalName name = IfaceExt name
| otherwise = IfaceLcl (getOccFS name)
where name = idName v
toIfaceLFInfo :: Name -> LambdaFormInfo -> IfaceLFInfo
toIfaceLFInfo nm lfi = case lfi of
LFReEntrant top_lvl arity no_fvs _arg_descr ->
ASSERT2(isTopLevel top_lvl, ppr nm)
ASSERT2(no_fvs, ppr nm)
IfLFReEntrant arity
LFThunk top_lvl no_fvs updatable sfi mb_fun ->
ASSERT2(isTopLevel top_lvl, ppr nm)
ASSERT2(no_fvs, ppr nm)
ASSERT2(sfi == NonStandardThunk, ppr nm)
IfLFThunk updatable mb_fun
LFCon dc ->
IfLFCon (dataConName dc)
LFUnknown mb_fun ->
IfLFUnknown mb_fun
LFUnlifted ->
IfLFUnlifted
LFLetNoEscape ->
panic "toIfaceLFInfo: LFLetNoEscape"