-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)
- 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)
+coreBindsSize :: [CoreBind] -> Int
+coreBindsSize bs = foldr ((+) . bindSize) 0 bs
+
+exprSize :: CoreExpr -> Int
+ -- A measure of the size of the expressions
+ -- It also forces the expression pretty drastically as a side effect
+exprSize (Var v) = varSize v
+exprSize (Lit lit) = lit `seq` 1
+exprSize (App f a) = exprSize f + exprSize a
+exprSize (Lam b e) = varSize b + exprSize e
+exprSize (Let b e) = bindSize b + exprSize e
+exprSize (Case e b as) = exprSize e + varSize b + foldr ((+) . altSize) 0 as
+exprSize (Note n e) = noteSize n + exprSize e
+exprSize (Type t) = seqType t `seq` 1
+
+noteSize (SCC cc) = cc `seq` 1
+noteSize (Coerce t1 t2) = seqType t1 `seq` seqType t2 `seq` 1
+noteSize InlineCall = 1
+noteSize InlineMe = 1
+noteSize (TermUsg usg) = usg `seq` 1
+
+varSize :: Var -> Int
+varSize b | isTyVar b = 1
+ | otherwise = seqType (idType b) `seq`
+ megaSeqIdInfo (idInfo b) `seq`
+ 1
+
+varsSize = foldr ((+) . varSize) 0
+
+bindSize (NonRec b e) = varSize b + exprSize e
+bindSize (Rec prs) = foldr ((+) . pairSize) 0 prs
+
+pairSize (b,e) = varSize b + exprSize e
+
+altSize (c,bs,e) = c `seq` varsSize bs + exprSize e