- init_specdata = initSpecData local_tycons tycon_specs
-
- switch_is_on = switchIsOn sw_chkr
-
- do_verbose_core2core = switch_is_on D_verbose_core2core
-
- lib_case_threshold -- ToDo: HACK HACK HACK : FIX ME FIX ME FIX ME
- -- Use 4x a known threshold
- = case (intSwitchSet sw_chkr UnfoldingOverrideThreshold) of
- Nothing -> 4 * uNFOLDING_USE_THRESHOLD
- Just xx -> 4 * xx
-
- -------------
- core_linter = if switch_is_on 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
- -> BSCC("CoreSimplify")
- begin_pass ("Simplify" ++ if switchIsOn simpl_sw_chkr SimplDoFoldrBuild
- then " (foldr/build)" else "") `thenMn_`
- case (simplifyPgm binds sw_chkr 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 "")
- ESCC
-
- CoreDoFoldrBuildWorkerWrapper
- -> BSCC("CoreDoFoldrBuildWorkerWrapper")
- begin_pass "FBWW" `thenMn_`
- case (mkFoldrBuildWW switch_is_on us1 binds) of { binds2 ->
- end_pass False us2 binds2 inline_env spec_data simpl_stats "FBWW"
- } ESCC
-
- CoreDoFoldrBuildWWAnal
- -> BSCC("CoreDoFoldrBuildWWAnal")
- begin_pass "AnalFBWW" `thenMn_`
- case (analFBWW switch_is_on binds) of { binds2 ->
- end_pass False us2 binds2 inline_env spec_data simpl_stats "AnalFBWW"
- } ESCC
-
- CoreLiberateCase
- -> BSCC("LiberateCase")
- begin_pass "LiberateCase" `thenMn_`
- case (liberateCase lib_case_threshold binds) of { binds2 ->
- end_pass False us2 binds2 inline_env spec_data simpl_stats "LiberateCase"
- } ESCC
-
- CoreDoCalcInlinings1 -- avoid inlinings w/ cost-centres
- -> BSCC("CoreInlinings1")
- begin_pass "CalcInlinings" `thenMn_`
- case (calcInlinings False sw_chkr inline_env binds) of { inline_env2 ->
- end_pass False us2 binds inline_env2 spec_data simpl_stats "CalcInlinings"
- } ESCC
-
- CoreDoCalcInlinings2 -- allow inlinings w/ cost-centres
- -> BSCC("CoreInlinings2")
- begin_pass "CalcInlinings" `thenMn_`
- case (calcInlinings True sw_chkr inline_env binds) of { inline_env2 ->
- end_pass False us2 binds inline_env2 spec_data simpl_stats "CalcInlinings"
- } ESCC
-
- CoreDoFloatInwards
- -> BSCC("FloatInwards")
- begin_pass "FloatIn" `thenMn_`
- case (floatInwards binds) of { binds2 ->
- end_pass False us2 binds2 inline_env spec_data simpl_stats "FloatIn"
- } ESCC
-
- CoreDoFullLaziness
- -> BSCC("CoreFloating")
- begin_pass "FloatOut" `thenMn_`
- case (floatOutwards switch_is_on us1 binds) of { binds2 ->
- end_pass False us2 binds2 inline_env spec_data simpl_stats "FloatOut"
- } ESCC
-
- CoreDoStaticArgs
- -> BSCC("CoreStaticArgs")
- begin_pass "StaticArgs" `thenMn_`
- 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])
- } ESCC
-
- CoreDoStrictness
- -> BSCC("CoreStranal")
- begin_pass "StrAnal" `thenMn_`
- case (saWwTopBinds us1 switch_is_on binds) of { binds2 ->
- end_pass False us2 binds2 inline_env spec_data simpl_stats "StrAnal"
- } ESCC
-
- CoreDoSpecialising
- -> BSCC("Specialise")
- begin_pass "Specialise" `thenMn_`
- case (specProgram switch_is_on 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 ||
- (switch_is_on ShowImportSpecs && not (isEmptyBag spec_warn)) then
- writeMn stderr (ppShow 1000 {-pprCols-}
- (pprSpecErrs module_name spec_errs spec_warn spec_tyerrs))
- `thenMn_` writeMn stderr "\n"
- else
- returnMn ()) `thenMn_`
-
- (if not spec_noerrs then -- Stop here if specialisation errors occured
- exitMn 1
- else
- returnMn ()) `thenMn_`
-
- end_pass False us2 p inline_env spec_data2 simpl_stats "Specialise"
- }
- ESCC
-
- CoreDoDeforest
-#if OMIT_DEFORESTER
- -> error "ERROR: CoreDoDeforest: not built into compiler\n"
-#else
- -> BSCC("Deforestation")
- begin_pass "Deforestation" `thenMn_`
- case (deforestProgram sw_chkr binds us1) of { binds2 ->
- end_pass False us2 binds2 inline_env spec_data simpl_stats "Deforestation"
- }
- ESCC
-#endif
-
- CoreDoAutoCostCentres
- -> BSCC("AutoSCCs")
- begin_pass "AutoSCCs" `thenMn_`
- case (addAutoCostCentres sw_chkr module_name binds) of { binds2 ->
- end_pass False us2 binds2 inline_env spec_data simpl_stats "AutoSCCs"
- }
- ESCC
-
- CoreDoPrintCore -- print result of last pass
- -> end_pass True us2 binds inline_env spec_data simpl_stats "Print"
-
-
- -------------------------------------------------
-
- begin_pass
- = if switch_is_on D_show_passes
- then \ what -> writeMn stderr ("*** Core2Core: "++what++"\n")
- else \ what -> returnMn ()
-
- end_pass print us2 binds2 inline_env2
- spec_data2@(SpecData spec_done _ _ _ _ _ _ _)
- simpl_stats2 what
- = -- report verbosely, if required
- (if (do_verbose_core2core && not print) ||
- (print && not do_verbose_core2core)
- then
- writeMn stderr ("\n*** "++what++":\n")
- `thenMn_`
- writeMn stderr (ppShow 1000
- (ppAboves (map (pprPlainCoreBinding ppr_style) binds2)))
- `thenMn_`
- writeMn stderr "\n"
- else
- returnMn ()) `thenMn_`
- let
- linted_binds = core_linter what spec_done binds2
- in
- returnMn
- (linted_binds, -- processed binds, possibly run thru CoreLint
- us2, -- UniqueSupply for the next guy
- inline_env2, -- possibly-updated inline env
- spec_data2, -- possibly-updated specialisation info
- simpl_stats2 -- accumulated simplifier stats
- )
-
--- here so it can be inlined...
-foldl_mn f z [] = returnMn z
-foldl_mn f z (x:xs) = f z x `thenMn` \ zz ->
- foldl_mn f zz xs
+ sw_chkr any = SwBool False -- A bit bogus
+ black_list_all v = True -- Black list everything
+
+
+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 sw_chkr)
+ = _scc_ "Simplify" simplifyPgm dfs rb sw_chkr 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 (saBinds 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 CoreDoCPResult
+ = _scc_ "CPResult" noStats dfs (cprAnalyse dfs binds)
+doCorePass dfs rb us binds CoreDoPrintCore
+ = _scc_ "PrintCore" noStats dfs (printCore binds)
+doCorePass dfs rb us binds CoreDoUSPInf
+ = _scc_ "CoreUsageSPInf" noStats dfs (doUsageSPInf dfs us binds)
+doCorePass dfs rb us binds CoreDoGlomBinds
+ = noStats dfs (glomBinds dfs binds)
+doCorePass dfs rb us binds CoreDoNothing
+ = noStats dfs (return binds)
+
+printCore binds = do dumpIfSet True "Print Core"
+ (pprCoreBindings binds)
+ return binds
+
+-- most passes return no stats and don't change rules
+noStats dfs thing = do { binds <- thing; return (zeroSimplCount dfs, binds) }