projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
[project @ 1996-07-19 18:36:04 by partain]
[ghc-hetmet.git]
/
ghc
/
compiler
/
simplCore
/
SimplCase.lhs
diff --git
a/ghc/compiler/simplCore/SimplCase.lhs
b/ghc/compiler/simplCore/SimplCase.lhs
index
ab3e4b2
..
786f723
100644
(file)
--- a/
ghc/compiler/simplCore/SimplCase.lhs
+++ b/
ghc/compiler/simplCore/SimplCase.lhs
@@
-16,7
+16,8
@@
IMPORT_DELOOPER(SmplLoop) ( simplBind, simplExpr, MagicUnfoldingFun )
import BinderInfo -- too boring to try to select things...
import CmdLineOpts ( SimplifierSwitch(..) )
import CoreSyn
import BinderInfo -- too boring to try to select things...
import CmdLineOpts ( SimplifierSwitch(..) )
import CoreSyn
-import CoreUnfold ( Unfolding(..), UnfoldingGuidance(..), SimpleUnfolding
+import CoreUnfold ( Unfolding(..), UnfoldingGuidance(..),
+ SimpleUnfolding, FormSummary
)
import CoreUtils ( coreAltsType, nonErrorRHSs, maybeErrorApp,
unTagBindersAlts
)
import CoreUtils ( coreAltsType, nonErrorRHSs, maybeErrorApp,
unTagBindersAlts
@@
-371,7
+372,7
@@
constructor or literal, because that would have been inlined
\begin{code}
completeCase env scrut alts rhs_c
= simplAlts env scrut alts rhs_c `thenSmpl` \ alts' ->
\begin{code}
completeCase env scrut alts rhs_c
= simplAlts env scrut alts rhs_c `thenSmpl` \ alts' ->
- mkCoCase scrut alts'
+ mkCoCase env scrut alts'
\end{code}
\end{code}
@@
-682,7
+683,8
@@
completeAlgCaseWithKnownCon env con con_args (AlgAlts alts deflt) rhs_c
-- let-bind the binder to the constructor
cloneId env binder `thenSmpl` \ id' ->
let
-- let-bind the binder to the constructor
cloneId env binder `thenSmpl` \ id' ->
let
- new_env = extendEnvGivenBinding env occ_info id' (Con con con_args)
+ env1 = extendIdEnvWithClone env binder id'
+ new_env = extendEnvGivenBinding env1 occ_info id' (Con con con_args)
in
rhs_c new_env rhs `thenSmpl` \ rhs' ->
returnSmpl (Let (NonRec id' (Con con con_args)) rhs')
in
rhs_c new_env rhs `thenSmpl` \ rhs' ->
returnSmpl (Let (NonRec id' (Con con con_args)) rhs')
@@
-692,7
+694,7
@@
Case absorption and identity-case elimination
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
\begin{code}
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
\begin{code}
-mkCoCase :: OutExpr -> OutAlts -> SmplM OutExpr
+mkCoCase :: SimplEnv -> OutExpr -> OutAlts -> SmplM OutExpr
\end{code}
@mkCoCase@ tries the following transformation (if possible):
\end{code}
@mkCoCase@ tries the following transformation (if possible):
@@
-742,12
+744,13
@@
The following code handles *both* these transformations (one
equation for AlgAlts, one for PrimAlts):
\begin{code}
equation for AlgAlts, one for PrimAlts):
\begin{code}
-mkCoCase scrut (AlgAlts outer_alts
+mkCoCase env scrut (AlgAlts outer_alts
(BindDefault deflt_var
(Case (Var scrut_var')
(AlgAlts inner_alts inner_deflt))))
(BindDefault deflt_var
(Case (Var scrut_var')
(AlgAlts inner_alts inner_deflt))))
- | (scrut_is_var && scrut_var == scrut_var') -- First transformation
- || deflt_var == scrut_var' -- Second transformation
+ | switchIsSet env SimplCaseMerge &&
+ ((scrut_is_var && scrut_var == scrut_var') || -- First transformation
+ deflt_var == scrut_var') -- Second transformation
= -- Aha! The default-absorption rule applies
tick CaseMerge `thenSmpl_`
returnSmpl (Case scrut (AlgAlts (outer_alts ++ munged_reduced_inner_alts)
= -- Aha! The default-absorption rule applies
tick CaseMerge `thenSmpl_`
returnSmpl (Case scrut (AlgAlts (outer_alts ++ munged_reduced_inner_alts)
@@
-775,13
+778,14
@@
mkCoCase scrut (AlgAlts outer_alts
arg_tys = case (getAppDataTyConExpandingDicts (idType deflt_var)) of
(_, arg_tys, _) -> arg_tys
arg_tys = case (getAppDataTyConExpandingDicts (idType deflt_var)) of
(_, arg_tys, _) -> arg_tys
-mkCoCase scrut (PrimAlts
+mkCoCase env scrut (PrimAlts
outer_alts
(BindDefault deflt_var (Case
(Var scrut_var')
(PrimAlts inner_alts inner_deflt))))
outer_alts
(BindDefault deflt_var (Case
(Var scrut_var')
(PrimAlts inner_alts inner_deflt))))
- | (scrut_is_var && scrut_var == scrut_var') ||
- deflt_var == scrut_var'
+ | switchIsSet env SimplCaseMerge &&
+ ((scrut_is_var && scrut_var == scrut_var') ||
+ deflt_var == scrut_var')
= -- Aha! The default-absorption rule applies
tick CaseMerge `thenSmpl_`
returnSmpl (Case scrut (PrimAlts (outer_alts ++ munged_reduced_inner_alts)
= -- Aha! The default-absorption rule applies
tick CaseMerge `thenSmpl_`
returnSmpl (Case scrut (PrimAlts (outer_alts ++ munged_reduced_inner_alts)
@@
-831,7
+835,7
@@
Now the identity-case transformation:
and similar friends.
\begin{code}
and similar friends.
\begin{code}
-mkCoCase scrut alts
+mkCoCase env scrut alts
| identity_alts alts
= tick CaseIdentity `thenSmpl_`
returnSmpl scrut
| identity_alts alts
= tick CaseIdentity `thenSmpl_`
returnSmpl scrut
@@
-868,7
+872,7
@@
mkCoCase scrut alts
The catch-all case
\begin{code}
The catch-all case
\begin{code}
-mkCoCase other_scrut other_alts = returnSmpl (Case other_scrut other_alts)
+mkCoCase env other_scrut other_alts = returnSmpl (Case other_scrut other_alts)
\end{code}
Boring local functions used above. They simply introduce a trivial binding
\end{code}
Boring local functions used above. They simply introduce a trivial binding