- return final_binds
- where
- --------------
- do_core_pass info@(binds, us, simpl_stats) to_do =
- case (splitUniqSupply us) of
- (us1,us2) ->
- 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 us2 p 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 us2 binds2 simpl_stats "FBWW" }
-
- CoreDoFoldrBuildWWAnal
- -> _scc_ "CoreDoFoldrBuildWWAnal"
- begin_pass "AnalFBWW" >>
- case (analFBWW binds) of { binds2 ->
- end_pass us2 binds2 simpl_stats "AnalFBWW" }
-
- CoreLiberateCase
- -> _scc_ "LiberateCase"
- begin_pass "LiberateCase" >>
- case (liberateCase opt_LiberateCaseThreshold binds) of { binds2 ->
- end_pass us2 binds2 simpl_stats "LiberateCase" }
-
- CoreDoFloatInwards
- -> _scc_ "FloatInwards"
- begin_pass "FloatIn" >>
- case (floatInwards binds) of { binds2 ->
- end_pass us2 binds2 simpl_stats "FloatIn" }
-
- CoreDoFullLaziness
- -> _scc_ "CoreFloating"
- begin_pass "FloatOut" >>
- case (floatOutwards us1 binds) of { binds2 ->
- end_pass us2 binds2 simpl_stats "FloatOut" }
-
- CoreDoStaticArgs
- -> _scc_ "CoreStaticArgs"
- begin_pass "StaticArgs" >>
- case (doStaticArgs binds us1) of { binds2 ->
- end_pass us2 binds2 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 us2 binds2 simpl_stats "StrAnal" }
-
- CoreDoSpecialising
- -> _scc_ "Specialise"
- begin_pass "Specialise" >>
- case (specProgram us1 binds) of { p ->
- end_pass us2 p simpl_stats "Specialise"
- }
-
- CoreDoPrintCore -- print result of last pass
- -> dumpIfSet (not opt_D_verbose_core2core) "Print Core"
- (pprCoreBindings binds) >>
- return (binds, us1, simpl_stats)
-
- -------------------------------------------------
-
- begin_pass what
- = if opt_D_show_passes
- then hPutStr stderr ("*** Core2Core: "++what++"\n")
- else return ()
-
- end_pass us2 binds2
- simpl_stats2 what
- = -- Report verbosely, if required
- dumpIfSet opt_D_verbose_core2core what
- (pprCoreBindings binds2) >>
-
- lintCoreBindings what True {- spec_done -} binds2 >>
- -- The spec_done flag tells the linter to
- -- complain about unboxed let-bindings
- -- But we're not specialising unboxed types any more,
- -- so its irrelevant.
-
- return
- (binds2, -- processed binds, possibly run thru CoreLint
- us2, -- UniqSupply for the next guy
- simpl_stats2 -- accumulated simplifier stats
- )
-
-
--- here so it can be inlined...
-foldl_mn f z [] = return z
-foldl_mn f z (x:xs) = f z x >>= \ zz ->
- foldl_mn f zz xs
+ return (post_simpl_binds, filter orphanRule better_rules)
+
+
+doCorePasses stats us binds irs []
+ = return (stats, binds)
+
+doCorePasses stats us binds irs (to_do : to_dos)
+ = do
+ let (us1, us2) = splitUniqSupply us
+ (stats1, binds1) <- doCorePass us1 binds irs to_do
+ doCorePasses (stats `plusSimplCount` stats1) us2 binds1 irs to_dos
+
+doCorePass us binds rb (CoreDoSimplify sw_chkr) = _scc_ "Simplify" simplifyPgm rb sw_chkr us binds
+doCorePass us binds rb CoreCSE = _scc_ "CommonSubExpr" noStats (cseProgram binds)
+doCorePass us binds rb CoreLiberateCase = _scc_ "LiberateCase" noStats (liberateCase binds)
+doCorePass us binds rb CoreDoFloatInwards = _scc_ "FloatInwards" noStats (floatInwards binds)
+doCorePass us binds rb CoreDoFullLaziness = _scc_ "FloatOutwards" noStats (floatOutwards us binds)
+doCorePass us binds rb CoreDoStaticArgs = _scc_ "StaticArgs" noStats (doStaticArgs us binds)
+doCorePass us binds rb CoreDoStrictness = _scc_ "Stranal" noStats (saBinds binds)
+doCorePass us binds rb CoreDoWorkerWrapper = _scc_ "WorkWrap" noStats (wwTopBinds us binds)
+doCorePass us binds rb CoreDoSpecialising = _scc_ "Specialise" noStats (specProgram us binds)
+doCorePass us binds rb CoreDoCPResult = _scc_ "CPResult" noStats (cprAnalyse binds)
+doCorePass us binds rb CoreDoPrintCore = _scc_ "PrintCore" noStats (printCore binds)
+doCorePass us binds rb CoreDoUSPInf
+ = _scc_ "CoreUsageSPInf"
+ if opt_UsageSPOn then
+ noStats (doUsageSPInf us binds)
+ else
+ trace "WARNING: ignoring requested -fusagesp pass; requires -fusagesp-on" $
+ noStats (return binds)
+
+printCore binds = do dumpIfSet True "Print Core"
+ (pprCoreBindings binds)
+ return binds
+
+noStats thing = do { result <- thing; return (zeroSimplCount, result) }