-core2core :: [CoreToDo] -- spec of what core-to-core passes to do
- -> FAST_STRING -- module name (profiling only)
- -> PprStyle -- printing style (for debugging only)
- -> UniqSupply -- a name supply
- -> [TyCon] -- local data tycons and tycon specialisations
- -> FiniteMap TyCon [(Bool, [Maybe Type])]
- -> [CoreBinding] -- input...
- -> IO
- ([CoreBinding], -- results: program, plus...
- IdEnv UnfoldingDetails, -- unfoldings to be exported from here
- SpecialiseData) -- specialisation data
-
-core2core core_todos module_name ppr_style us local_tycons tycon_specs binds
- = if null core_todos then -- very rare, I suspect...
- -- well, we still must do some renumbering
- return (
- (substCoreBindings nullIdEnv nullTyVarEnv binds us,
- nullIdEnv,
- init_specdata)
- )
- else
- (if do_verbose_core2core then
- hPutStr stderr "VERBOSE CORE-TO-CORE:\n"
- else return ()) >>
-
- -- better do the main business
- foldl_mn do_core_pass
- (binds, us, nullIdEnv, init_specdata, zeroSimplCount)
- core_todos
- >>= \ (processed_binds, _, inline_env, spec_data, simpl_stats) ->
-
- (if opt_D_simplifier_stats
- then hPutStr stderr ("\nSimplifier Stats:\n")
- >>
- hPutStr stderr (showSimplCount simpl_stats)
- >>
- hPutStr stderr "\n"
- else return ()
- ) >>
-
- return (processed_binds, inline_env, spec_data)
- where
- init_specdata = initSpecData local_tycons tycon_specs
-
- do_verbose_core2core = opt_D_verbose_core2core
-
- lib_case_threshold -- ToDo: HACK HACK HACK : FIX ME FIX ME FIX ME
- -- Use 4x a known threshold
- = case opt_UnfoldingOverrideThreshold of
- Nothing -> 4 * uNFOLDING_USE_THRESHOLD
- Just xx -> 4 * xx
-
- -------------
- core_linter = if opt_DoCoreLinting
- then lintCoreBindings ppr_style
- else ( \ whodunnit spec_done binds -> binds )
-
- --------------
- do_core_pass info@(binds, us, inline_env, spec_data, simpl_stats) to_do
- = let
- (us1, us2) = splitUniqSupply us
- in
- case to_do of
- CoreDoSimplify simpl_sw_chkr
- -> _scc_ "CoreSimplify"
- begin_pass ("Simplify" ++ if switchIsOn simpl_sw_chkr SimplDoFoldrBuild
- then " (foldr/build)" else "") >>
- case (simplifyPgm binds simpl_sw_chkr simpl_stats us1) of
- (p, it_cnt, simpl_stats2)
- -> end_pass False us2 p inline_env spec_data simpl_stats2
- ("Simplify (" ++ show it_cnt ++ ")"
- ++ if switchIsOn simpl_sw_chkr SimplDoFoldrBuild
- then " foldr/build" else "")
-
- CoreDoFoldrBuildWorkerWrapper
- -> _scc_ "CoreDoFoldrBuildWorkerWrapper"
- begin_pass "FBWW" >>
- case (mkFoldrBuildWW us1 binds) of { binds2 ->
- end_pass False us2 binds2 inline_env spec_data simpl_stats "FBWW" }
-
- CoreDoFoldrBuildWWAnal
- -> _scc_ "CoreDoFoldrBuildWWAnal"
- begin_pass "AnalFBWW" >>
- case (analFBWW binds) of { binds2 ->
- end_pass False us2 binds2 inline_env spec_data simpl_stats "AnalFBWW" }
-
- CoreLiberateCase
- -> _scc_ "LiberateCase"
- begin_pass "LiberateCase" >>
- case (liberateCase lib_case_threshold binds) of { binds2 ->
- end_pass False us2 binds2 inline_env spec_data simpl_stats "LiberateCase" }
-
- CoreDoCalcInlinings1 -- avoid inlinings w/ cost-centres
- -> _scc_ "CoreInlinings1"
- begin_pass "CalcInlinings" >>
- case (calcInlinings False inline_env binds) of { inline_env2 ->
- end_pass False us2 binds inline_env2 spec_data simpl_stats "CalcInlinings" }
-
- CoreDoCalcInlinings2 -- allow inlinings w/ cost-centres
- -> _scc_ "CoreInlinings2"
- begin_pass "CalcInlinings" >>
- case (calcInlinings True inline_env binds) of { inline_env2 ->
- end_pass False us2 binds inline_env2 spec_data simpl_stats "CalcInlinings" }
-
- CoreDoFloatInwards
- -> _scc_ "FloatInwards"
- begin_pass "FloatIn" >>
- case (floatInwards binds) of { binds2 ->
- end_pass False us2 binds2 inline_env spec_data simpl_stats "FloatIn" }
-
- CoreDoFullLaziness
- -> _scc_ "CoreFloating"
- begin_pass "FloatOut" >>
- case (floatOutwards us1 binds) of { binds2 ->
- end_pass False us2 binds2 inline_env spec_data simpl_stats "FloatOut" }
-
- CoreDoStaticArgs
- -> _scc_ "CoreStaticArgs"
- begin_pass "StaticArgs" >>
- case (doStaticArgs binds us1) of { binds2 ->
- end_pass False us2 binds2 inline_env spec_data simpl_stats "StaticArgs" }
- -- Binds really should be dependency-analysed for static-
- -- arg transformation... Not to worry, they probably are.
- -- (I don't think it *dies* if they aren't [WDP 94/04/15])
-
- CoreDoStrictness
- -> _scc_ "CoreStranal"
- begin_pass "StrAnal" >>
- case (saWwTopBinds us1 binds) of { binds2 ->
- end_pass False us2 binds2 inline_env spec_data simpl_stats "StrAnal" }
-
- CoreDoSpecialising
- -> _scc_ "Specialise"
- begin_pass "Specialise" >>
- case (specProgram us1 binds spec_data) of {
- (p, spec_data2@(SpecData _ spec_noerrs _ _ _
- spec_errs spec_warn spec_tyerrs)) ->
-
- -- if we got errors, we die straight away
- (if not spec_noerrs ||
- (opt_ShowImportSpecs && not (isEmptyBag spec_warn)) then
- hPutStr stderr (ppShow 1000 {-pprCols-}
- (pprSpecErrs module_name spec_errs spec_warn spec_tyerrs))
- >> hPutStr stderr "\n"
- else
- return ()) >>
-
- (if not spec_noerrs then -- Stop here if specialisation errors occured
- ghcExit 1
- else
- return ()) >>
-
- end_pass False us2 p inline_env spec_data2 simpl_stats "Specialise"
- }
-
- CoreDoDeforest
-#if OMIT_DEFORESTER
- -> error "ERROR: CoreDoDeforest: not built into compiler\n"
-#else
- -> _scc_ "Deforestation"
- begin_pass "Deforestation" >>
- case (deforestProgram binds us1) of { binds2 ->
- end_pass False us2 binds2 inline_env spec_data simpl_stats "Deforestation" }
+core2core :: HscEnv
+ -> PersistentCompilerState
+ -> ModGuts
+ -> IO ModGuts
+
+core2core hsc_env pcs
+ mod_impl@(ModGuts { mg_exports = exports,
+ mg_binds = binds_in,
+ mg_rules = rules_in })
+ = do
+ let dflags = hsc_dflags hsc_env
+ hpt = hsc_HPT hsc_env
+ ghci_mode = hsc_mode hsc_env
+ core_todos = dopt_CoreToDo dflags
+ pkg_rule_base = eps_rule_base (pcs_EPS pcs) -- Rule-base accumulated from imported packages
+
+ us <- mkSplitUniqSupply 's'
+ let (cp_us, ru_us) = splitUniqSupply us
+
+ -- COMPUTE THE RULE BASE TO USE
+ (rule_base, local_rule_ids, orphan_rules, rule_rhs_fvs)
+ <- prepareRules dflags pkg_rule_base hpt ru_us binds_in rules_in
+
+ -- PREPARE THE BINDINGS
+ let binds1 = updateBinders ghci_mode local_rule_ids
+ rule_rhs_fvs exports binds_in
+
+ -- DO THE BUSINESS
+ (stats, processed_binds)
+ <- doCorePasses dflags rule_base (zeroSimplCount dflags) cp_us binds1 core_todos
+
+ dumpIfSet_dyn dflags Opt_D_dump_simpl_stats
+ "Grand total simplifier statistics"
+ (pprSimplCount stats)
+
+ -- Return results
+ -- We only return local orphan rules, i.e., local rules not attached to an Id
+ -- The bindings cotain more rules, embedded in the Ids
+ return (mod_impl { mg_binds = processed_binds, mg_rules = orphan_rules})
+
+
+simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do
+ -> CoreExpr
+ -> IO CoreExpr
+-- simplifyExpr is called by the driver to simplify an
+-- expression typed in at the interactive prompt
+simplifyExpr dflags expr
+ = do {
+ ; showPass dflags "Simplify"
+
+ ; us <- mkSplitUniqSupply 's'
+
+ ; let env = emptySimplEnv SimplGently [] emptyVarSet
+ (expr', _counts) = initSmpl dflags us (simplExprGently env expr)
+
+ ; dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"
+ (pprCoreExpr expr')
+
+ ; return expr'
+ }
+
+
+doCorePasses :: DynFlags
+ -> RuleBase -- the main rule base
+ -> SimplCount -- simplifier stats
+ -> UniqSupply -- uniques
+ -> [CoreBind] -- local binds in (with rules attached)
+ -> [CoreToDo] -- which passes to do
+ -> IO (SimplCount, [CoreBind]) -- stats, binds, local orphan rules
+
+doCorePasses dflags rb stats us binds []
+ = return (stats, binds)
+
+doCorePasses dflags rb stats us binds (to_do : to_dos)
+ = do
+ let (us1, us2) = splitUniqSupply us
+
+ (stats1, binds1) <- doCorePass dflags rb us1 binds to_do
+
+ doCorePasses dflags rb (stats `plusSimplCount` stats1) us2 binds1 to_dos
+
+doCorePass dfs rb us binds (CoreDoSimplify mode switches)
+ = _scc_ "Simplify" simplifyPgm dfs rb mode switches us binds
+doCorePass dfs rb us binds CoreCSE
+ = _scc_ "CommonSubExpr" noStats dfs (cseProgram dfs binds)
+doCorePass dfs rb us binds CoreLiberateCase
+ = _scc_ "LiberateCase" noStats dfs (liberateCase dfs binds)
+doCorePass dfs rb us binds CoreDoFloatInwards
+ = _scc_ "FloatInwards" noStats dfs (floatInwards dfs binds)
+doCorePass dfs rb us binds (CoreDoFloatOutwards f)
+ = _scc_ "FloatOutwards" noStats dfs (floatOutwards dfs f us binds)
+doCorePass dfs rb us binds CoreDoStaticArgs
+ = _scc_ "StaticArgs" noStats dfs (doStaticArgs us binds)
+doCorePass dfs rb us binds CoreDoStrictness
+ = _scc_ "Stranal" noStats dfs (dmdAnalPgm dfs binds)
+doCorePass dfs rb us binds CoreDoWorkerWrapper
+ = _scc_ "WorkWrap" noStats dfs (wwTopBinds dfs us binds)
+doCorePass dfs rb us binds CoreDoSpecialising
+ = _scc_ "Specialise" noStats dfs (specProgram dfs us binds)
+doCorePass dfs rb us binds CoreDoSpecConstr
+ = _scc_ "SpecConstr" noStats dfs (specConstrProgram dfs us binds)
+#ifdef OLD_STRICTNESS
+doCorePass dfs rb us binds CoreDoOldStrictness
+ = _scc_ "OldStrictness" noStats dfs (doOldStrictness dfs binds)
+#endif
+doCorePass dfs rb us binds CoreDoPrintCore
+ = _scc_ "PrintCore" noStats dfs (printCore binds)
+doCorePass dfs rb us binds CoreDoGlomBinds
+ = noStats dfs (glomBinds dfs binds)
+doCorePass dfs rb us binds (CoreDoRuleCheck phase pat)
+ = noStats dfs (ruleCheck dfs phase pat binds)
+doCorePass dfs rb us binds CoreDoNothing
+ = noStats dfs (return binds)
+
+#ifdef OLD_STRICTNESS
+doOldStrictness dfs binds
+ = do binds1 <- saBinds dfs binds
+ binds2 <- cprAnalyse dfs binds1
+ return binds2