projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
Retain unfoldings even with SimplGently
[ghc-hetmet.git]
/
compiler
/
simplCore
/
Simplify.lhs
diff --git
a/compiler/simplCore/Simplify.lhs
b/compiler/simplCore/Simplify.lhs
index
8c34873
..
e1a8492
100644
(file)
--- a/
compiler/simplCore/Simplify.lhs
+++ b/
compiler/simplCore/Simplify.lhs
@@
-25,7
+25,7
@@
import NewDemand ( isStrictDmd )
import PprCore ( pprParendExpr, pprCoreExpr )
import CoreUnfold ( mkUnfolding, callSiteInline, CallCtxt(..) )
import CoreUtils
import PprCore ( pprParendExpr, pprCoreExpr )
import CoreUnfold ( mkUnfolding, callSiteInline, CallCtxt(..) )
import CoreUtils
-import Rules ( lookupRule )
+import Rules ( lookupRule, getRules )
import BasicTypes ( isMarkedStrict )
import CostCentre ( currentCCS )
import TysPrim ( realWorldStatePrimTy )
import BasicTypes ( isMarkedStrict )
import CostCentre ( currentCCS )
import TysPrim ( realWorldStatePrimTy )
@@
-566,7
+566,10
@@
completeBind env top_lvl old_bndr new_bndr new_rhs
old_info = idInfo old_bndr
occ_info = occInfo old_info
wkr = substWorker env (workerInfo old_info)
old_info = idInfo old_bndr
occ_info = occInfo old_info
wkr = substWorker env (workerInfo old_info)
- omit_unfolding = isNonRuleLoopBreaker occ_info || not (activeInline env old_bndr)
+ omit_unfolding = isNonRuleLoopBreaker occ_info
+ -- or not (activeInline env old_bndr)
+ -- Do *not* trim the unfolding in SimplGently, else
+ -- the specialiser can't see it!
-----------------
addPolyBind :: TopLevelFlag -> SimplEnv -> OutBind -> SimplEnv
-----------------
addPolyBind :: TopLevelFlag -> SimplEnv -> OutBind -> SimplEnv
@@
-1033,12
+1036,13
@@
completeCall env var cont
-- is recursive, and hence a loop breaker:
-- foldr k z (build g) = g k z
-- So it's up to the programmer: rules can cause divergence
-- is recursive, and hence a loop breaker:
-- foldr k z (build g) = g k z
-- So it's up to the programmer: rules can cause divergence
- ; rules <- getRules
+ ; rule_base <- getSimplRules
; let in_scope = getInScope env
; let in_scope = getInScope env
+ rules = getRules rule_base var
maybe_rule = case activeRule dflags env of
Nothing -> Nothing -- No rules apply
Just act_fn -> lookupRule act_fn in_scope
maybe_rule = case activeRule dflags env of
Nothing -> Nothing -- No rules apply
Just act_fn -> lookupRule act_fn in_scope
- rules var args
+ var args rules
; case maybe_rule of {
Just (rule, rule_rhs) -> do
tick (RuleFired (ru_name rule))
; case maybe_rule of {
Just (rule, rule_rhs) -> do
tick (RuleFired (ru_name rule))