import SrcLoc ( Located(..) )
import Maybes ( isJust, catMaybes, orElse )
import Bag ( bagToList )
-import BasicTypes ( Activation(..), InlineSpec(..), isAlwaysActive, defaultInlineSpec )
+import BasicTypes ( Activation(..), InlineSpec(..), isAlwaysActive )
import Monad ( foldM )
import FastString ( mkFastString )
import List ( (\\) )
mappM (addAutoScc auto_scc) sel_binds `thenDs` \ sel_binds ->
returnDs (sel_binds ++ rest)
- -- Common special case: no type or dictionary abstraction
- -- For the (rare) case when there are some mixed-up
- -- dictionary bindings (for which a Rec is convenient)
- -- we reply on the enclosing dsBind to wrap a Rec around.
+-- Note [Rules and inlining]
+-- Common special case: no type or dictionary abstraction
+-- This is a bit less trivial than you might suppose
+-- The naive way woudl be to desguar to something like
+-- f_lcl = ...f_lcl... -- The "binds" from AbsBinds
+-- M.f = f_lcl -- Generated from "exports"
+-- But we don't want that, because if M.f isn't exported,
+-- it'll be inlined unconditionally at every call site (its rhs is
+-- trivial). That woudl be ok unless it has RULES, which would
+-- thereby be completely lost. Bad, bad, bad.
+--
+-- Instead we want to generate
+-- M.f = ...f_lcl...
+-- f_lcl = M.f
+-- Now all is cool. The RULES are attached to M.f (by SimplCore),
+-- and f_lcl is rapidly inlined away.
+--
+-- This does not happen in the same way to polymorphic binds,
+-- because they desugar to
+-- M.f = /\a. let f_lcl = ...f_lcl... in f_lcl
+-- Although I'm a bit worried about whether full laziness might
+-- float the f_lcl binding out and then inline M.f at its call site
+
dsHsBind auto_scc rest (AbsBinds [] [] exports binds)
- = ds_lhs_binds (addSccs auto_scc exports) binds `thenDs` \ core_prs ->
- let
- core_prs' = addLocalInlines exports core_prs
- exports' = [(global, Var local) | (_, global, local, _) <- exports]
- in
- returnDs (core_prs' ++ exports' ++ rest)
+ = do { core_prs <- ds_lhs_binds (addSccs auto_scc exports) binds
+ ; let env = mkVarEnv [ (lcl_id, (gbl_id, prags))
+ | (_, gbl_id, lcl_id, prags) <- exports]
+ do_one (lcl_id, rhs) | Just (gbl_id, prags) <- lookupVarEnv env lcl_id
+ = addInlinePrags prags gbl_id rhs
+ | otherwise = (lcl_id, rhs)
+ locals' = [(lcl_id, Var gbl_id) | (_, gbl_id, lcl_id, _) <- exports]
+ ; return (map do_one core_prs ++ locals' ++ rest) }
+ -- No Rec needed here (contrast the other AbsBinds cases)
+ -- because we can rely on the enclosing dsBind to wrap in Rec
-- Another common case: one exported variable
-- Non-recursive bindings come through this way
(spec_binds, rules) = unzip (catMaybes mb_specs)
global' = addIdSpecialisations global rules
rhs' = mkLams tyvars $ mkLams dicts $ Let core_bind (Var local)
- inl = case [inl | InlinePrag inl <- prags] of
- [] -> defaultInlineSpec
- (inl:_) -> inl
in
- returnDs (addInlineInfo inl global' rhs' : spec_binds ++ rest)
+ returnDs (addInlinePrags prags global' rhs' : spec_binds ++ rest)
dsHsBind auto_scc rest (AbsBinds all_tyvars dicts exports binds)
= ds_lhs_binds (addSccs auto_scc exports) binds `thenDs` \ core_prs ->
let
+ add_inline (bndr,rhs) | Just prags <- lookupVarEnv inline_env bndr
+ = addInlinePrags prags bndr rhs
+ | otherwise = (bndr,rhs)
+ inline_env = mkVarEnv [(lcl_id, prags) | (_, _, lcl_id, prags) <- exports]
+
-- Rec because of mixed-up dictionary bindings
- core_bind = Rec (addLocalInlines exports core_prs)
+ core_bind = Rec (map add_inline core_prs)
tup_expr = mkTupleExpr locals
tup_ty = exprType tup_expr
mb_lhs = decomposeRuleLhs (bndrs ++ const_dicts) body
; case mb_lhs of
- Nothing -> do { dsWarn msg; return Nothing }
+ Nothing -> do { warnDs msg; return Nothing }
Just (bndrs', var, args) -> return (Just (addInlineInfo inl spec_id spec_rhs, rule))
where
= 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 (Case scrut bndr ty alts) = Case (go scrut) bndr ty
[(c,bs,go r) | (c,bs,r) <- alts]
-addLocalInlines exports core_prs
- = map add_inline core_prs
- where
- add_inline (bndr,rhs) | Just inl <- lookupVarEnv inline_env bndr
- = addInlineInfo inl bndr rhs
- | otherwise
- = (bndr,rhs)
- inline_env = mkVarEnv [(mono_id, prag)
- | (_, _, mono_id, prags) <- exports,
- InlinePrag prag <- prags]
-
+addInlinePrags :: [Prag] -> Id -> CoreExpr -> (Id,CoreExpr)
+addInlinePrags prags bndr rhs
+ = case [inl | InlinePrag inl <- prags] of
+ [] -> (bndr, rhs)
+ (inl:_) -> addInlineInfo inl bndr rhs
+
addInlineInfo :: InlineSpec -> Id -> CoreExpr -> (Id,CoreExpr)
addInlineInfo (Inline phase is_inline) bndr rhs
= (attach_phase bndr phase, wrap_inline is_inline rhs)
dsCoercion :: ExprCoFn -> DsM CoreExpr -> DsM CoreExpr
dsCoercion CoHole thing_inside = thing_inside
dsCoercion (CoCompose c1 c2) thing_inside = dsCoercion c1 (dsCoercion c2 thing_inside)
-dsCoercion (CoLams ids c) thing_inside = do { expr <- dsCoercion c thing_inside
+dsCoercion (ExprCoFn co) thing_inside = do { expr <- thing_inside
+ ; return (Cast expr co) }
+dsCoercion (CoLams ids) thing_inside = do { expr <- thing_inside
; return (mkLams ids expr) }
-dsCoercion (CoTyLams tvs c) thing_inside = do { expr <- dsCoercion c thing_inside
+dsCoercion (CoTyLams tvs) thing_inside = do { expr <- thing_inside
; return (mkLams tvs expr) }
-dsCoercion (CoApps c ids) thing_inside = do { expr <- dsCoercion c thing_inside
+dsCoercion (CoApps ids) thing_inside = do { expr <- thing_inside
; return (mkVarApps expr ids) }
-dsCoercion (CoTyApps c tys) thing_inside = do { expr <- dsCoercion c thing_inside
+dsCoercion (CoTyApps tys) thing_inside = do { expr <- thing_inside
; return (mkTyApps expr tys) }
-dsCoercion (CoLet bs c) thing_inside = do { prs <- dsLHsBinds bs
- ; expr <- dsCoercion c thing_inside
+dsCoercion (CoLet bs) thing_inside = do { prs <- dsLHsBinds bs
+ ; expr <- thing_inside
; return (Let (Rec prs) expr) }
\end{code}
projects / ghc-hetmet.git / blobdiff