\section[CoreUtils]{Utility functions on @Core@ syntax}
\begin{code}
-#include "HsVersions.h"
-
module CoreUtils (
coreExprType, coreAltsType, coreExprCc,
, squashableDictishCcExpr
) where
-IMP_Ubiq()
+#include "HsVersions.h"
import CoreSyn
toplevelishId, mkIdWithNewUniq, applyTypeEnvToId,
dataConRepType,
addOneToIdEnv, growIdEnvList, lookupIdEnv,
- isNullIdEnv, SYN_IE(IdEnv),
- GenId{-instances-}, SYN_IE(Id)
+ isNullIdEnv, IdEnv, Id
)
import Literal ( literalType, isNoRepLit, Literal(..) )
import Maybes ( catMaybes, maybeToBool )
import PprCore
-import Outputable ( PprStyle(..), Outputable(..) )
-import PprType ( GenType{-instances-}, GenTyVar )
-import Pretty ( Doc, vcat )
import PrimOp ( primOpType, PrimOp(..) )
import SrcLoc ( noSrcLoc )
import TyVar ( cloneTyVar,
- isNullTyVarEnv, addOneToTyVarEnv, SYN_IE(TyVarEnv),
- SYN_IE(TyVar), GenTyVar
+ isEmptyTyVarEnv, addToTyVarEnv, TyVarEnv,
+ TyVar, GenTyVar
)
-import Type ( mkFunTy, mkForAllTy, mkForAllUsageTy, mkTyVarTy,
- getFunTyExpandingDicts_maybe, applyTy, isPrimType,
- splitSigmaTy, splitFunTy, eqTy, applyTypeEnvToTy,
- SYN_IE(Type)
+import Type ( mkFunTy, mkForAllTy, mkTyVarTy,
+ splitFunTy_maybe, applyTy, isUnpointedType,
+ splitSigmaTy, splitFunTys, instantiateTy,
+ Type
)
import TysWiredIn ( trueDataCon, falseDataCon )
import Unique ( Unique )
+import BasicTypes ( Unused )
import UniqSupply ( initUs, returnUs, thenUs,
mapUs, mapAndUnzipUs, getUnique,
- SYN_IE(UniqSM), UniqSupply
+ UniqSM, UniqSupply
)
-import Usage ( SYN_IE(UVar) )
-import Util ( zipEqual, panic, pprTrace, pprPanic, assertPanic )
+import Util ( zipEqual )
+import Outputable
type TypeEnv = TyVarEnv Type
-applyUsage = panic "CoreUtils.applyUsage:ToDo"
\end{code}
%************************************************************************
-- a Prim is <ditto> of a PrimOp
coreExprType (Con con args) =
--- pprTrace "appTyArgs" (hsep [ppr PprDebug con, semi,
--- ppr PprDebug con_ty, semi,
--- 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" (hsep [ppr PprDebug fun_ty, space, ppr PprDebug ty]) $
+-- pprTrace "appTy1" (hsep [ppr fun_ty, space, ppr ty]) $
applyTy fun_ty ty
where
fun_ty = coreExprType expr
-coreExprType (App expr (UsageArg use))
- = applyUsage (coreExprType expr) use
-
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"
- (vcat [ppr PprDebug fun_ty,
- ppr PprShowAll (App expr val_arg)])
+ (vcat [ppr fun_ty, ppr (App expr val_arg)])
#endif
\end{code}
applyTypeToArgs op_ty args = foldl applyTypeToArg op_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
+applyTypeToArg op_ty val_or_lit_arg = case (splitFunTy_maybe op_ty) of
Just (_, res_ty) -> res_ty
\end{code}
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 :: GenCoreExpr val_bdr val_occ flexi -> CostCentre
coreExprCc (SCC cc e) = cc
coreExprCc (Lam _ e) = coreExprCc e
coreExprCc other = noCostCentre
\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_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 b 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
substCoreBindings venv tenv binds
-- if the envs are empty, then avoid doing anything
- = if (isNullIdEnv venv && isNullTyVarEnv tenv) then
+ = if (isNullIdEnv venv && isEmptyTyVarEnv tenv) then
returnUs binds
else
do_CoreBindings venv tenv binds
substCoreExpr venv tenv expr
- = if (isNullIdEnv venv && isNullTyVarEnv tenv) then
+ = if (isNullIdEnv venv && isEmptyTyVarEnv tenv) then
returnUs expr
else
do_CoreExpr venv tenv expr
)
do_CoreArg venv tenv (TyArg ty)
- = returnUs (AnArg (TyArg (applyTypeEnvToTy tenv ty)))
+ = returnUs (AnArg (TyArg (instantiateTy tenv ty)))
do_CoreArg venv tenv other_arg = returnUs (AnArg other_arg)
\end{code}
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
+ new_arg_tys = map (instantiateTy tenv) arg_tys
+ new_result_ty = instantiateTy tenv result_ty
in
returnUs (CCallOp label is_asm may_gc new_arg_tys new_result_ty)
do_CoreExpr venv tenv (Lam (TyBinder tyvar) expr)
= dup_tyvar tyvar `thenUs` \ (new_tyvar, (old, new)) ->
let
- new_tenv = addOneToTyVarEnv tenv old new
+ new_tenv = addToTyVarEnv 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 ->
do_CoreExpr venv tenv (Coerce c ty expr)
= do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
- returnUs (Coerce c (applyTypeEnvToTy tenv ty) new_expr)
+ returnUs (Coerce c (instantiateTy tenv ty) new_expr)
\end{code}
\begin{code}
projects / ghc-hetmet.git / blobdiff