- beginPass "Tidy Core"
- let (_, binds_out) = mapAccumL (tidyBind (Just mod)) init_tidy_env binds_in
- endPass "Tidy Core" (opt_D_dump_simpl || opt_D_verbose_core2core) binds_out
- where
- -- Make sure to avoid the names of class operations
- -- They don't have top-level bindings, so we won't see them
- -- in binds_in; so we must initialise the tidy_env appropriately
- --
- -- We also make sure to avoid any exported binders. Consider
- -- f{-u1-} = 1 -- Local decl
- -- ...
- -- f{-u2-} = 2 -- Exported decl
- --
- -- The second exported decl must 'get' the name 'f', so we
- -- have to put 'f' in the avoids list before we get to the first
- -- decl. Name.tidyName then does a no-op on exported binders.
- init_tidy_env = (initTidyOccEnv avoids, emptyVarEnv)
- avoids = [getOccName sel_id | cls <- local_classes,
- sel_id <- classSelIds cls]
- ++
- [getOccName bndr | bind <- binds_in,
- bndr <- bindersOf bind,
- isExported bndr]
-
-tidyBind :: Maybe Module -- (Just m) for top level, Nothing for nested
- -> TidyEnv
- -> CoreBind
- -> (TidyEnv, CoreBind)
-tidyBind maybe_mod env (NonRec bndr rhs)
- = let
- (env', bndr') = tidyBndr maybe_mod env bndr
- rhs' = tidyExpr env rhs
- in
- (env', NonRec bndr' rhs')
-
-tidyBind maybe_mod env (Rec pairs)
- = let
- -- We use env' when tidying the rhss
- -- When tidying the binder itself we may tidy it's
- -- specialisations; if any of these mention other binders
- -- in the group we should really feed env' to them too;
- -- but that seems (a) unlikely and (b) a bit tiresome.
- -- So I left it out for now
-
- (bndrs, rhss) = unzip pairs
- (env', bndrs') = mapAccumL (tidyBndr maybe_mod) env bndrs
- rhss' = map (tidyExpr env') rhss
- in
- (env', Rec (zip bndrs' rhss'))
-
-tidyExpr env (Type ty) = Type (tidyType env ty)
-tidyExpr env (Con con args) = Con con (map (tidyExpr env) args)
-tidyExpr env (App f a) = App (tidyExpr env f) (tidyExpr env a)
-tidyExpr env (Note n e) = Note (tidyNote env n) (tidyExpr env e)
-
-tidyExpr env (Let b e) = Let b' (tidyExpr env' e)
- where
- (env', b') = tidyBind Nothing env b
-
-tidyExpr env (Case e b alts) = Case (tidyExpr env e) b' (map (tidyAlt env') alts)
- where
- (env', b') = tidyNestedBndr env b
-
-tidyExpr env (Var v) = case lookupVarEnv var_env v of
- Just v' -> Var v'
- Nothing -> Var v
- where
- (_, var_env) = env
-
-tidyExpr env (Lam b e) = Lam b' (tidyExpr env' e)
- where
- (env', b') = tidyNestedBndr env b
-
-tidyAlt env (con, vs, rhs) = (con, vs', tidyExpr env' rhs)
- where
- (env', vs') = mapAccumL tidyNestedBndr env vs
-
-tidyNote env (Coerce t1 t2) = Coerce (tidyType env t1) (tidyType env t2)
-\end{code}
+ 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
+#endif
+
+printCore binds = do dumpIfSet True "Print Core"
+ (pprCoreBindings binds)
+ return binds
+
+ruleCheck dflags phase pat binds = do showPass dflags "RuleCheck"
+ printDump (ruleCheckProgram phase pat binds)
+ return binds
+
+-- most passes return no stats and don't change rules
+noStats dfs thing = do { binds <- thing; return (zeroSimplCount dfs, binds) }