import CoreTidy
import CoreMonad
import CoreUtils
+import Rules
import CoreArity ( exprArity, exprBotStrictness_maybe )
import Class ( classSelIds )
import VarEnv
import Module
import HscTypes
import Maybes
-import ErrUtils
import UniqSupply
import Outputable
import FastBool hiding ( fastOr )
import Util
+import FastString
import Data.List ( sortBy )
import Data.IORef ( IORef, readIORef, writeIORef )
-> [Instance] -> [FamInstEnv.FamInst] -> IO ModDetails
mkBootModDetails hsc_env exports type_env insts fam_insts
= do { let dflags = hsc_dflags hsc_env
- ; showPass dflags "Tidy [hoot] type env"
+ ; showPass dflags CoreTidy
; let { insts' = tidyInstances globaliseAndTidyId insts
; dfun_ids = map instanceDFunId insts'
; expose_all = dopt Opt_ExposeAllUnfoldings dflags
; th = dopt Opt_TemplateHaskell dflags
}
- ; showPass dflags "Tidy Core"
+ ; showPass dflags CoreTidy
; let { implicit_binds = getImplicitBinds type_env }
; alg_tycons = filter isAlgTyCon (typeEnvTyCons type_env)
}
- ; endPass dflags "Tidy Core" Opt_D_dump_simpl all_tidy_binds tidy_rules
+ ; endPass dflags CoreTidy all_tidy_binds tidy_rules
+
+ -- If the endPass didn't print the rules, but ddump-rules is on, print now
+ ; dumpIfSet (dopt Opt_D_dump_rules dflags
+ && (not (dopt Opt_D_dump_simpl dflags)))
+ CoreTidy
+ (ptext (sLit "rules"))
+ (pprRulesForUser tidy_rules)
+
; let dir_imp_mods = moduleEnvKeys dir_imps
; return (CgGuts { cg_module = mod,
mb_unfold_ids :: Maybe (IdSet, [Id]) -- Nothing => don't unfold
mb_unfold_ids = case unfoldingInfo idinfo of
CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src, uf_guidance = guide }
- | show_unfolding src guide
- -> Just (exprFvsInOrder unf_rhs)
- DFunUnfolding _ ops -> Just (exprsFvsInOrder ops)
- _ -> Nothing
+ | show_unfolding src guide
+ -> Just (unf_ext_ids src unf_rhs)
+ DFunUnfolding _ _ ops -> Just (exprsFvsInOrder ops)
+ _ -> Nothing
+ where
+ unf_ext_ids (InlineWrapper v) _ = (unitVarSet v, [v])
+ unf_ext_ids _ unf_rhs = exprFvsInOrder unf_rhs
+ -- For a wrapper, externalise the wrapper id rather than the
+ -- fvs of the rhs. The two usually come down to the same thing
+ -- but I've seen cases where we had a wrapper id $w but a
+ -- rhs where $w had been inlined; see Trac #3922
show_unfolding unf_source unf_guidance
= expose_all -- 'expose_all' says to expose all
------------ Unfolding --------------
tidyUnfolding :: TidyEnv -> CoreExpr -> Maybe StrictSig -> Unfolding -> Unfolding
-tidyUnfolding tidy_env _ _ (DFunUnfolding con ids)
- = DFunUnfolding con (map (tidyExpr tidy_env) ids)
+tidyUnfolding tidy_env _ _ (DFunUnfolding ar con ids)
+ = DFunUnfolding ar con (map (tidyExpr tidy_env) ids)
tidyUnfolding tidy_env tidy_rhs strict_sig
unf@(CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src })
| isInlineRuleSource src