- (bndrs, body) = collectBinders (simpleOptExpr lhs)
- -- simpleOptExpr occurrence-analyses and simplifies the lhs
- -- and thereby
- -- (a) identifies unused binders: Note [Unused spec binders]
- -- (b) sorts dict bindings into NonRecs
- -- so they can be inlined by 'decomp'
- -- (c) substitute trivial lets so that they don't get in the way
- -- Note that we substitute the function too; we might
- -- have this as a LHS: let f71 = M.f Int in f71
- -- NB: tcSimplifyRuleLhs is very careful not to generate complicated
- -- dictionary expressions that we might have to match
+ occ_lhs = occurAnalyseExpr lhs
+ -- The occurrence-analysis does two things
+ -- (a) identifies unused binders: Note [Unused spec binders]
+ -- (b) sorts dict bindings into NonRecs
+ -- so they can be inlined by 'decomp'
+ (bndrs, body) = collectBinders occ_lhs
+
+ -- Substitute dicts in the LHS args, so that there
+ -- aren't any lets getting in the way
+ -- Note that we substitute the function too; we might have this as
+ -- a LHS: let f71 = M.f Int in f71
+ decomp env (Let (NonRec dict rhs) body)
+ = decomp (extendVarEnv env dict (simpleSubst env rhs)) body
+ decomp env body
+ = case collectArgs (simpleSubst env body) of
+ (Var fn, args) -> Just (fn, args)
+ _ -> Nothing
+
+simpleSubst :: IdEnv CoreExpr -> CoreExpr -> CoreExpr
+-- Similar to CoreSubst.substExpr, except that
+-- (a) Takes no account of capture; at this point there is no shadowing
+-- (b) Can have a GlobalId (imported) in its domain
+-- (c) Ids only; no types are substituted
+-- (d) Does not insist (as does CoreSubst.lookupIdSubst) that the
+-- in-scope set mentions all LocalIds mentioned in the argument of the subst
+--
+-- (b) and (d) are the reasons we can't use CoreSubst
+--
+-- (I had a note that (b) is "no longer relevant", and indeed it doesn't
+-- look relevant here. Perhaps there was another caller of simpleSubst.)
+
+simpleSubst subst expr
+ = go expr
+ where
+ go (Var v) = lookupVarEnv subst v `orElse` Var v
+ go (Cast e co) = Cast (go e) co
+ go (Type ty) = Type ty
+ go (Lit lit) = Lit lit
+ go (App fun arg) = App (go fun) (go arg)
+ go (Note note e) = Note note (go e)
+ go (Lam bndr body) = Lam bndr (go body)
+ go (Let (NonRec bndr rhs) body) = Let (NonRec bndr (go rhs)) (go body)
+ go (Let (Rec pairs) body) = Let (Rec (mapSnd go pairs)) (go body)
+ go (Case scrut bndr ty alts) = Case (go scrut) bndr ty
+ [(c,bs,go r) | (c,bs,r) <- alts]
+
+addInlinePrags :: [LPrag] -> Id -> CoreExpr -> (Id,CoreExpr)
+addInlinePrags prags bndr rhs
+ = case [inl | L _ (InlinePrag inl) <- prags] of
+ [] -> (bndr, rhs)
+ (inl:_) -> addInlineInfo inl bndr rhs
+
+addInlineInfo :: InlineSpec -> Id -> CoreExpr -> (Id,CoreExpr)
+addInlineInfo (Inline prag is_inline) bndr rhs
+ = (attach_pragma bndr prag, wrap_inline is_inline rhs)
+ where
+ attach_pragma bndr prag
+ | isDefaultInlinePragma prag = bndr
+ | otherwise = bndr `setInlinePragma` prag
+
+ wrap_inline True body = mkInlineMe body
+ wrap_inline False body = body