\section[CoreUtils]{Utility functions on @Core@ syntax}
\begin{code}
-#include "HsVersions.h"
-
module CoreUtils (
coreExprType, coreAltsType, coreExprCc,
- substCoreExpr, substCoreBindings
-
- , mkCoreIfThenElse
- , argToExpr
- , unTagBinders, unTagBindersAlts
-
- , maybeErrorApp
- , nonErrorRHSs
- , squashableDictishCcExpr
+ mkCoreIfThenElse,
+ argToExpr,
+ unTagBinders, unTagBindersAlts,
+
+ maybeErrorApp,
+ nonErrorRHSs,
+ squashableDictishCcExpr,
+ idSpecVars
) where
-IMP_Ubiq()
-IMPORT_DELOOPER(IdLoop) -- for pananoia-checking purposes
+#include "HsVersions.h"
import CoreSyn
import CostCentre ( isDictCC, CostCentre, noCostCentre )
-import Id ( idType, mkSysLocal, isBottomingId,
- toplevelishId, mkIdWithNewUniq, applyTypeEnvToId,
+import MkId ( mkSysLocal )
+import Id ( idType, isBottomingId, getIdSpecialisation,
+ mkIdWithNewUniq,
dataConRepType,
addOneToIdEnv, growIdEnvList, lookupIdEnv,
- isNullIdEnv, SYN_IE(IdEnv),
- GenId{-instances-}
+ isNullIdEnv, IdEnv, Id
)
-import Literal ( literalType, isNoRepLit, Literal(..) )
+import Literal ( literalType, Literal(..) )
import Maybes ( catMaybes, maybeToBool )
import PprCore
-import PprStyle ( PprStyle(..) )
-import PprType ( GenType{-instances-} )
-import Pretty ( ppAboves, ppStr )
-import PrelVals ( augmentId, buildId )
import PrimOp ( primOpType, PrimOp(..) )
+import SpecEnv ( specEnvValues )
import SrcLoc ( noSrcLoc )
import TyVar ( cloneTyVar,
- isNullTyVarEnv, addOneToTyVarEnv, SYN_IE(TyVarEnv)
+ isEmptyTyVarEnv, addToTyVarEnv, TyVarEnv,
+ TyVar, GenTyVar
)
-import Type ( mkFunTy, mkForAllTy, mkForAllUsageTy, mkTyVarTy,
- getFunTyExpandingDicts_maybe, applyTy, isPrimType,
- splitSigmaTy, splitFunTy, eqTy, applyTypeEnvToTy
+import Type ( mkFunTy, mkForAllTy, mkTyVarTy,
+ splitFunTy_maybe, applyTys, isUnpointedType,
+ splitSigmaTy, splitFunTys, instantiateTy,
+ Type
)
import TysWiredIn ( trueDataCon, falseDataCon )
-import UniqSupply ( initUs, returnUs, thenUs,
+import Unique ( Unique )
+import BasicTypes ( Unused )
+import UniqSupply ( returnUs, thenUs,
mapUs, mapAndUnzipUs, getUnique,
- SYN_IE(UniqSM), UniqSupply
+ UniqSM, UniqSupply
)
-import Usage ( SYN_IE(UVar) )
-import Util ( zipEqual, panic, pprTrace, pprPanic, assertPanic )
-import Pretty
-import Outputable ( Outputable(..) )
+import Util ( zipEqual )
+import Outputable
type TypeEnv = TyVarEnv Type
-applyUsage = panic "CoreUtils.applyUsage:ToDo"
\end{code}
%************************************************************************
coreExprType (Lit lit) = literalType lit
coreExprType (Let _ body) = coreExprType body
-coreExprType (SCC _ expr) = coreExprType expr
coreExprType (Case _ alts) = coreAltsType alts
-coreExprType (Coerce _ ty _) = ty -- that's the whole point!
+coreExprType (Note (Coerce ty _) e) = ty
+coreExprType (Note other_note e) = coreExprType e
-- a Con is a fully-saturated application of a data constructor
-- a Prim is <ditto> of a PrimOp
coreExprType (Con con args) =
--- pprTrace "appTyArgs" (ppCat [ppr PprDebug con, ppSemi,
--- ppr PprDebug con_ty, ppSemi,
--- ppr PprDebug args]) $
+-- pprTrace "appTyArgs" (hsep [ppr con, semi,
+-- ppr con_ty, semi,
+-- ppr args]) $
applyTypeToArgs con_ty args
where
con_ty = dataConRepType con
coreExprType (Lam (TyBinder tyvar) expr)
= mkForAllTy tyvar (coreExprType expr)
-coreExprType (Lam (UsageBinder uvar) expr)
- = mkForAllUsageTy uvar (panic "coreExprType:Lam UsageBinder") (coreExprType expr)
-
coreExprType (App expr (TyArg ty))
- =
--- pprTrace "appTy1" (ppCat [ppr PprDebug fun_ty, ppSP, ppr PprDebug ty]) $
- applyTy fun_ty ty
+ = -- Gather type args; more efficient to instantiate the type all at once
+ go expr [ty]
where
- fun_ty = coreExprType expr
-
-coreExprType (App expr (UsageArg use))
- = applyUsage (coreExprType expr) use
+ go (App expr (TyArg ty)) tys = go expr (ty:tys)
+ go expr tys = applyTys (coreExprType expr) tys
coreExprType (App expr val_arg)
= ASSERT(isValArg val_arg)
let
fun_ty = coreExprType expr
in
- case (getFunTyExpandingDicts_maybe False{-no peeking-} fun_ty) of
+ case (splitFunTy_maybe fun_ty) of
Just (_, result_ty) -> result_ty
#ifdef DEBUG
Nothing -> pprPanic "coreExprType:\n"
- (ppAboves [ppr PprDebug fun_ty,
- ppr PprShowAll (App expr val_arg)])
+ (vcat [ppr fun_ty, ppr (App expr val_arg)])
#endif
\end{code}
\end{code}
\begin{code}
-applyTypeToArgs op_ty args = foldl applyTypeToArg op_ty args
+applyTypeToArgs op_ty (TyArg ty : args)
+ = -- Accumulate type arguments so we can instantiate all at once
+ applyTypeToArgs (applyTys op_ty tys) rest_args
+ where
+ (tys, rest_args) = go [ty] args
+ go tys (TyArg ty : args) = go (ty:tys) args
+ go tys rest_args = (reverse tys, rest_args)
+
+applyTypeToArgs op_ty (val_or_lit_arg:args)
+ = case (splitFunTy_maybe op_ty) of
+ Just (_, res_ty) -> applyTypeToArgs res_ty args
-applyTypeToArg op_ty (TyArg ty) = applyTy op_ty ty
-applyTypeToArg op_ty (UsageArg _) = panic "applyTypeToArg: UsageArg"
-applyTypeToArg op_ty val_or_lit_arg = case (getFunTyExpandingDicts_maybe False{-no peeking-} op_ty) of
- Just (_, res_ty) -> res_ty
+applyTypeToArgs op_ty [] = op_ty
\end{code}
coreExprCc gets the cost centre enclosing an expression, if any.
It looks inside lambdas because (scc "foo" \x.e) = \x.scc "foo" e
\begin{code}
-coreExprCc :: GenCoreExpr val_bdr val_occ tyvar uvar -> CostCentre
-coreExprCc (SCC cc e) = cc
-coreExprCc (Lam _ e) = coreExprCc e
-coreExprCc other = noCostCentre
+coreExprCc :: GenCoreExpr val_bdr val_occ flexi -> CostCentre
+coreExprCc (Note (SCC cc) e) = cc
+coreExprCc (Note other_note e) = coreExprCc e
+coreExprCc (Lam _ e) = coreExprCc e
+coreExprCc other = noCostCentre
\end{code}
%************************************************************************
\begin{code}
argToExpr ::
- GenCoreArg val_occ tyvar uvar -> GenCoreExpr val_bdr val_occ tyvar uvar
+ GenCoreArg val_occ flexi -> GenCoreExpr val_bdr val_occ flexi
argToExpr (VarArg v) = Var v
argToExpr (LitArg lit) = Lit lit
annotates all binders with False.
\begin{code}
-unTagBinders :: GenCoreExpr (Id,tag) bdee tv uv -> GenCoreExpr Id bdee tv uv
+unTagBinders :: GenCoreExpr (Id,tag) bdee flexi -> GenCoreExpr Id bdee flexi
unTagBinders expr = bop_expr fst expr
-unTagBindersAlts :: GenCoreCaseAlts (Id,tag) bdee tv uv -> GenCoreCaseAlts Id bdee tv uv
+unTagBindersAlts :: GenCoreCaseAlts (Id,tag) bdee flexi -> GenCoreCaseAlts Id bdee flexi
unTagBindersAlts alts = bop_alts fst alts
\end{code}
\begin{code}
-bop_expr :: (a -> b) -> GenCoreExpr a bdee tv uv -> GenCoreExpr b bdee tv uv
+bop_expr :: (a -> b) -> GenCoreExpr a bdee flexi -> GenCoreExpr b bdee flexi
bop_expr f (Var b) = Var b
bop_expr f (Lit lit) = Lit lit
bop_expr f (Prim op args) = Prim op args
bop_expr f (Lam binder expr) = Lam (bop_binder f binder) (bop_expr f expr)
bop_expr f (App expr arg) = App (bop_expr f expr) arg
-bop_expr f (SCC label expr) = SCC label (bop_expr f expr)
-bop_expr f (Coerce c ty e) = Coerce c ty (bop_expr f e)
+bop_expr f (Note note expr) = Note note (bop_expr f expr)
bop_expr f (Let bind expr) = Let (bop_bind f bind) (bop_expr f expr)
bop_expr f (Case expr alts) = Case (bop_expr f expr) (bop_alts f alts)
bop_binder f (ValBinder v) = ValBinder (f v)
bop_binder f (TyBinder t) = TyBinder t
-bop_binder f (UsageBinder u) = UsageBinder u
bop_bind f (NonRec b e) = NonRec (f b) (bop_expr f e)
bop_bind f (Rec pairs) = Rec [(f b, bop_expr f e) | (b, e) <- pairs]
Notice that the \tr{<alts>} don't get duplicated.
\begin{code}
-nonErrorRHSs :: GenCoreCaseAlts a Id TyVar UVar -> [GenCoreExpr a Id TyVar UVar]
+nonErrorRHSs :: GenCoreCaseAlts a Id Unused -> [GenCoreExpr a Id Unused]
nonErrorRHSs alts
= filter not_error_app (find_rhss alts)
\begin{code}
maybeErrorApp
- :: GenCoreExpr a Id TyVar UVar -- Expr to look at
+ :: GenCoreExpr a Id Unused -- Expr to look at
-> Maybe Type -- Just ty => a result type *already cloned*;
-- Nothing => don't know result ty; we
-- *pretend* that the result ty won't be
-- primitive -- somebody later must
-- ensure this.
- -> Maybe (GenCoreExpr a Id TyVar UVar)
+ -> Maybe (GenCoreExpr b Id Unused)
maybeErrorApp expr result_ty_maybe
= case (collectArgs expr) of
- (Var fun, [{-no usage???-}], [ty], other_args)
+ (Var fun, [ty], other_args)
| isBottomingId fun
&& maybeToBool result_ty_maybe -- we *know* the result type
-- (otherwise: live a fairy-tale existence...)
- && not (isPrimType result_ty) ->
+ && not (isUnpointedType result_ty) ->
case (splitSigmaTy (idType fun)) of
([tyvar], [], tau_ty) ->
- case (splitFunTy tau_ty) of { (arg_tys, res_ty) ->
+ case (splitFunTys tau_ty) of { (arg_tys, res_ty) ->
let
n_args_to_keep = length arg_tys
args_to_keep = take n_args_to_keep other_args
in
- if (res_ty `eqTy` mkTyVarTy tyvar)
+ if (res_ty == mkTyVarTy tyvar)
&& n_args_to_keep <= length other_args
then
-- Phew! We're in business
\end{code}
\begin{code}
-squashableDictishCcExpr :: CostCentre -> GenCoreExpr a b c d -> Bool
+squashableDictishCcExpr :: CostCentre -> GenCoreExpr a b c -> Bool
squashableDictishCcExpr cc expr
= if not (isDictCC cc) then
squashable other = False
\end{code}
-%************************************************************************
-%* *
-\subsection{Core-renaming utils}
-%* *
-%************************************************************************
-
-\begin{code}
-substCoreBindings :: ValEnv
- -> TypeEnv -- TyVar=>Type
- -> [CoreBinding]
- -> UniqSM [CoreBinding]
-
-substCoreExpr :: ValEnv
- -> TypeEnv -- TyVar=>Type
- -> CoreExpr
- -> UniqSM CoreExpr
-
-substCoreBindings venv tenv binds
- -- if the envs are empty, then avoid doing anything
- = if (isNullIdEnv venv && isNullTyVarEnv tenv) then
- returnUs binds
- else
- do_CoreBindings venv tenv binds
-
-substCoreExpr venv tenv expr
- = if (isNullIdEnv venv && isNullTyVarEnv tenv) then
- returnUs expr
- else
- do_CoreExpr venv tenv expr
-\end{code}
-
-The equiv code for @Types@ is in @TyUtils@.
-
-Because binders aren't necessarily unique: we don't do @plusEnvs@
-(which check for duplicates); rather, we use the shadowing version,
-@growIdEnv@ (and shorthand @addOneToIdEnv@).
-
-@do_CoreBindings@ takes into account the semantics of a list of
-@CoreBindings@---things defined early in the list are visible later in
-the list, but not vice versa.
-
-\begin{code}
-type ValEnv = IdEnv CoreExpr
-
-do_CoreBindings :: ValEnv
- -> TypeEnv
- -> [CoreBinding]
- -> UniqSM [CoreBinding]
-
-do_CoreBinding :: ValEnv
- -> TypeEnv
- -> CoreBinding
- -> UniqSM (CoreBinding, ValEnv)
-do_CoreBindings venv tenv [] = returnUs []
-do_CoreBindings venv tenv (b:bs)
- = do_CoreBinding venv tenv b `thenUs` \ (new_b, new_venv) ->
- do_CoreBindings new_venv tenv bs `thenUs` \ new_bs ->
- returnUs (new_b : new_bs)
-
-do_CoreBinding venv tenv (NonRec binder rhs)
- = do_CoreExpr venv tenv rhs `thenUs` \ new_rhs ->
-
- dup_binder tenv binder `thenUs` \ (new_binder, (old, new)) ->
- -- now plug new bindings into envs
- let new_venv = addOneToIdEnv venv old new in
-
- returnUs (NonRec new_binder new_rhs, new_venv)
-
-do_CoreBinding venv tenv (Rec binds)
- = -- for letrec, we plug in new bindings BEFORE cloning rhss
- mapAndUnzipUs (dup_binder tenv) binders `thenUs` \ (new_binders, new_maps) ->
- let new_venv = growIdEnvList venv new_maps in
-
- mapUs (do_CoreExpr new_venv tenv) rhss `thenUs` \ new_rhss ->
- returnUs (Rec (zipEqual "do_CoreBinding" new_binders new_rhss), new_venv)
- where
- (binders, rhss) = unzip binds
-\end{code}
+Given an Id, idSpecVars returns all its specialisations.
+We extract these from its SpecEnv.
+This is used by the occurrence analyser and free-var finder;
+we regard an Id's specialisations as free in the Id's definition.
\begin{code}
-do_CoreArg :: ValEnv
- -> TypeEnv
- -> CoreArg
- -> UniqSM CoreArgOrExpr
-
-do_CoreArg venv tenv a@(VarArg v)
- = returnUs (
- case (lookupIdEnv venv v) of
- Nothing -> AnArg a
- Just expr -> AnExpr expr
- )
-
-do_CoreArg venv tenv (TyArg ty)
- = returnUs (AnArg (TyArg (applyTypeEnvToTy tenv ty)))
-
-do_CoreArg venv tenv other_arg = returnUs (AnArg other_arg)
-\end{code}
-
-\begin{code}
-do_CoreExpr :: ValEnv
- -> TypeEnv
- -> CoreExpr
- -> UniqSM CoreExpr
-
-do_CoreExpr venv tenv orig_expr@(Var var)
- = returnUs (
- case (lookupIdEnv venv var) of
- Nothing -> --false:ASSERT(toplevelishId var) (SIGH)
- orig_expr
- Just expr -> expr
- )
-
-do_CoreExpr venv tenv e@(Lit _) = returnUs e
-
-do_CoreExpr venv tenv (Con con as)
- = mapUs (do_CoreArg venv tenv) as `thenUs` \ new_as ->
- mkCoCon con new_as
-
-do_CoreExpr venv tenv (Prim op as)
- = mapUs (do_CoreArg venv tenv) as `thenUs` \ new_as ->
- do_PrimOp op `thenUs` \ new_op ->
- mkCoPrim new_op new_as
- where
- do_PrimOp (CCallOp label is_asm may_gc arg_tys result_ty)
- = let
- new_arg_tys = map (applyTypeEnvToTy tenv) arg_tys
- new_result_ty = applyTypeEnvToTy tenv result_ty
- in
- returnUs (CCallOp label is_asm may_gc new_arg_tys new_result_ty)
-
- do_PrimOp other_op = returnUs other_op
-
-do_CoreExpr venv tenv (Lam (ValBinder binder) expr)
- = dup_binder tenv binder `thenUs` \(new_binder, (old,new)) ->
- let new_venv = addOneToIdEnv venv old new in
- do_CoreExpr new_venv tenv expr `thenUs` \ new_expr ->
- returnUs (Lam (ValBinder new_binder) new_expr)
-
-do_CoreExpr venv tenv (Lam (TyBinder tyvar) expr)
- = dup_tyvar tyvar `thenUs` \ (new_tyvar, (old, new)) ->
- let
- new_tenv = addOneToTyVarEnv tenv old new
- in
- do_CoreExpr venv new_tenv expr `thenUs` \ new_expr ->
- returnUs (Lam (TyBinder new_tyvar) new_expr)
-
-do_CoreExpr venv tenv (Lam _ expr) = panic "CoreUtils.do_CoreExpr:Lam UsageBinder"
-
-do_CoreExpr venv tenv (App expr arg)
- = do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
- do_CoreArg venv tenv arg `thenUs` \ new_arg ->
- mkCoApps new_expr [new_arg] -- ToDo: more efficiently?
-
-do_CoreExpr venv tenv (Case expr alts)
- = do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
- do_alts venv tenv alts `thenUs` \ new_alts ->
- returnUs (Case new_expr new_alts)
+idSpecVars :: Id -> [Id]
+idSpecVars id
+ = map get_spec (specEnvValues (getIdSpecialisation id))
where
- do_alts venv tenv (AlgAlts alts deflt)
- = mapUs (do_boxed_alt venv tenv) alts `thenUs` \ new_alts ->
- do_default venv tenv deflt `thenUs` \ new_deflt ->
- returnUs (AlgAlts new_alts new_deflt)
- where
- do_boxed_alt venv tenv (con, binders, expr)
- = mapAndUnzipUs (dup_binder tenv) binders `thenUs` \ (new_binders, new_vmaps) ->
- let new_venv = growIdEnvList venv new_vmaps in
- do_CoreExpr new_venv tenv expr `thenUs` \ new_expr ->
- returnUs (con, new_binders, new_expr)
-
-
- do_alts venv tenv (PrimAlts alts deflt)
- = mapUs (do_unboxed_alt venv tenv) alts `thenUs` \ new_alts ->
- do_default venv tenv deflt `thenUs` \ new_deflt ->
- returnUs (PrimAlts new_alts new_deflt)
- where
- do_unboxed_alt venv tenv (lit, expr)
- = do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
- returnUs (lit, new_expr)
-
- do_default venv tenv NoDefault = returnUs NoDefault
-
- do_default venv tenv (BindDefault binder expr)
- = dup_binder tenv binder `thenUs` \ (new_binder, (old, new)) ->
- let new_venv = addOneToIdEnv venv old new in
- do_CoreExpr new_venv tenv expr `thenUs` \ new_expr ->
- returnUs (BindDefault new_binder new_expr)
-
-do_CoreExpr venv tenv (Let core_bind expr)
- = do_CoreBinding venv tenv core_bind `thenUs` \ (new_bind, new_venv) ->
- -- and do the body of the let
- do_CoreExpr new_venv tenv expr `thenUs` \ new_expr ->
- returnUs (Let new_bind new_expr)
-
-do_CoreExpr venv tenv (SCC label expr)
- = do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
- returnUs (SCC label new_expr)
-
-do_CoreExpr venv tenv (Coerce c ty expr)
- = do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
- returnUs (Coerce c (applyTypeEnvToTy tenv ty) new_expr)
-\end{code}
-
-\begin{code}
-dup_tyvar :: TyVar -> UniqSM (TyVar, (TyVar, Type))
-dup_tyvar tyvar
- = getUnique `thenUs` \ uniq ->
- let new_tyvar = cloneTyVar tyvar uniq in
- returnUs (new_tyvar, (tyvar, mkTyVarTy new_tyvar))
-
--- same thing all over again --------------------
-
-dup_binder :: TypeEnv -> Id -> UniqSM (Id, (Id, CoreExpr))
-dup_binder tenv b
- = if (toplevelishId b) then
- -- binder is "top-level-ish"; -- it should *NOT* be renamed
- -- ToDo: it's unsavoury that we return something to heave in env
- returnUs (b, (b, Var b))
-
- else -- otherwise, the full business
- getUnique `thenUs` \ uniq ->
- let
- new_b1 = mkIdWithNewUniq b uniq
- new_b2 = applyTypeEnvToId tenv new_b1
- in
- returnUs (new_b2, (b, Var new_b2))
+ -- get_spec is another cheapo function like dictRhsFVs
+ -- It knows what these specialisation temlates look like,
+ -- and just goes for the jugular
+ get_spec (App f _) = get_spec f
+ get_spec (Lam _ b) = get_spec b
+ get_spec (Var v) = v
\end{code}