#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
+ ) where
IMP_Ubiq()
-IMPORT_DELOOPER(IdLoop) -- for pananoia-checking purposes
import CoreSyn
-import CostCentre ( isDictCC )
-import Id ( idType, mkSysLocal, getIdArity, isBottomingId,
+import CostCentre ( isDictCC, CostCentre, noCostCentre )
+import Id ( idType, mkSysLocal, isBottomingId,
toplevelishId, mkIdWithNewUniq, applyTypeEnvToId,
+ dataConRepType,
addOneToIdEnv, growIdEnvList, lookupIdEnv,
isNullIdEnv, SYN_IE(IdEnv),
- GenId{-instances-}
+ GenId{-instances-}, SYN_IE(Id)
)
-import IdInfo ( arityMaybe )
import Literal ( literalType, isNoRepLit, Literal(..) )
import Maybes ( catMaybes, maybeToBool )
import PprCore
-import PprStyle ( PprStyle(..) )
-import PprType ( GenType{-instances-} )
-import Pretty ( ppAboves )
-import PrelVals ( augmentId, buildId )
-import PrimOp ( primOpType, fragilePrimOp, PrimOp(..) )
-import SrcLoc ( mkUnknownSrcLoc )
+import Outputable ( PprStyle(..), Outputable(..) )
+import PprType ( GenType{-instances-}, GenTyVar )
+import Pretty ( vcat, text )
+import PrimOp ( primOpType, PrimOp(..) )
+import SrcLoc ( noSrcLoc )
import TyVar ( cloneTyVar,
- isNullTyVarEnv, addOneToTyVarEnv, SYN_IE(TyVarEnv)
+ isNullTyVarEnv, addOneToTyVarEnv, SYN_IE(TyVarEnv),
+ SYN_IE(TyVar), GenTyVar
)
import Type ( mkFunTy, mkForAllTy, mkForAllUsageTy, mkTyVarTy,
- getFunTy_maybe, applyTy, isPrimType,
- splitSigmaTy, splitFunTy, eqTy, applyTypeEnvToTy
+ getFunTyExpandingDicts_maybe, applyTy, isPrimType,
+ splitSigmaTy, splitFunTy, eqTy, applyTypeEnvToTy,
+ SYN_IE(Type)
)
import TysWiredIn ( trueDataCon, falseDataCon )
+import Unique ( Unique )
import UniqSupply ( initUs, returnUs, thenUs,
mapUs, mapAndUnzipUs, getUnique,
SYN_IE(UniqSM), UniqSupply
)
import Usage ( SYN_IE(UVar) )
-import Util ( zipEqual, panic, pprPanic, assertPanic )
+import Util ( zipEqual, panic, pprTrace, pprPanic, assertPanic )
+import Pretty
type TypeEnv = TyVarEnv Type
applyUsage = panic "CoreUtils.applyUsage:ToDo"
-- 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) =
+-- pprTrace "appTyArgs" (hsep [ppr PprDebug con, semi,
+-- ppr PprDebug con_ty, semi,
+-- ppr PprDebug args]) $
+ applyTypeToArgs con_ty args
+ where
+ con_ty = dataConRepType con
+
coreExprType (Prim op args) = applyTypeToArgs (primOpType op) args
coreExprType (Lam (ValBinder binder) expr)
= mkForAllUsageTy uvar (panic "coreExprType:Lam UsageBinder") (coreExprType expr)
coreExprType (App expr (TyArg ty))
- = applyTy (coreExprType expr) ty
+ =
+-- pprTrace "appTy1" (hsep [ppr PprDebug fun_ty, space, ppr PprDebug ty]) $
+ applyTy fun_ty ty
+ where
+ fun_ty = coreExprType expr
coreExprType (App expr (UsageArg use))
= applyUsage (coreExprType expr) use
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"
- (ppAboves [ppr PprDebug fun_ty,
+ (vcat [ppr PprDebug fun_ty,
ppr PprShowAll (App expr val_arg)])
#endif
\end{code}
applyTypeToArg op_ty (TyArg ty) = applyTy op_ty ty
applyTypeToArg op_ty (UsageArg _) = panic "applyTypeToArg: UsageArg"
-applyTypeToArg op_ty val_or_lit_arg = case (getFunTy_maybe op_ty) of
+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}
+
%************************************************************************
%* *
\subsection{Routines to manufacture bits of @CoreExpr@}
in
getUnique `thenUs` \ uniq ->
let
- new_var = mkSysLocal SLIT("a") uniq e_ty mkUnknownSrcLoc
+ new_var = mkSysLocal SLIT("a") uniq e_ty noSrcLoc
in
returnUs (VarArg new_var, Just (NonRec new_var other_expr))
\end{code}
argToExpr (LitArg lit) = Lit lit
\end{code}
-\begin{code}
-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
- = case (collectArgs expr) of { (fun, _, _, vargs) ->
- case fun of
- Var v | length vargs == 0 -> True
- _ -> False
- }
-
-{- LATER:
-WAS: MORE CLEVER:
-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 (Coerce _ _ 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 (Coerce _ _ 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))
- -> GenCoreExpr bndr Id
- -> Int
-coreExprArity f (Lam _ expr) = coreExprArity f expr + 1
-coreExprArity f (CoTyLam _ expr) = coreExprArity f expr
-coreExprArity f (App expr arg) = max (coreExprArity f expr - 1) 0
-coreExprArity f (CoTyApp expr _) = coreExprArity f expr
-coreExprArity f (Var v) = max further info
- where
- further
- = case f v of
- Nothing -> 0
- Just expr -> coreExprArity f expr
- info = case (arityMaybe (getIdArity v)) of
- Nothing -> 0
- Just arity -> arity
-coreExprArity f _ = 0
-\end{code}
-
-@isWrapperFor@: we want to see exactly:
-\begin{verbatim}
-/\ ... \ args -> case <arg> of ... -> case <arg> of ... -> wrkr <stuff>
-\end{verbatim}
-
-Probably a little too HACKY [WDP].
-
-\begin{code}
-isWrapperFor :: CoreExpr -> Id -> Bool
-
-expr `isWrapperFor` var
- = case (collectBinders expr) of { (_, _, args, body) -> -- lambdas off the front
- unravel_casing args body
- --NO, THANKS: && not (null args)
- }
- where
- var's_worker = getWorkerId (getIdStrictness var)
-
- is_elem = isIn "isWrapperFor"
-
- --------------
- unravel_casing case_ables (Case scrut alts)
- = case (collectArgs scrut) of { (fun, _, _, vargs) ->
- case fun of
- Var scrut_var -> let
- answer =
- scrut_var /= var && all (doesn't_mention var) vargs
- && scrut_var `is_elem` case_ables
- && unravel_alts case_ables alts
- in
- answer
-
- _ -> False
- }
-
- unravel_casing case_ables other_expr
- = case (collectArgs other_expr) of { (fun, _, _, vargs) ->
- case fun of
- Var wrkr -> let
- answer =
- -- DOESN'T WORK: wrkr == var's_worker
- wrkr /= var
- && isWorkerId wrkr
- && all (doesn't_mention var) vargs
- && all (only_from case_ables) vargs
- in
- answer
-
- _ -> False
- }
-
- --------------
- unravel_alts case_ables (AlgAlts [(_,params,rhs)] NoDefault)
- = unravel_casing (params ++ case_ables) rhs
- unravel_alts case_ables other = False
-
- -------------------------
- doesn't_mention var (ValArg (VarArg v)) = v /= var
- doesn't_mention var other = True
-
- -------------------------
- only_from case_ables (ValArg (VarArg v)) = v `is_elem` case_ables
- only_from case_ables other = True
--}
-\end{code}
-
All the following functions operate on binders, perform a uniform
transformation on them; ie. the function @(\ x -> (x,False))@
annotates all binders with False.
-- *pretend* that the result ty won't be
-- primitive -- somebody later must
-- ensure this.
- -> Maybe (GenCoreExpr a Id TyVar UVar)
+ -> Maybe (GenCoreExpr b Id TyVar UVar)
maybeErrorApp expr result_ty_maybe
= case (collectArgs expr) of
projects / ghc-hetmet.git / blobdiff