-substExpr :: TyVarSubst -> IdSubst -- Substitution
- -> IdOrTyVarSet -- Superset of in-scope
- -> CoreExpr
- -> CoreExpr
-
-substExpr te ve in_scope expr = subst_expr (te, ve, in_scope) expr
-
-subst_expr env@(te, ve, in_scope) expr
- = go expr
- where
- go (Var v) = case lookupVarEnv ve v of
- Just (Done e')
- -> e'
-
- Just (SubstMe e' te' ve')
- -> subst_expr (te', ve', in_scope) e'
-
- Nothing -> case lookupVarSet in_scope v of
- Just v' -> Var v'
- Nothing -> Var v
- -- NB: we look up in the in_scope set because the variable
- -- there may have more info. In particular, when substExpr
- -- is called from the simplifier, the type inside the *occurrences*
- -- of a variable may not be right; we should replace it with the
- -- binder, from the in_scope set.
-
- go (Type ty) = Type (go_ty ty)
- go (Con con args) = Con con (map go args)
- go (App fun arg) = App (go fun) (go arg)
- go (Note note e) = Note (go_note note) (go e)
-
- go (Lam bndr body) = Lam bndr' (subst_expr env' body)
- where
- (env', bndr') = go_bndr env bndr
-
- go (Let (NonRec bndr rhs) body) = Let (NonRec bndr' (go rhs)) (subst_expr env' body)
- where
- (env', bndr') = go_bndr env bndr
-
- go (Let (Rec pairs) body) = Let (Rec pairs') (subst_expr env' body)
- where
- (ve', in_scope', _, bndrs')
- = substIds clone_fn te ve in_scope undefined (map fst pairs)
- env' = (te, ve', in_scope')
- pairs' = bndrs' `zip` rhss'
- rhss' = map (subst_expr env' . snd) pairs
-
- go (Case scrut bndr alts) = Case (go scrut) bndr' (map (go_alt env') alts)
- where
- (env', bndr') = go_bndr env bndr
-
- go_alt env (con, bndrs, rhs) = (con, bndrs', subst_expr env' rhs)
- where
- (env', bndrs') = mapAccumL go_bndr env bndrs
-
- go_note (Coerce ty1 ty2) = Coerce (go_ty ty1) (go_ty ty2)
- go_note note = note
-
- go_ty ty = fullSubstTy te in_scope ty
-
- go_bndr (te, ve, in_scope) bndr
- | isTyVar bndr
- = case substTyVar te in_scope bndr of
- (te', in_scope', bndr') -> ((te', ve, in_scope'), bndr')
-
- | otherwise
- = case substId clone_fn te ve in_scope undefined bndr of
- (ve', in_scope', _, bndr') -> ((te, ve', in_scope'), bndr')
-
-
- clone_fn in_scope _ bndr
- | bndr `elemVarSet` in_scope = Just (uniqAway in_scope bndr, undefined)
- | otherwise = Nothing
-
+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) = v `seq` 1
+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 (CoreNote s) = s `seq` 1 -- hdaume: core annotations
+
+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