Commit 64c71ce9 authored by Ben Gamari's avatar Ben Gamari Committed by Ben Gamari

Don't use unsafeGlobalDynFlags in optCoercion

This plumbs DynFlags through CoreOpt so optCoercion can finally
eliminate its usage of `unsafeGlobalDynFlags`.

Note that this doesn't completely eliminate `unsafeGlobalDynFlags`
usage from this bit of the compiler. A few uses are introduced in
call-sites where we don't (yet) have ready access to `DynFlags`.

Test Plan: Validate

Reviewers: goldfire

Subscribers: rwbarton, thomie, carter

Differential Revision: https://phabricator.haskell.org/D4774
parent f7417118
......@@ -86,7 +86,7 @@ little dance in action; the full Simplifier is a lot more complicated.
-}
simpleOptExpr :: CoreExpr -> CoreExpr
simpleOptExpr :: DynFlags -> CoreExpr -> CoreExpr
-- See Note [The simple optimiser]
-- Do simple optimisation on an expression
-- The optimisation is very straightforward: just
......@@ -103,9 +103,9 @@ simpleOptExpr :: CoreExpr -> CoreExpr
-- in (let x = y in ....) we substitute for x; so y's occ-info
-- may change radically
simpleOptExpr expr
simpleOptExpr dflags expr
= -- pprTrace "simpleOptExpr" (ppr init_subst $$ ppr expr)
simpleOptExprWith init_subst expr
simpleOptExprWith dflags init_subst expr
where
init_subst = mkEmptySubst (mkInScopeSet (exprFreeVars expr))
-- It's potentially important to make a proper in-scope set
......@@ -118,12 +118,14 @@ simpleOptExpr expr
-- It's a bit painful to call exprFreeVars, because it makes
-- three passes instead of two (occ-anal, and go)
simpleOptExprWith :: Subst -> InExpr -> OutExpr
simpleOptExprWith :: DynFlags -> Subst -> InExpr -> OutExpr
-- See Note [The simple optimiser]
simpleOptExprWith subst expr
simpleOptExprWith dflags subst expr
= simple_opt_expr init_env (occurAnalyseExpr expr)
where
init_env = SOE { soe_inl = emptyVarEnv, soe_subst = subst }
init_env = SOE { soe_dflags = dflags
, soe_inl = emptyVarEnv
, soe_subst = subst }
----------------------
simpleOptPgm :: DynFlags -> Module
......@@ -141,7 +143,7 @@ simpleOptPgm dflags this_mod binds rules
(\_ -> False) {- No rules active -}
rules binds
(final_env, binds') = foldl do_one (emptyEnv, []) occ_anald_binds
(final_env, binds') = foldl do_one (emptyEnv dflags, []) occ_anald_binds
final_subst = soe_subst final_env
rules' = substRulesForImportedIds final_subst rules
......@@ -159,7 +161,8 @@ simpleOptPgm dflags this_mod binds rules
type SimpleClo = (SimpleOptEnv, InExpr)
data SimpleOptEnv
= SOE { soe_inl :: IdEnv SimpleClo
= SOE { soe_dflags :: DynFlags
, soe_inl :: IdEnv SimpleClo
-- Deals with preInlineUnconditionally; things
-- that occur exactly once and are inlined
-- without having first been simplified
......@@ -174,13 +177,15 @@ instance Outputable SimpleOptEnv where
, text "soe_subst =" <+> ppr subst ]
<+> text "}"
emptyEnv :: SimpleOptEnv
emptyEnv = SOE { soe_inl = emptyVarEnv
, soe_subst = emptySubst }
emptyEnv :: DynFlags -> SimpleOptEnv
emptyEnv dflags
= SOE { soe_dflags = dflags
, soe_inl = emptyVarEnv
, soe_subst = emptySubst }
soeZapSubst :: SimpleOptEnv -> SimpleOptEnv
soeZapSubst (SOE { soe_subst = subst })
= SOE { soe_inl = emptyVarEnv, soe_subst = zapSubstEnv subst }
soeZapSubst env@(SOE { soe_subst = subst })
= env { soe_inl = emptyVarEnv, soe_subst = zapSubstEnv subst }
soeSetInScope :: SimpleOptEnv -> SimpleOptEnv -> SimpleOptEnv
-- Take in-scope set from env1, and the rest from env2
......@@ -209,13 +214,13 @@ simple_opt_expr env expr
go (App e1 e2) = simple_app env e1 [(env,e2)]
go (Type ty) = Type (substTy subst ty)
go (Coercion co) = Coercion (optCoercion (getTCvSubst subst) co)
go (Coercion co) = Coercion (optCoercion (soe_dflags env) (getTCvSubst subst) co)
go (Lit lit) = Lit lit
go (Tick tickish e) = mkTick (substTickish subst tickish) (go e)
go (Cast e co) | isReflCo co' = go e
| otherwise = Cast (go e) co'
where
co' = optCoercion (getTCvSubst subst) co
co' = optCoercion (soe_dflags env) (getTCvSubst subst) co
go (Let bind body) = case simple_opt_bind env bind of
(env', Nothing) -> simple_opt_expr env' body
......@@ -350,7 +355,7 @@ simple_bind_pair env@(SOE { soe_inl = inl_env, soe_subst = subst })
(env { soe_subst = extendTvSubst subst in_bndr out_ty }, Nothing)
| Coercion co <- in_rhs
, let out_co = optCoercion (getTCvSubst (soe_subst rhs_env)) co
, let out_co = optCoercion (soe_dflags env) (getTCvSubst (soe_subst rhs_env)) co
= ASSERT( isCoVar in_bndr )
(env { soe_subst = extendCvSubst subst in_bndr out_co }, Nothing)
......@@ -493,8 +498,8 @@ subst_opt_id_bndr :: SimpleOptEnv -> InId -> (SimpleOptEnv, OutId)
-- It's important to zap fragile OccInfo (which CoreSubst.substIdBndr
-- carefully does not do) because simplOptExpr invalidates it
subst_opt_id_bndr (SOE { soe_subst = subst, soe_inl = inl }) old_id
= (SOE { soe_subst = new_subst, soe_inl = new_inl }, new_id)
subst_opt_id_bndr env@(SOE { soe_subst = subst, soe_inl = inl }) old_id
= (env { soe_subst = new_subst, soe_inl = new_inl }, new_id)
where
Subst in_scope id_subst tv_subst cv_subst = subst
......@@ -902,7 +907,7 @@ exprIsLambda_maybe (in_scope_set, id_unf) e
-- Make sure there is hope to get a lambda
, Just rhs <- expandUnfolding_maybe (id_unf f)
-- Optimize, for beta-reduction
, let e' = simpleOptExprWith (mkEmptySubst in_scope_set) (rhs `mkApps` as)
, let e' = simpleOptExprWith unsafeGlobalDynFlags (mkEmptySubst in_scope_set) (rhs `mkApps` as)
-- Recurse, because of possible casts
, Just (x', e'', ts') <- exprIsLambda_maybe (in_scope_set, id_unf) e'
, let res = Just (x', e'', ts++ts')
......
......@@ -85,7 +85,7 @@ mkTopUnfolding dflags is_bottoming rhs
mkImplicitUnfolding :: DynFlags -> CoreExpr -> Unfolding
-- For implicit Ids, do a tiny bit of optimising first
mkImplicitUnfolding dflags expr
= mkTopUnfolding dflags False (simpleOptExpr expr)
= mkTopUnfolding dflags False (simpleOptExpr dflags expr)
-- Note [Top-level flag on inline rules]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......@@ -107,14 +107,14 @@ mkDFunUnfolding bndrs con ops
mkWwInlineRule :: CoreExpr -> Arity -> Unfolding
mkWwInlineRule expr arity
= mkCoreUnfolding InlineStable True
(simpleOptExpr expr)
(simpleOptExpr unsafeGlobalDynFlags expr)
(UnfWhen { ug_arity = arity, ug_unsat_ok = unSaturatedOk
, ug_boring_ok = boringCxtNotOk })
mkCompulsoryUnfolding :: CoreExpr -> Unfolding
mkCompulsoryUnfolding expr -- Used for things that absolutely must be unfolded
= mkCoreUnfolding InlineCompulsory True
(simpleOptExpr expr)
(simpleOptExpr unsafeGlobalDynFlags expr)
(UnfWhen { ug_arity = 0 -- Arity of unfolding doesn't matter
, ug_unsat_ok = unSaturatedOk, ug_boring_ok = boringCxtOk })
......@@ -126,7 +126,7 @@ mkWorkerUnfolding dflags work_fn
| isStableSource src
= mkCoreUnfolding src top_lvl new_tmpl guidance
where
new_tmpl = simpleOptExpr (work_fn tmpl)
new_tmpl = simpleOptExpr dflags (work_fn tmpl)
guidance = calcUnfoldingGuidance dflags False new_tmpl
mkWorkerUnfolding _ _ _ = noUnfolding
......@@ -141,7 +141,7 @@ mkInlineUnfolding expr
True -- Note [Top-level flag on inline rules]
expr' guide
where
expr' = simpleOptExpr expr
expr' = simpleOptExpr unsafeGlobalDynFlags expr
guide = UnfWhen { ug_arity = manifestArity expr'
, ug_unsat_ok = unSaturatedOk
, ug_boring_ok = boring_ok }
......@@ -155,7 +155,7 @@ mkInlineUnfoldingWithArity arity expr
True -- Note [Top-level flag on inline rules]
expr' guide
where
expr' = simpleOptExpr expr
expr' = simpleOptExpr unsafeGlobalDynFlags expr
guide = UnfWhen { ug_arity = arity
, ug_unsat_ok = needSaturated
, ug_boring_ok = boring_ok }
......@@ -165,14 +165,15 @@ mkInlinableUnfolding :: DynFlags -> CoreExpr -> Unfolding
mkInlinableUnfolding dflags expr
= mkUnfolding dflags InlineStable False False expr'
where
expr' = simpleOptExpr expr
expr' = simpleOptExpr dflags expr
specUnfolding :: [Var] -> (CoreExpr -> CoreExpr) -> Arity -> Unfolding -> Unfolding
specUnfolding :: DynFlags -> [Var] -> (CoreExpr -> CoreExpr) -> Arity
-> Unfolding -> Unfolding
-- See Note [Specialising unfoldings]
-- specUnfolding spec_bndrs spec_app arity_decrease unf
-- = \spec_bndrs. spec_app( unf )
--
specUnfolding spec_bndrs spec_app arity_decrease
specUnfolding dflags spec_bndrs spec_app arity_decrease
df@(DFunUnfolding { df_bndrs = old_bndrs, df_con = con, df_args = args })
= ASSERT2( arity_decrease == count isId old_bndrs - count isId spec_bndrs, ppr df )
mkDFunUnfolding spec_bndrs con (map spec_arg args)
......@@ -184,11 +185,11 @@ specUnfolding spec_bndrs spec_app arity_decrease
-- \new_bndrs. MkD (spec_app(\old_bndrs. <op1>)) ... ditto <opn>
-- The ASSERT checks the value part of that
where
spec_arg arg = simpleOptExpr (spec_app (mkLams old_bndrs arg))
spec_arg arg = simpleOptExpr dflags (spec_app (mkLams old_bndrs arg))
-- The beta-redexes created by spec_app will be
-- simplified away by simplOptExpr
specUnfolding spec_bndrs spec_app arity_decrease
specUnfolding dflags spec_bndrs spec_app arity_decrease
(CoreUnfolding { uf_src = src, uf_tmpl = tmpl
, uf_is_top = top_lvl
, uf_guidance = old_guidance })
......@@ -199,13 +200,13 @@ specUnfolding spec_bndrs spec_app arity_decrease
= let guidance = UnfWhen { ug_arity = old_arity - arity_decrease
, ug_unsat_ok = unsat_ok
, ug_boring_ok = boring_ok }
new_tmpl = simpleOptExpr (mkLams spec_bndrs (spec_app tmpl))
new_tmpl = simpleOptExpr dflags (mkLams spec_bndrs (spec_app tmpl))
-- The beta-redexes created by spec_app will be
-- simplified away by simplOptExpr
in mkCoreUnfolding src top_lvl new_tmpl guidance
specUnfolding _ _ _ _ = noUnfolding
specUnfolding _ _ _ _ _ = noUnfolding
{- Note [Specialising unfoldings]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......
......@@ -397,18 +397,18 @@ dsRule (L loc (HsRule _ name rule_act vars lhs rhs))
Left msg -> do { warnDs NoReason msg; return Nothing } ;
Right (final_bndrs, fn_id, args) -> do
{ let is_local = isLocalId fn_id
{ dflags <- getDynFlags
; let is_local = isLocalId fn_id
-- NB: isLocalId is False of implicit Ids. This is good because
-- we don't want to attach rules to the bindings of implicit Ids,
-- because they don't show up in the bindings until just before code gen
fn_name = idName fn_id
final_rhs = simpleOptExpr rhs'' -- De-crap it
final_rhs = simpleOptExpr dflags rhs'' -- De-crap it
rule_name = snd (unLoc name)
final_bndrs_set = mkVarSet final_bndrs
arg_ids = filterOut (`elemVarSet` final_bndrs_set) $
exprsSomeFreeVarsList isId args
; dflags <- getDynFlags
; rule <- dsMkUserRule this_mod is_local
rule_name rule_act fn_name final_bndrs args
final_rhs
......
......@@ -689,7 +689,7 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
{ dflags <- getDynFlags
; this_mod <- getModule
; let fn_unf = realIdUnfolding poly_id
spec_unf = specUnfolding spec_bndrs core_app arity_decrease fn_unf
spec_unf = specUnfolding dflags spec_bndrs core_app arity_decrease fn_unf
spec_id = mkLocalId spec_name spec_ty
`setInlinePragma` inl_prag
`setIdUnfolding` spec_unf
......@@ -849,7 +849,7 @@ decomposeRuleLhs orig_bndrs orig_lhs
= Left bad_shape_msg
where
lhs1 = drop_dicts orig_lhs
lhs2 = simpleOptExpr lhs1 -- See Note [Simplify rule LHS]
lhs2 = simpleOptExpr unsafeGlobalDynFlags lhs1 -- See Note [Simplify rule LHS]
(fun2,args2) = collectArgs lhs2
lhs_fvs = exprFreeVars lhs2
......
......@@ -1015,8 +1015,9 @@ simplCoercionF env co cont
simplCoercion :: SimplEnv -> InCoercion -> SimplM OutCoercion
simplCoercion env co
= let opt_co = optCoercion (getTCvSubst env) co
in seqCo opt_co `seq` return opt_co
= do { dflags <- getDynFlags
; let opt_co = optCoercion dflags (getTCvSubst env) co
; seqCo opt_co `seq` return opt_co }
-----------------------------------
-- | Push a TickIt context outwards past applications and cases, as
......
......@@ -1346,7 +1346,7 @@ specCalls mb_mod env existing_rules calls_for_me fn rhs
= (inl_prag { inl_inline = NoUserInline }, noUnfolding)
| otherwise
= (inl_prag, specUnfolding poly_tyvars spec_app
= (inl_prag, specUnfolding dflags poly_tyvars spec_app
arity_decrease fn_unf)
arity_decrease = length spec_dict_args
......
......@@ -83,11 +83,15 @@ an ambient substitution, which is why a LiftingContext stores a TCvSubst.
-}
optCoercion :: TCvSubst -> Coercion -> NormalCo
optCoercion :: DynFlags -> TCvSubst -> Coercion -> NormalCo
-- ^ optCoercion applies a substitution to a coercion,
-- *and* optimises it to reduce its size
optCoercion env co
| hasNoOptCoercion unsafeGlobalDynFlags = substCo env co
optCoercion dflags env co
| hasNoOptCoercion dflags = substCo env co
| otherwise = optCoercion' env co
optCoercion' :: TCvSubst -> Coercion -> NormalCo
optCoercion' env co
| debugIsOn
= let out_co = opt_co1 lc False co
(Pair in_ty1 in_ty2, in_role) = coercionKindRole co
......@@ -350,7 +354,7 @@ opt_co4 env sym rep r (CoherenceCo co1 co2)
| TransCo col1' cor1' <- co1'
= if sym then opt_trans in_scope col1'
(optCoercion (zapTCvSubst (lcTCvSubst env))
(optCoercion' (zapTCvSubst (lcTCvSubst env))
(mkCoherenceRightCo cor1' co2'))
else opt_trans in_scope (mkCoherenceCo col1' co2') cor1'
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment