-{-# OPTIONS -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
--- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
-
zapDemandIdInfo, transferPolyIdInfo,
idSpecialisation, idWorkerInfo, setIdInfo
)
zapDemandIdInfo, transferPolyIdInfo,
idSpecialisation, idWorkerInfo, setIdInfo
)
-import IdInfo ( workerExists, vanillaIdInfo, isEmptySpecInfo,
- setNewStrictnessInfo, newStrictnessInfo,
- setArityInfo, arityInfo )
tOP_LEVEL = Level 0 0
iNLINE_CTXT = InlineCtxt
incMajorLvl :: Level -> Level
-- For InlineCtxt we ignore any inc's; we don't want
-- to do any floating at all; see notes above
tOP_LEVEL = Level 0 0
iNLINE_CTXT = InlineCtxt
incMajorLvl :: Level -> Level
-- For InlineCtxt we ignore any inc's; we don't want
-- to do any floating at all; see notes above
ltLvl InlineCtxt (Level _ _) = True
ltLvl (Level maj1 min1) (Level maj2 min2)
= (maj1 < maj2) || (maj1 == maj2 && min1 < min2)
ltMajLvl :: Level -> Level -> Bool
-- Tells if one level belongs to a difft *lambda* level to another
ltLvl InlineCtxt (Level _ _) = True
ltLvl (Level maj1 min1) (Level maj2 min2)
= (maj1 < maj2) || (maj1 == maj2 && min1 < min2)
ltMajLvl :: Level -> Level -> Bool
-- Tells if one level belongs to a difft *lambda* level to another
ltMajLvl (Level maj1 _) (Level maj2 _) = maj1 < maj2
isTopLvl :: Level -> Bool
isTopLvl (Level 0 0) = True
ltMajLvl (Level maj1 _) (Level maj2 _) = maj1 < maj2
isTopLvl :: Level -> Bool
isTopLvl (Level 0 0) = True
instance Outputable Level where
ppr InlineCtxt = text "<INLINE>"
ppr (Level maj min) = hcat [ char '<', int maj, char ',', int min, char '>' ]
instance Eq Level where
instance Outputable Level where
ppr InlineCtxt = text "<INLINE>"
ppr (Level maj min) = hcat [ char '<', int maj, char ',', int min, char '>' ]
instance Eq Level where
- InlineCtxt == InlineCtxt = True
- (Level maj1 min1) == (Level maj2 min2) = maj1==maj2 && min1==min2
- l1 == l2 = False
+ InlineCtxt == InlineCtxt = True
+ (Level maj1 min1) == (Level maj2 min2) = maj1 == maj2 && min1 == min2
+ _ == _ = False
lvlTopBind env (NonRec binder rhs)
= lvlBind TopLevel tOP_LEVEL env (AnnNonRec binder (freeVars rhs))
-- Rhs can have no free vars!
lvlTopBind env (NonRec binder rhs)
= lvlBind TopLevel tOP_LEVEL env (AnnNonRec binder (freeVars rhs))
-- Rhs can have no free vars!
-- We don't do MFE on partial applications generally,
-- but we do if the function is big and hairy, like a case
-- We don't do MFE on partial applications generally,
-- but we do if the function is big and hairy, like a case
-- Don't float anything out of an InlineMe; hence the iNLINE_CTXT
expr' <- lvlExpr iNLINE_CTXT env expr
return (Note InlineMe expr')
-- Don't float anything out of an InlineMe; hence the iNLINE_CTXT
expr' <- lvlExpr iNLINE_CTXT env expr
return (Note InlineMe expr')
-- Why not? Because partial applications are fairly rare, and splitting
-- lambdas makes them more expensive.
-- Why not? Because partial applications are fairly rare, and splitting
-- lambdas makes them more expensive.
@lvlMFE@ is just like @lvlExpr@, except that it might let-bind
the expression, so that it can itself be floated.
@lvlMFE@ is just like @lvlExpr@, except that it might let-bind
the expression, so that it can itself be floated.
|| isInlineCtxt ctxt_lvl -- Don't float out of an __inline__ context
|| exprIsTrivial expr -- Never float if it's trivial
|| not good_destination
|| isInlineCtxt ctxt_lvl -- Don't float out of an __inline__ context
|| exprIsTrivial expr -- Never float if it's trivial
|| not good_destination
-> LvlM (LevelledBind, LevelEnv)
lvlBind top_lvl ctxt_lvl env (AnnNonRec bndr rhs@(rhs_fvs,_))
-> LvlM (LevelledBind, LevelEnv)
lvlBind top_lvl ctxt_lvl env (AnnNonRec bndr rhs@(rhs_fvs,_))
- | isInlineCtxt ctxt_lvl -- Don't do anything inside InlineMe
+ | isTyVar bndr -- Don't do anything for TyVar binders
+ -- (simplifier gets rid of them pronto)
+ || isInlineCtxt ctxt_lvl -- Don't do anything inside InlineMe
= do rhs' <- lvlExpr ctxt_lvl env rhs
return (NonRec (TB bndr ctxt_lvl) rhs', env)
= do rhs' <- lvlExpr ctxt_lvl env rhs
return (NonRec (TB bndr ctxt_lvl) rhs', env)
new_rhss <- mapM (lvlExpr ctxt_lvl new_env) rhss
return (Rec ([TB b dest_lvl | b <- new_bndrs] `zip` new_rhss), new_env)
new_rhss <- mapM (lvlExpr ctxt_lvl new_env) rhss
return (Rec ([TB b dest_lvl | b <- new_bndrs] `zip` new_rhss), new_env)
= do -- Special case for self recursion where there are
-- several variables carried around: build a local loop:
-- poly_f = \abs_vars. \lam_vars . letrec f = \lam_vars. rhs in f lam_vars
= do -- Special case for self recursion where there are
-- several variables carried around: build a local loop:
-- poly_f = \abs_vars. \lam_vars . letrec f = \lam_vars. rhs in f lam_vars
----------------------------------------------------
-- Three help functons for the type-abstraction case
----------------------------------------------------
-- Three help functons for the type-abstraction case
lvlFloatRhs abs_vars dest_lvl env rhs = do
rhs' <- lvlExpr rhs_lvl rhs_env rhs
return (mkLams abs_vars_w_lvls rhs')
lvlFloatRhs abs_vars dest_lvl env rhs = do
rhs' <- lvlExpr rhs_lvl rhs_env rhs
return (mkLams abs_vars_w_lvls rhs')
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 (TB bndr new_lvl : rev_lvld_bndrs) bndrs
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 (TB bndr new_lvl : rev_lvld_bndrs) bndrs
-- We may only want to do this if there are sufficiently few free
-- variables. We certainly only want to do it for values, and not for
-- constructors. So the simple thing is just to look for lambdas
-- We may only want to do this if there are sufficiently few free
-- variables. We certainly only want to do it for values, and not for
-- constructors. So the simple thing is just to look for lambdas
-isFunction (_, AnnLam b e) | isId b = True
- | otherwise = isFunction e
-isFunction (_, AnnNote n e) = isFunction e
-isFunction other = False
+isFunction (_, AnnLam b e) | isIdVar b = True
+ | otherwise = isFunction e
+isFunction (_, AnnNote _ e) = isFunction e
+isFunction _ = False
-- extendCaseBndrLvlEnv adds the mapping case-bndr->scrut-var if it can
-- (see point 4 of the module overview comment)
-- extendCaseBndrLvlEnv adds the mapping case-bndr->scrut-var if it can
-- (see point 4 of the module overview comment)
extendCaseBndrLvlEnv (float_lams, lvl_env, subst, id_env) (Var scrut_var) case_bndr lvl
= (float_lams,
extendVarEnv lvl_env case_bndr lvl,
extendIdSubst subst case_bndr (Var scrut_var),
extendVarEnv id_env case_bndr ([scrut_var], Var scrut_var))
extendCaseBndrLvlEnv (float_lams, lvl_env, subst, id_env) (Var scrut_var) case_bndr lvl
= (float_lams,
extendVarEnv lvl_env case_bndr lvl,
extendIdSubst subst case_bndr (Var scrut_var),
extendVarEnv id_env case_bndr ([scrut_var], Var scrut_var))
extendPolyLvlEnv dest_lvl (float_lams, lvl_env, subst, id_env) abs_vars bndr_pairs
= (float_lams,
foldl add_lvl lvl_env bndr_pairs,
foldl add_subst subst bndr_pairs,
foldl add_id id_env bndr_pairs)
where
extendPolyLvlEnv dest_lvl (float_lams, lvl_env, subst, id_env) abs_vars bndr_pairs
= (float_lams,
foldl add_lvl lvl_env bndr_pairs,
foldl add_subst subst bndr_pairs,
foldl add_id id_env bndr_pairs)
where
- add_lvl env (v,v') = extendVarEnv env v' dest_lvl
- 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)
+ add_lvl env (_, v') = extendVarEnv env v' dest_lvl
+ 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
= (float_lams,
foldl add_lvl lvl_env bndr_pairs,
new_subst,
foldl add_id id_env bndr_pairs)
where
extendCloneLvlEnv lvl (float_lams, lvl_env, _, id_env) new_subst bndr_pairs
= (float_lams,
foldl add_lvl lvl_env bndr_pairs,
new_subst,
foldl add_id id_env bndr_pairs)
where
- add_lvl env (v,v') = extendVarEnv env v' lvl
- add_id env (v,v') = extendVarEnv env v ([v'], Var v')
+ add_lvl env (_, v') = extendVarEnv env v' lvl
+ add_id env (v, v') = extendVarEnv env v ([v'], Var v')
lookupVar :: LevelEnv -> Id -> LevelledExpr
lookupVar (_, _, _, id_env) v = case lookupVarEnv id_env v of
Just (_, expr) -> expr
lookupVar :: LevelEnv -> Id -> LevelledExpr
lookupVar (_, _, _, id_env) v = case lookupVarEnv id_env v of
Just (_, expr) -> expr
abstractVars :: Level -> LevelEnv -> VarSet -> [Var]
-- Find the variables in fvs, free vars of the target expresion,
abstractVars :: Level -> LevelEnv -> VarSet -> [Var]
-- Find the variables in fvs, free vars of the target expresion,
-- We are going to lambda-abstract, so nuke any IdInfo,
-- and add the tyvars of the Id (if necessary)
-- We are going to lambda-abstract, so nuke any IdInfo,
-- and add the tyvars of the Id (if necessary)
not (isEmptySpecInfo (idSpecialisation v)),
text "absVarsOf: discarding info on" <+> ppr v )
setIdInfo v vanillaIdInfo
not (isEmptySpecInfo (idSpecialisation v)),
text "absVarsOf: discarding info on" <+> ppr v )
setIdInfo v vanillaIdInfo
-- to the rules inside each Id. Grr. But it matters.
cloneVar :: TopLevelFlag -> LevelEnv -> Id -> Level -> Level -> LvlM (LevelEnv, Id)
-- to the rules inside each Id. Grr. But it matters.
cloneVar :: TopLevelFlag -> LevelEnv -> Id -> Level -> Level -> LvlM (LevelEnv, Id)
= return (env, v) -- Don't clone top level things
cloneVar NotTopLevel env@(_,_,subst,_) v ctxt_lvl dest_lvl
= return (env, v) -- Don't clone top level things
cloneVar NotTopLevel env@(_,_,subst,_) v ctxt_lvl dest_lvl
= return (env, vs) -- Don't clone top level things
cloneRecVars NotTopLevel env@(_,_,subst,_) vs ctxt_lvl dest_lvl
= return (env, vs) -- Don't clone top level things
cloneRecVars NotTopLevel env@(_,_,subst,_) vs ctxt_lvl dest_lvl
-- VERY IMPORTANT: we must zap the demand info
-- if the thing is going to float out past a lambda,
-- or if it's going to top level (where things can't be strict)
-- VERY IMPORTANT: we must zap the demand info
-- if the thing is going to float out past a lambda,
-- or if it's going to top level (where things can't be strict)
zap_demand dest_lvl ctxt_lvl id
| ctxt_lvl == dest_lvl,
not (isTopLvl dest_lvl) = id -- Stays, and not going to top level
zap_demand dest_lvl ctxt_lvl id
| ctxt_lvl == dest_lvl,
not (isTopLvl dest_lvl) = id -- Stays, and not going to top level