- Now that the evaluation order is safe.
-
-4. Do eta reduction for lambda abstractions appearing in:
- - the RHS of case alternatives
- - the body of a let
-
- These will otherwise turn into local bindings during Core->STG;
- better to nuke them if possible. (In general the simplifier does
- eta expansion not eta reduction, up to this point. It does eta
- on the RHSs of bindings but not the RHSs of case alternatives and
- let bodies)
-
-
-------------------- NOT DONE ANY MORE ------------------------
-[March 98] Indirections are now elimianted by the occurrence analyser
-1. Eliminate indirections. The point here is to transform
- x_local = E
- x_exported = x_local
- ==>
- x_exported = E
-
-[Dec 98] [Not now done because there is no penalty in the code
- generator for using the former form]
-2. Convert
- case x of {...; x' -> ...x'...}
- ==>
- case x of {...; _ -> ...x... }
- See notes in SimplCase.lhs, near simplDefault for the reasoning here.
---------------------------------------------------------------
-
-Special case
-~~~~~~~~~~~~
-
-NOT ENABLED AT THE MOMENT (because the floated Ids are global-ish
-things, and we need local Ids for non-floated stuff):
-
- Don't float stuff out of a binder that's marked as a bottoming Id.
- Reason: it doesn't do any good, and creates more CAFs that increase
- the size of SRTs.
-
-eg.
-
- f = error "string"
-
-is translated to
-
- f' = unpackCString# "string"
- f = error f'
-
-hence f' and f become CAFs. Instead, the special case for
-tidyTopBinding below makes sure this comes out as
-
- f = let f' = unpackCString# "string" in error f'
+\begin{code}
+prepareRules :: DynFlags -> PackageRuleBase -> HomeSymbolTable
+ -> UniqSupply
+ -> [CoreBind]
+ -> [IdCoreRule] -- Local rules
+ -> IO (RuleBase, -- Full rule base
+ (IdSet,IdSet), -- Local rule Ids, and RHS fvs
+ [IdCoreRule]) -- Orphan rules
+
+prepareRules dflags pkg_rule_base hst us binds rules
+ = do { let (better_rules,_) = initSmpl dflags sw_chkr us local_ids black_list_all
+ (mapSmpl simplRule rules)
+
+ ; dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules"
+ (vcat (map pprIdCoreRule better_rules))
+
+ ; let (local_rules, orphan_rules) = partition (isLocalId . fst) better_rules
+ local_rule_rhs_fvs = unionVarSets (map (ruleRhsFreeVars . snd) local_rules)
+ local_rule_base = extendRuleBaseList emptyRuleBase local_rules
+ local_rule_ids = ruleBaseIds local_rule_base -- Local Ids with rules attached
+ imp_rule_base = foldl add_rules pkg_rule_base (moduleEnvElts hst)
+ rule_base = extendRuleBaseList imp_rule_base orphan_rules
+ final_rule_base = addRuleBaseFVs rule_base (ruleBaseFVs local_rule_base)
+ -- The last step black-lists the free vars of local rules too
+
+ ; return (final_rule_base, (local_rule_ids, local_rule_rhs_fvs), orphan_rules)
+ }
+ where
+ sw_chkr any = SwBool False -- A bit bogus
+ black_list_all v = not (isDataConWrapId v)
+ -- This stops all inlining except the
+ -- wrappers for data constructors
+
+ add_rules rule_base mds = extendRuleBaseList rule_base (md_rules mds)
+
+ -- Boringly, we need to gather the in-scope set.
+ -- Typically this thunk won't even be forced, but the test in
+ -- simpVar fails if it isn't right, and it might conceiveably matter
+ local_ids = foldr (unionVarSet . mkVarSet . bindersOf) emptyVarSet binds
+
+
+updateBinders :: (IdSet, -- Locally defined ids with their Rules attached
+ IdSet) -- Ids free in the RHS of local rules
+ -> IsExported
+ -> [CoreBind] -> [CoreBind]
+ -- A horrible function
+
+-- Update the binders of top-level bindings as follows
+-- a) Attach the rules for each locally-defined Id to that Id.
+-- b) Set the no-discard flag if either the Id is exported,
+-- or it's mentoined in the RHS of a rule
+--
+-- Reason for (a)
+-- - It makes the rules easier to look up
+-- - It means that transformation rules and specialisations for
+-- locally defined Ids are handled uniformly
+-- - It keeps alive things that are referred to only from a rule
+-- (the occurrence analyser knows about rules attached to Ids)
+-- - It makes sure that, when we apply a rule, the free vars
+-- of the RHS are more likely to be in scope
+--
+-- Reason for (b)
+-- It means that the binding won't be discarded EVEN if the binding
+-- ends up being trivial (v = w) -- the simplifier would usually just
+-- substitute w for v throughout, but we don't apply the substitution to
+-- the rules (maybe we should?), so this substitution would make the rule
+-- bogus.
+
+updateBinders (rule_ids, rule_rhs_fvs) is_exported binds
+ = map update_bndrs binds
+ where
+ update_bndrs (NonRec b r) = NonRec (update_bndr b) r
+ update_bndrs (Rec prs) = Rec [(update_bndr b, r) | (b,r) <- prs]