#include "HsVersions.h"
module CoreUtils (
- coreExprType, coreAltsType,
+ coreExprType, coreAltsType, coreExprCc,
substCoreExpr, substCoreBindings
, mkCoreIfThenElse
, argToExpr
, unTagBinders, unTagBindersAlts
- , manifestlyWHNF, manifestlyBottom
+
, maybeErrorApp
, nonErrorRHSs
, squashableDictishCcExpr
-{- exprSmallEnoughToDup,
+{-
coreExprArity,
isWrapperFor,
-} ) where
-import Ubiq
-import IdLoop -- for pananoia-checking purposes
+IMP_Ubiq()
+IMPORT_DELOOPER(IdLoop) -- for pananoia-checking purposes
import CoreSyn
-import CostCentre ( isDictCC )
+import CostCentre ( isDictCC, CostCentre, noCostCentre )
import Id ( idType, mkSysLocal, getIdArity, isBottomingId,
+ toplevelishId, mkIdWithNewUniq, applyTypeEnvToId,
+ dataConRepType,
addOneToIdEnv, growIdEnvList, lookupIdEnv,
- isNullIdEnv, IdEnv(..),
+ isNullIdEnv, SYN_IE(IdEnv),
GenId{-instances-}
)
import IdInfo ( arityMaybe )
import Literal ( literalType, isNoRepLit, Literal(..) )
import Maybes ( catMaybes, maybeToBool )
-import PprCore ( GenCoreExpr{-instances-}, GenCoreArg{-instances-} )
+import PprCore
import PprStyle ( PprStyle(..) )
import PprType ( GenType{-instances-} )
-import Pretty ( ppAboves )
-import PrelInfo ( trueDataCon, falseDataCon,
- augmentId, buildId
- )
+import Pretty ( ppAboves, ppStr )
+import PrelVals ( augmentId, buildId )
import PrimOp ( primOpType, PrimOp(..) )
import SrcLoc ( mkUnknownSrcLoc )
-import TyVar ( isNullTyVarEnv, TyVarEnv(..) )
-import Type ( mkFunTys, mkForAllTy, mkForAllUsageTy, mkTyVarTy,
- getFunTy_maybe, applyTy, isPrimType,
+import TyVar ( cloneTyVar,
+ isNullTyVarEnv, addOneToTyVarEnv, SYN_IE(TyVarEnv)
+ )
+import Type ( mkFunTy, mkForAllTy, mkForAllUsageTy, mkTyVarTy,
+ getFunTyExpandingDicts_maybe, applyTy, isPrimType,
splitSigmaTy, splitFunTy, eqTy, applyTypeEnvToTy
)
+import TysWiredIn ( trueDataCon, falseDataCon )
import UniqSupply ( initUs, returnUs, thenUs,
mapUs, mapAndUnzipUs, getUnique,
- UniqSM(..), UniqSupply
+ SYN_IE(UniqSM), UniqSupply
)
-import Usage ( UVar(..) )
+import Usage ( SYN_IE(UVar) )
import Util ( zipEqual, panic, pprPanic, assertPanic )
type TypeEnv = TyVarEnv Type
applyUsage = panic "CoreUtils.applyUsage:ToDo"
-dup_binder = panic "CoreUtils.dup_binder"
\end{code}
%************************************************************************
coreExprType (SCC _ expr) = coreExprType expr
coreExprType (Case _ alts) = coreAltsType alts
+coreExprType (Coerce _ ty _) = ty -- that's the whole point!
+
-- a Con is a fully-saturated application of a data constructor
-- a Prim is <ditto> of a PrimOp
-coreExprType (Con con args) = applyTypeToArgs (idType con) args
+coreExprType (Con con args) = applyTypeToArgs (dataConRepType con) args
coreExprType (Prim op args) = applyTypeToArgs (primOpType op) args
coreExprType (Lam (ValBinder binder) expr)
- = mkFunTys [idType binder] (coreExprType expr)
+ = idType binder `mkFunTy` coreExprType expr
coreExprType (Lam (TyBinder tyvar) expr)
= mkForAllTy tyvar (coreExprType expr)
let
fun_ty = coreExprType expr
in
- case (getFunTy_maybe fun_ty) of
+ case (getFunTyExpandingDicts_maybe False{-no peeking-} fun_ty) of
Just (_, result_ty) -> result_ty
#ifdef DEBUG
Nothing -> pprPanic "coreExprType:\n"
\end{code}
\begin{code}
-applyTypeToArgs op_ty args
- = foldl applyTy op_ty [ ty | TyArg ty <- args ]
+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
+ Just (_, res_ty) -> res_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
\end{code}
%************************************************************************
\end{code}
\begin{code}
-{- LATER:
-exprSmallEnoughToDup :: GenCoreExpr binder Id -> Bool
-
-exprSmallEnoughToDup (Con _ _ _) = True -- Could check # of args
-exprSmallEnoughToDup (Prim op _ _) = not (fragilePrimOp op) -- Could check # of args
-exprSmallEnoughToDup (Lit lit) = not (isNoRepLit lit)
-
-exprSmallEnoughToDup expr -- for now, just: <var> applied to <args>
- = case (collectArgs expr) of { (fun, _, _, vargs) ->
- case fun of
- Var v -> v /= buildId
- && v /= augmentId
- && length vargs <= 6 -- or 10 or 1 or 4 or anything smallish.
- _ -> False
- }
--}
-\end{code}
-Question (ADR): What is the above used for? Is a _ccall_ really small
-enough?
-
-@manifestlyWHNF@ looks at a Core expression and returns \tr{True} if
-it is obviously in weak head normal form. It isn't a disaster if it
-errs on the conservative side (returning \tr{False})---I've probably
-left something out... [WDP]
-
-\begin{code}
-manifestlyWHNF :: GenCoreExpr bndr Id tyvar uvar -> Bool
-
-manifestlyWHNF (Var _) = True
-manifestlyWHNF (Lit _) = True
-manifestlyWHNF (Con _ _) = True
-manifestlyWHNF (SCC _ e) = manifestlyWHNF e
-manifestlyWHNF (Let _ e) = False
-manifestlyWHNF (Case _ _) = False
-
-manifestlyWHNF (Lam x e) = if isValBinder x then True else manifestlyWHNF e
-
-manifestlyWHNF other_expr -- look for manifest partial application
- = case (collectArgs other_expr) of { (fun, _, _, vargs) ->
- case fun of
- Var f -> let
- num_val_args = length vargs
- in
- num_val_args == 0 -- Just a type application of
- -- a variable (f t1 t2 t3);
- -- counts as WHNF.
- ||
- case (arityMaybe (getIdArity f)) of
- Nothing -> False
- Just arity -> num_val_args < arity
-
- _ -> False
- }
-\end{code}
-
-@manifestlyBottom@ looks at a Core expression and returns \tr{True} if
-it is obviously bottom, that is, it will certainly return bottom at
-some point. It isn't a disaster if it errs on the conservative side
-(returning \tr{False}).
-
-\begin{code}
-manifestlyBottom :: GenCoreExpr bndr Id tyvar uvar -> Bool
-
-manifestlyBottom (Var v) = isBottomingId v
-manifestlyBottom (Lit _) = False
-manifestlyBottom (Con _ _) = False
-manifestlyBottom (Prim _ _) = False
-manifestlyBottom (SCC _ e) = manifestlyBottom e
-manifestlyBottom (Let _ e) = manifestlyBottom e
-
- -- We do not assume \x.bottom == bottom:
-manifestlyBottom (Lam x e) = if isValBinder x then False else manifestlyBottom e
-
-manifestlyBottom (Case e a)
- = manifestlyBottom e
- || (case a of
- AlgAlts alts def -> all mbalg alts && mbdef def
- PrimAlts alts def -> all mbprim alts && mbdef def
- )
- where
- mbalg (_,_,e') = manifestlyBottom e'
-
- mbprim (_,e') = manifestlyBottom e'
-
- mbdef NoDefault = True
- mbdef (BindDefault _ e') = manifestlyBottom e'
-
-manifestlyBottom other_expr -- look for manifest partial application
- = case (collectArgs other_expr) of { (fun, _, _, _) ->
- case fun of
- Var f | isBottomingId f -> True
- -- Application of a function which always gives
- -- bottom; we treat this as a WHNF, because it
- -- certainly doesn't need to be shared!
- _ -> False
- }
-\end{code}
-
-\begin{code}
{-LATER:
coreExprArity
:: (Id -> Maybe (GenCoreExpr bndr Id))
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 (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)
let new_venv = growIdEnvList venv new_maps in
mapUs (do_CoreExpr new_venv tenv) rhss `thenUs` \ new_rhss ->
- returnUs (Rec (new_binders `zipEqual` new_rhss), new_venv)
+ returnUs (Rec (zipEqual "do_CoreBinding" new_binders new_rhss), new_venv)
where
(binders, rhss) = unzip binds
\end{code}
do_PrimOp other_op = returnUs other_op
-do_CoreExpr venv tenv (Lam binder expr)
+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 new_binder 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_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))
\end{code}
projects / ghc-hetmet.git / blobdiff