diff options
Diffstat (limited to 'compiler/simplCore')
| -rw-r--r-- | compiler/simplCore/OccurAnal.hs | 2 | ||||
| -rw-r--r-- | compiler/simplCore/SetLevels.hs | 2 | ||||
| -rw-r--r-- | compiler/simplCore/SimplCore.hs | 12 | ||||
| -rw-r--r-- | compiler/simplCore/SimplUtils.hs | 66 | ||||
| -rw-r--r-- | compiler/simplCore/Simplify.hs | 18 |
5 files changed, 56 insertions, 44 deletions
diff --git a/compiler/simplCore/OccurAnal.hs b/compiler/simplCore/OccurAnal.hs index 1e086027ba..1e485aee1e 100644 --- a/compiler/simplCore/OccurAnal.hs +++ b/compiler/simplCore/OccurAnal.hs @@ -253,7 +253,7 @@ always in scope. * Note [Rule dependency info] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ - The VarSet in a SpecInfo is used for dependency analysis in the + The VarSet in a RuleInfo is used for dependency analysis in the occurrence analyser. We must track free vars in *both* lhs and rhs. Hence use of idRuleVars, rather than idRuleRhsVars in occAnalBind. Why both? Consider diff --git a/compiler/simplCore/SetLevels.hs b/compiler/simplCore/SetLevels.hs index de02e27c2b..d873cc5e15 100644 --- a/compiler/simplCore/SetLevels.hs +++ b/compiler/simplCore/SetLevels.hs @@ -1015,7 +1015,7 @@ abstractVars dest_lvl (LE { le_subst = subst, le_lvl_env = lvl_env }) in_fvs -- We are going to lambda-abstract, so nuke any IdInfo, -- and add the tyvars of the Id (if necessary) zap v | isId v = WARN( isStableUnfolding (idUnfolding v) || - not (isEmptySpecInfo (idSpecialisation v)), + not (isEmptyRuleInfo (idSpecialisation v)), text "absVarsOf: discarding info on" <+> ppr v ) setIdInfo v vanillaIdInfo | otherwise = v diff --git a/compiler/simplCore/SimplCore.hs b/compiler/simplCore/SimplCore.hs index 90233d608a..dddb24d335 100644 --- a/compiler/simplCore/SimplCore.hs +++ b/compiler/simplCore/SimplCore.hs @@ -15,7 +15,7 @@ import CoreSyn import HscTypes import CSE ( cseProgram ) import Rules ( mkRuleBase, unionRuleBase, - extendRuleBaseList, ruleCheckProgram, addSpecInfo, ) + extendRuleBaseList, ruleCheckProgram, addRuleInfo, ) import PprCore ( pprCoreBindings, pprCoreExpr ) import OccurAnal ( occurAnalysePgm, occurAnalyseExpr ) import IdInfo @@ -871,7 +871,7 @@ shortOutIndirections binds -- These exported Ids are the subjects of the indirection-elimination exp_ids = map fst $ varEnvElts ind_env exp_id_set = mkVarSet exp_ids - no_need_to_flatten = all (null . specInfoRules . idSpecialisation) exp_ids + no_need_to_flatten = all (null . ruleInfoRules . idSpecialisation) exp_ids binds' = concatMap zap binds zap (NonRec bndr rhs) = [NonRec b r | (b,r) <- zapPair (bndr,rhs)] @@ -929,7 +929,7 @@ hasShortableIdInfo :: Id -> Bool -- so we can safely discard it -- See Note [Messing up the exported Id's IdInfo] hasShortableIdInfo id - = isEmptySpecInfo (specInfo info) + = isEmptyRuleInfo (ruleInfo info) && isDefaultInlinePragma (inlinePragInfo info) && not (isStableUnfolding (unfoldingInfo info)) where @@ -951,8 +951,8 @@ transferIdInfo exported_id local_id transfer exp_info = exp_info `setStrictnessInfo` strictnessInfo local_info `setUnfoldingInfo` unfoldingInfo local_info `setInlinePragInfo` inlinePragInfo local_info - `setSpecInfo` addSpecInfo (specInfo exp_info) new_info - new_info = setSpecInfoHead (idName exported_id) - (specInfo local_info) + `setRuleInfo` addRuleInfo (ruleInfo exp_info) new_info + new_info = setRuleInfoHead (idName exported_id) + (ruleInfo local_info) -- Remember to set the function-name field of the -- rules as we transfer them from one function to another diff --git a/compiler/simplCore/SimplUtils.hs b/compiler/simplCore/SimplUtils.hs index effd2121e9..1577efda37 100644 --- a/compiler/simplCore/SimplUtils.hs +++ b/compiler/simplCore/SimplUtils.hs @@ -14,7 +14,7 @@ module SimplUtils ( preInlineUnconditionally, postInlineUnconditionally, activeUnfolding, activeRule, getUnfoldingInRuleMatch, - simplEnvForGHCi, updModeForStableUnfoldings, updModeForRuleLHS, + simplEnvForGHCi, updModeForStableUnfoldings, updModeForRules, -- The continuation type SimplCont(..), DupFlag(..), @@ -701,24 +701,25 @@ updModeForStableUnfoldings inline_rule_act current_mode phaseFromActivation (ActiveAfter n) = Phase n phaseFromActivation _ = InitialPhase -updModeForRuleLHS :: SimplifierMode -> SimplifierMode --- See Note [Simplifying rule LHSs] -updModeForRuleLHS current_mode +updModeForRules :: SimplifierMode -> SimplifierMode +-- See Note [Simplifying rules] +updModeForRules current_mode = current_mode { sm_phase = InitialPhase , sm_inline = False , sm_rules = False , sm_eta_expand = False } -{- Note [Simplifying rule LHSs] +{- Note [Simplifying rules] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When simplifying on the LHS of a rule, refrain from all inlining and -all RULES. Doing anything to the LHS is plain confusing, because it -means that what the rule matches is not what the user wrote. -c.f. Trac #10595, and #10528. +When simplifying a rule, refrain from any inlining or applying of other RULES. +Doing anything to the LHS is plain confusing, because it means that what the +rule matches is not what the user wrote. c.f. Trac #10595, and #10528. Moreover, inlining (or applying rules) on rule LHSs risks introducing Ticks into the LHS, which makes matching trickier. Trac #10665, #10745. +Doing this to either side confounds tools like HERMIT, which seek to reason +about and apply the RULES as originally written. See Trac #10829. Note [Inlining in gentle mode] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1522,6 +1523,30 @@ as we would normally do. That's why the whole transformation is part of the same process that floats let-bindings and constructor arguments out of RHSs. In particular, it is guarded by the doFloatFromRhs call in simplLazyBind. + +Note [Which type variables to abstract over] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Abstract only over the type variables free in the rhs wrt which the +new binding is abstracted. Note that + + * The naive approach of abstracting wrt the + tyvars free in the Id's /type/ fails. Consider: + /\ a b -> let t :: (a,b) = (e1, e2) + x :: a = fst t + in ... + Here, b isn't free in x's type, but we must nevertheless + abstract wrt b as well, because t's type mentions b. + Since t is floated too, we'd end up with the bogus: + poly_t = /\ a b -> (e1, e2) + poly_x = /\ a -> fst (poly_t a *b*) + + * We must do closeOverKinds. Example (Trac #10934): + f = /\k (f:k->*) (a:k). let t = AccFailure @ (f a) in ... + Here we want to float 't', but we must remember to abstract over + 'k' as well, even though it is not explicitly mentioned in the RHS, + otherwise we get + t = /\ (f:k->*) (a:k). AccFailure @ (f a) + which is obviously bogus. -} abstractFloats :: [OutTyVar] -> SimplEnv -> OutExpr -> SimplM ([OutBind], OutExpr) @@ -1542,23 +1567,12 @@ abstractFloats main_tvs body_env body ; return (subst', (NonRec poly_id poly_rhs)) } where rhs' = CoreSubst.substExpr (text "abstract_floats2") subst rhs - tvs_here = varSetElemsKvsFirst (main_tv_set `intersectVarSet` exprSomeFreeVars isTyVar rhs') - - -- Abstract only over the type variables free in the rhs - -- wrt which the new binding is abstracted. But the naive - -- approach of abstract wrt the tyvars free in the Id's type - -- fails. Consider: - -- /\ a b -> let t :: (a,b) = (e1, e2) - -- x :: a = fst t - -- in ... - -- Here, b isn't free in x's type, but we must nevertheless - -- abstract wrt b as well, because t's type mentions b. - -- Since t is floated too, we'd end up with the bogus: - -- poly_t = /\ a b -> (e1, e2) - -- poly_x = /\ a -> fst (poly_t a *b*) - -- So for now we adopt the even more naive approach of - -- abstracting wrt *all* the tyvars. We'll see if that - -- gives rise to problems. SLPJ June 98 + + -- tvs_here: see Note [Which type variables to abstract over] + tvs_here = varSetElemsKvsFirst $ + intersectVarSet main_tv_set $ + closeOverKinds $ + exprSomeFreeVars isTyVar rhs' abstract subst (Rec prs) = do { (poly_ids, poly_apps) <- mapAndUnzipM (mk_poly tvs_here) ids diff --git a/compiler/simplCore/Simplify.hs b/compiler/simplCore/Simplify.hs index 07bc0041a1..2c73f8e119 100644 --- a/compiler/simplCore/Simplify.hs +++ b/compiler/simplCore/Simplify.hs @@ -36,7 +36,7 @@ import CoreUnfold import CoreUtils import CoreArity --import PrimOp ( tagToEnumKey ) -- temporalily commented out. See #8326 -import Rules ( mkSpecInfo, lookupRule, getRules ) +import Rules ( mkRuleInfo, lookupRule, getRules ) import TysPrim ( voidPrimTy ) --, intPrimTy ) -- temporalily commented out. See #8326 import BasicTypes ( TopLevelFlag(..), isTopLevel, RecFlag(..) ) import MonadUtils ( foldlM, mapAccumLM, liftIO ) @@ -2957,10 +2957,10 @@ addBndrRules env in_id out_id = return (env, out_id) | otherwise = do { new_rules <- simplRules env (Just (idName out_id)) old_rules - ; let final_id = out_id `setIdSpecialisation` mkSpecInfo new_rules + ; let final_id = out_id `setIdSpecialisation` mkRuleInfo new_rules ; return (modifyInScope env final_id, final_id) } where - old_rules = specInfoRules (idSpecialisation in_id) + old_rules = ruleInfoRules (idSpecialisation in_id) simplRules :: SimplEnv -> Maybe Name -> [CoreRule] -> SimplM [CoreRule] simplRules env mb_new_nm rules @@ -2970,13 +2970,11 @@ simplRules env mb_new_nm rules = return rule simpl_rule rule@(Rule { ru_bndrs = bndrs, ru_args = args - , ru_fn = fn_name, ru_rhs = rhs - , ru_act = act }) - = do { (env, bndrs') <- simplBinders env bndrs - ; let lhs_env = updMode updModeForRuleLHS env - rhs_env = updMode (updModeForStableUnfoldings act) env - ; args' <- mapM (simplExpr lhs_env) args - ; rhs' <- simplExpr rhs_env rhs + , ru_fn = fn_name, ru_rhs = rhs }) + = do { (env', bndrs') <- simplBinders env bndrs + ; let rule_env = updMode updModeForRules env' + ; args' <- mapM (simplExpr rule_env) args + ; rhs' <- simplExpr rule_env rhs ; return (rule { ru_bndrs = bndrs' , ru_fn = mb_new_nm `orElse` fn_name , ru_args = args' |