setLevels,
Level(..), tOP_LEVEL,
+ LevelledBind, LevelledExpr,
incMinorLvl, ltMajLvl, ltLvl, isTopLvl, isInlineCtxt
) where
import CoreSyn
-import CmdLineOpts ( FloatOutSwitches(..) )
+import DynFlags ( FloatOutSwitches(..) )
import CoreUtils ( exprType, exprIsTrivial, exprIsCheap, mkPiTypes )
import CoreFVs -- all of it
-import Subst
-import Id ( Id, idType, mkSysLocal, isOneShotLambda, zapDemandIdInfo,
+import CoreSubst ( Subst, emptySubst, extendInScope, extendIdSubst,
+ cloneIdBndr, cloneRecIdBndrs )
+import Id ( Id, idType, mkSysLocal, isOneShotLambda,
+ zapDemandIdInfo,
idSpecialisation, idWorkerInfo, setIdInfo
)
-import IdInfo ( workerExists, vanillaIdInfo, )
+import IdInfo ( workerExists, vanillaIdInfo, isEmptySpecInfo )
import Var ( Var )
import VarSet
import VarEnv
import Name ( getOccName )
-import OccName ( occNameUserString )
+import OccName ( occNameString )
import Type ( isUnLiftedType, Type )
import BasicTypes ( TopLevelFlag(..) )
import UniqSupply
-import Util ( sortLt, isSingleton, count )
+import Util ( sortLe, isSingleton, count )
import Outputable
import FastString
\end{code}
lvlMFE False ctxt_lvl env arg `thenLvl` \ arg' ->
returnLvl (App fun' arg')
where
- lvl_fun (_, AnnCase _ _ _) = lvlMFE True ctxt_lvl env fun
+-- gaw 2004
+ lvl_fun (_, AnnCase _ _ _ _) = lvlMFE True ctxt_lvl env fun
lvl_fun other = lvlExpr ctxt_lvl env fun
-- We don't do MFE on partial applications generally,
-- but we do if the function is big and hairy, like a case
-- but not nearly so much now non-recursive newtypes are transparent.
-- [See SetLevels rev 1.50 for a version with this approach.]
+lvlExpr ctxt_lvl env (_, AnnLet (AnnNonRec bndr rhs) body)
+ | isUnLiftedType (idType bndr)
+ -- Treat unlifted let-bindings (let x = b in e) just like (case b of x -> e)
+ -- That is, leave it exactly where it is
+ -- We used to float unlifted bindings too (e.g. to get a cheap primop
+ -- outside a lambda (to see how, look at lvlBind in rev 1.58)
+ -- but an unrelated change meant that these unlifed bindings
+ -- could get to the top level which is bad. And there's not much point;
+ -- unlifted bindings are always cheap, and so hardly worth floating.
+ = lvlExpr ctxt_lvl env rhs `thenLvl` \ rhs' ->
+ lvlExpr incd_lvl env' body `thenLvl` \ body' ->
+ returnLvl (Let (NonRec bndr' rhs') body')
+ where
+ incd_lvl = incMinorLvl ctxt_lvl
+ bndr' = TB bndr incd_lvl
+ env' = extendLvlEnv env [bndr']
+
lvlExpr ctxt_lvl env (_, AnnLet bind body)
= lvlBind NotTopLevel ctxt_lvl env bind `thenLvl` \ (bind', new_env) ->
lvlExpr ctxt_lvl new_env body `thenLvl` \ body' ->
returnLvl (Let bind' body')
-lvlExpr ctxt_lvl env (_, AnnCase expr case_bndr alts)
+lvlExpr ctxt_lvl env (_, AnnCase expr case_bndr ty alts)
= lvlMFE True ctxt_lvl env expr `thenLvl` \ expr' ->
let
alts_env = extendCaseBndrLvlEnv env expr' case_bndr incd_lvl
in
mapLvl (lvl_alt alts_env) alts `thenLvl` \ alts' ->
- returnLvl (Case expr' (case_bndr, incd_lvl) alts')
+ returnLvl (Case expr' (TB case_bndr incd_lvl) ty alts')
where
incd_lvl = incMinorLvl ctxt_lvl
= lvlMFE True incd_lvl new_env rhs `thenLvl` \ rhs' ->
returnLvl (con, bs', rhs')
where
- bs' = [ (b, incd_lvl) | b <- bs ]
+ bs' = [ TB b incd_lvl | b <- bs ]
new_env = extendLvlEnv alts_env bs'
\end{code}
@lvlMFE@ is just like @lvlExpr@, except that it might let-bind
the expression, so that it can itself be floated.
+[NOTE: unlifted MFEs]
+We don't float unlifted MFEs, which potentially loses big opportunites.
+For example:
+ \x -> f (h y)
+where h :: Int -> Int# is expensive. We'd like to float the (h y) outside
+the \x, but we don't because it's unboxed. Possible solution: box it.
+
\begin{code}
lvlMFE :: Bool -- True <=> strict context [body of case or let]
-> Level -- Level of innermost enclosing lambda/tylam
lvlMFE strict_ctxt ctxt_lvl env (_, AnnType ty)
= returnLvl (Type ty)
+
lvlMFE strict_ctxt ctxt_lvl env ann_expr@(fvs, _)
- | isUnLiftedType ty -- Can't let-bind it
+ | isUnLiftedType ty -- Can't let-bind it; see [NOTE: unlifted MFEs]
|| isInlineCtxt ctxt_lvl -- Don't float out of an __inline__ context
|| exprIsTrivial expr -- Never float if it's trivial
|| not good_destination
| otherwise -- Float it out!
= lvlFloatRhs abs_vars dest_lvl env ann_expr `thenLvl` \ expr' ->
newLvlVar "lvl" abs_vars ty `thenLvl` \ var ->
- returnLvl (Let (NonRec (var,dest_lvl) expr')
+ returnLvl (Let (NonRec (TB var dest_lvl) expr')
(mkVarApps (Var var) abs_vars))
where
expr = deAnnotate ann_expr
-> LvlM (LevelledBind, LevelEnv)
lvlBind top_lvl ctxt_lvl env (AnnNonRec bndr rhs@(rhs_fvs,_))
- | isInlineCtxt ctxt_lvl -- Don't do anything inside InlineMe
+ | isInlineCtxt ctxt_lvl -- Don't do anything inside InlineMe
= lvlExpr ctxt_lvl env rhs `thenLvl` \ rhs' ->
- returnLvl (NonRec (bndr, ctxt_lvl) rhs', env)
+ returnLvl (NonRec (TB bndr ctxt_lvl) rhs', env)
| null abs_vars
= -- No type abstraction; clone existing binder
lvlExpr dest_lvl env rhs `thenLvl` \ rhs' ->
cloneVar top_lvl env bndr ctxt_lvl dest_lvl `thenLvl` \ (env', bndr') ->
- returnLvl (NonRec (bndr', dest_lvl) rhs', env')
+ returnLvl (NonRec (TB bndr' dest_lvl) rhs', env')
| otherwise
= -- Yes, type abstraction; create a new binder, extend substitution, etc
lvlFloatRhs abs_vars dest_lvl env rhs `thenLvl` \ rhs' ->
newPolyBndrs dest_lvl env abs_vars [bndr] `thenLvl` \ (env', [bndr']) ->
- returnLvl (NonRec (bndr', dest_lvl) rhs', env')
+ returnLvl (NonRec (TB bndr' dest_lvl) rhs', env')
where
bind_fvs = rhs_fvs `unionVarSet` idFreeVars bndr
abs_vars = abstractVars dest_lvl env bind_fvs
-
- dest_lvl | isUnLiftedType (idType bndr) = destLevel env bind_fvs False `maxLvl` Level 1 0
- | otherwise = destLevel env bind_fvs (isFunction rhs)
- -- Hack alert! We do have some unlifted bindings, for cheap primops, and
- -- it is ok to float them out; but not to the top level. If they would otherwise
- -- go to the top level, we pin them inside the topmost lambda
+ dest_lvl = destLevel env bind_fvs (isFunction rhs)
\end{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)
+ returnLvl (Rec ([TB b ctxt_lvl | b <- bndrs] `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 ->
- returnLvl (Rec ((new_bndrs `zip` repeat dest_lvl) `zip` new_rhss), new_env)
+ returnLvl (Rec ([TB b dest_lvl | b <- new_bndrs] `zip` new_rhss), new_env)
| isSingleton pairs && count isId abs_vars > 1
= -- Special case for self recursion where there are
in
lvlExpr body_lvl body_env rhs_body `thenLvl` \ new_rhs_body ->
newPolyBndrs dest_lvl env abs_vars [bndr] `thenLvl` \ (poly_env, [poly_bndr]) ->
- returnLvl (Rec [((poly_bndr,dest_lvl), mkLams abs_vars_w_lvls $
- mkLams new_lam_bndrs $
- Let (Rec [((new_bndr,rhs_lvl), mkLams new_lam_bndrs new_rhs_body)])
- (mkVarApps (Var new_bndr) lam_bndrs))],
+ returnLvl (Rec [(TB poly_bndr dest_lvl,
+ mkLams abs_vars_w_lvls $
+ mkLams new_lam_bndrs $
+ Let (Rec [(TB new_bndr rhs_lvl, mkLams new_lam_bndrs new_rhs_body)])
+ (mkVarApps (Var new_bndr) lam_bndrs))],
poly_env)
| otherwise -- Non-null abs_vars
= newPolyBndrs dest_lvl env abs_vars bndrs `thenLvl` \ (new_env, new_bndrs) ->
mapLvl (lvlFloatRhs abs_vars dest_lvl new_env) rhss `thenLvl` \ new_rhss ->
- returnLvl (Rec ((new_bndrs `zip` repeat dest_lvl) `zip` new_rhss), new_env)
+ returnLvl (Rec ([TB b dest_lvl | b <- new_bndrs] `zip` new_rhss), new_env)
where
(bndrs,rhss) = unzip pairs
%************************************************************************
\begin{code}
-lvlLamBndrs :: Level -> [CoreBndr] -> (Level, [(CoreBndr, Level)])
+lvlLamBndrs :: Level -> [CoreBndr] -> (Level, [TaggedBndr Level])
-- Compute the levels for the binders of a lambda group
-- The binders returned are exactly the same as the ones passed,
-- but they are now paired with a level
| isId bndr && -- Go to the next major level if this is a value binder,
not bumped_major && -- and we havn't already gone to the next level (one jump per group)
not (isOneShotLambda bndr) -- and it isn't a one-shot lambda
- = go new_lvl True ((bndr,new_lvl) : rev_lvld_bndrs) bndrs
+ = go new_lvl True (TB bndr new_lvl : rev_lvld_bndrs) bndrs
| otherwise
- = go old_lvl bumped_major ((bndr,old_lvl) : rev_lvld_bndrs) bndrs
+ = go old_lvl bumped_major (TB bndr old_lvl : rev_lvld_bndrs) bndrs
where
new_lvl = incMajorLvl old_lvl
floatConsts :: LevelEnv -> Bool
floatConsts (FloatOutSw _ float_consts, _, _, _) = float_consts
-extendLvlEnv :: LevelEnv -> [(Var,Level)] -> LevelEnv
+extendLvlEnv :: LevelEnv -> [TaggedBndr Level] -> LevelEnv
-- Used when *not* cloning
extendLvlEnv (float_lams, lvl_env, subst, id_env) prs
= (float_lams,
foldl del_subst subst prs,
foldl del_id id_env prs)
where
- add_lvl env (v,l) = extendVarEnv env v l
- del_subst env (v,_) = extendInScope env v
- del_id env (v,_) = delVarEnv env v
+ add_lvl env (TB v l) = extendVarEnv env v l
+ del_subst env (TB v _) = extendInScope env v
+ del_id env (TB v _) = delVarEnv env v
-- We must remove any clone for this variable name in case of
-- shadowing. This bit me in the following case
-- (in nofib/real/gg/Spark.hs):
extendCaseBndrLvlEnv (float_lams, lvl_env, subst, id_env) (Var scrut_var) case_bndr lvl
= (float_lams,
extendVarEnv lvl_env case_bndr lvl,
- extendSubst subst case_bndr (DoneEx (Var scrut_var)),
+ extendIdSubst subst case_bndr (Var scrut_var),
extendVarEnv id_env case_bndr ([scrut_var], Var scrut_var))
extendCaseBndrLvlEnv env scrut case_bndr lvl
- = extendLvlEnv env [(case_bndr,lvl)]
+ = extendLvlEnv env [TB case_bndr lvl]
extendPolyLvlEnv dest_lvl (float_lams, lvl_env, subst, id_env) abs_vars bndr_pairs
= (float_lams,
foldl add_id id_env bndr_pairs)
where
add_lvl env (v,v') = extendVarEnv env v' dest_lvl
- add_subst env (v,v') = extendSubst env v (DoneEx (mkVarApps (Var v') abs_vars))
+ add_subst env (v,v') = extendIdSubst env v (mkVarApps (Var v') abs_vars)
add_id env (v,v') = extendVarEnv env v ((v':abs_vars), mkVarApps (Var v') abs_vars)
extendCloneLvlEnv lvl (float_lams, lvl_env, _, id_env) new_subst bndr_pairs
-- whose level is greater than the destination level
-- These are the ones we are going to abstract out
abstractVars dest_lvl env fvs
- = uniq (sortLt lt [var | fv <- varSetElems fvs, var <- absVarsOf dest_lvl env fv])
+ = uniq (sortLe le [var | fv <- varSetElems fvs, var <- absVarsOf dest_lvl env fv])
where
-- Sort the variables so we don't get
-- mixed-up tyvars and Ids; it's just messy
- v1 `lt` v2 = case (isId v1, isId v2) of
+ v1 `le` v2 = case (isId v1, isId v2) of
(True, False) -> False
(False, True) -> True
- other -> v1 < v2 -- Same family
+ other -> v1 <= v2 -- Same family
uniq :: [Var] -> [Var]
-- Remove adjacent duplicates; the sort will have brought them together
-- We are going to lambda-abstract, so nuke any IdInfo,
-- and add the tyvars of the Id (if necessary)
zap v | isId v = WARN( workerExists (idWorkerInfo v) ||
- not (isEmptyCoreRules (idSpecialisation v)),
+ not (isEmptySpecInfo (idSpecialisation v)),
text "absVarsOf: discarding info on" <+> ppr v )
setIdInfo v vanillaIdInfo
| otherwise = v
where
mk_poly_bndr bndr uniq = mkSysLocal (mkFastString str) uniq poly_ty
where
- str = "poly_" ++ occNameUserString (getOccName bndr)
+ str = "poly_" ++ occNameString (getOccName bndr)
poly_ty = mkPiTypes abs_vars (idType bndr)
= ASSERT( isId v )
getUs `thenLvl` \ us ->
let
- (subst', v1) = substAndCloneId subst us v
+ (subst', v1) = cloneIdBndr subst us v
v2 = zap_demand ctxt_lvl dest_lvl v1
env' = extendCloneLvlEnv dest_lvl env subst' [(v,v2)]
in
= ASSERT( all isId vs )
getUs `thenLvl` \ us ->
let
- (subst', vs1) = substAndCloneRecIds subst us vs
+ (subst', vs1) = cloneRecIdBndrs subst us vs
vs2 = map (zap_demand ctxt_lvl dest_lvl) vs1
env' = extendCloneLvlEnv dest_lvl env subst' (vs `zip` vs2)
in
projects / ghc-hetmet.git / blobdiff