import Id ( Id )
import VarEnv
import CoreLint ( showPass, endPass )
-import SetLevels ( setLevels,
+import SetLevels ( setLevels, isInlineCtxt,
Level(..), tOP_LEVEL, ltMajLvl, ltLvl, isTopLvl
)
import UniqSupply ( UniqSupply )
ann_bind (Rec pairs)
= Rec [(binder, mkSCC dupd_cc rhs) | (binder, rhs) <- pairs]
--- At one time I tried the effect of not float anything out of an InlineMe,
--- but it sometimes works badly. For example, consider PrelArr.done. It
--- has the form __inline (\d. e)
--- where e doesn't mention d. If we float this to
--- __inline (let x = e in \d. x)
--- things are bad. The inliner doesn't even inline it because it doesn't look
--- like a head-normal form. So it seems a lesser evil to let things float.
--- In SetLevels we do set the context to (Level 0 0) when we get to an InlineMe
--- which discourages floating out.
+floatExpr env lvl (Note InlineMe expr) -- Other than SCCs
+ = case floatExpr env InlineCtxt expr of { (fs, floating_defns, expr') ->
+ ASSERT( null floating_defns ) -- We do no floating out of Inlines
+ (fs, [], Note InlineMe expr') } -- See notes in SetLevels
floatExpr env lvl (Note note expr) -- Other than SCCs
= case (floatExpr env lvl expr) of { (fs, floating_defns, expr') ->
floatExpr env lvl (Let bind body)
= case (floatBind env lvl bind) of { (fsb, rhs_floats, bind', new_env) ->
case (floatExpr new_env lvl body) of { (fse, body_floats, body') ->
- (add_stats fsb fse,
- rhs_floats ++ [(bind_lvl, bind')] ++ body_floats,
- body')
+ if isInlineCtxt lvl then -- No floating inside an InlineMe
+ ASSERT( null rhs_floats && null body_floats )
+ (add_stats fsb fse, [], Let bind' body')
+ else
+ (add_stats fsb fse,
+ rhs_floats ++ [(bind_lvl, bind')] ++ body_floats,
+ body')
}}
where
bind_lvl = getBindLevel bind
Level(..), tOP_LEVEL,
- incMinorLvl, ltMajLvl, ltLvl, isTopLvl
+ incMinorLvl, ltMajLvl, ltLvl, isTopLvl, isInlineCtxt
) where
#include "HsVersions.h"
If you can float to level @Level 0 0@ worth doing so because then your
allocation becomes static instead of dynamic. We always start with
-context @Level 0 0@. @InlineCtxt@ very similar to @Level 0 0@, but is
-used for one purpose: to say "don't float anything out of here".
-That's exactly what we want for the body of an INLINE, where we don't
-want to float anything out at all. See notes with lvlMFE below.
+context @Level 0 0@.
+InlineCtxt
+~~~~~~~~~~
+@InlineCtxt@ very similar to @Level 0 0@, but is used for one purpose:
+to say "don't float anything out of here". That's exactly what we
+want for the body of an INLINE, where we don't want to float anything
+out at all. See notes with lvlMFE below.
+
+But, check this out:
+
+-- At one time I tried the effect of not float anything out of an InlineMe,
+-- but it sometimes works badly. For example, consider PrelArr.done. It
+-- has the form __inline (\d. e)
+-- where e doesn't mention d. If we float this to
+-- __inline (let x = e in \d. x)
+-- things are bad. The inliner doesn't even inline it because it doesn't look
+-- like a head-normal form. So it seems a lesser evil to let things float.
+-- In SetLevels we do set the context to (Level 0 0) when we get to an InlineMe
+-- which discourages floating out.
+
+So the conclusion is: don't do any floating at all inside an InlineMe.
+(In the above example, don't float the {x=e} out of the \d.)
+
+One particular case is that of workers: we don't want to float the
+call to the worker outside the wrapper, otherwise the worker might get
+inlined into the floated expression, and an importing module won't see
+the worker at all.
+
\begin{code}
type LevelledExpr = TaggedExpr Level
type LevelledBind = TaggedBind Level
incMajorLvl :: Level -> Level
-- For InlineCtxt we ignore any inc's; we don't want
--- to do any floating at all. For example,
--- f = __inline__ (\x -> g 3)
--- Don't float the (g 3) because that will stop it being
--- inlined. One particular case is that of workers: we don't
--- want to float the call to the worker outside the wrapper,
--- otherwise the worker might get inlined into the floated expression,
--- and an importing module won't see the worker at all.
+-- to do any floating at all; see notes above
incMajorLvl InlineCtxt = InlineCtxt
incMajorLvl (Level major minor) = Level (major+1) 0
-> LvlM (LevelledBind, LevelEnv)
lvlBind top_lvl ctxt_lvl env (AnnNonRec bndr rhs@(rhs_fvs,_))
+ | isInlineCtxt ctxt_lvl -- Don't do anything inside InlineMe
+ = lvlExpr ctxt_lvl env rhs `thenLvl` \ rhs' ->
+ returnLvl (NonRec (bndr, ctxt_lvl) rhs', env)
+
| null abs_vars
= -- No type abstraction; clone existing binder
lvlExpr dest_lvl env rhs `thenLvl` \ rhs' ->
\begin{code}
lvlBind top_lvl ctxt_lvl env (AnnRec pairs)
+ | isInlineCtxt ctxt_lvl -- Don't do anything inside InlineMe
+ = mapLvl (lvlExpr ctxt_lvl env) rhss `thenLvl` \ rhss' ->
+ returnLvl (Rec ((bndrs `zip` repeat ctxt_lvl) `zip` rhss'), env)
+
| null abs_vars
= cloneRecVars top_lvl env bndrs ctxt_lvl dest_lvl `thenLvl` \ (new_env, new_bndrs) ->
mapLvl (lvlExpr ctxt_lvl new_env) rhss `thenLvl` \ new_rhss ->
projects / ghc-hetmet.git / commitdiff