projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
[project @ 2006-01-10 13:35:04 by simonmar]
[ghc-hetmet.git]
/
ghc
/
compiler
/
specialise
/
SpecConstr.lhs
diff --git
a/ghc/compiler/specialise/SpecConstr.lhs
b/ghc/compiler/specialise/SpecConstr.lhs
index
e07470b
..
6a2cd92
100644
(file)
--- a/
ghc/compiler/specialise/SpecConstr.lhs
+++ b/
ghc/compiler/specialise/SpecConstr.lhs
@@
-14,24
+14,22
@@
import CoreSyn
import CoreLint ( showPass, endPass )
import CoreUtils ( exprType, tcEqExpr, mkPiTypes )
import CoreFVs ( exprsFreeVars )
import CoreLint ( showPass, endPass )
import CoreUtils ( exprType, tcEqExpr, mkPiTypes )
import CoreFVs ( exprsFreeVars )
-import CoreTidy ( pprTidyIdRules )
+import CoreTidy ( tidyRules )
+import PprCore ( pprRules )
import WwLib ( mkWorkerArgs )
import DataCon ( dataConRepArity )
import Type ( tyConAppArgs )
import WwLib ( mkWorkerArgs )
import DataCon ( dataConRepArity )
import Type ( tyConAppArgs )
-import Id ( Id, idName, idType,
- isDataConWorkId_maybe,
+import Id ( Id, idName, idType, isDataConWorkId_maybe,
mkUserLocal, mkSysLocal )
import Var ( Var )
import VarEnv
import VarSet
import Name ( nameOccName, nameSrcLoc )
mkUserLocal, mkSysLocal )
import Var ( Var )
import VarEnv
import VarSet
import Name ( nameOccName, nameSrcLoc )
-import Rules ( addIdSpecialisations )
+import Rules ( addIdSpecialisations, mkLocalRule, rulesOfBinds )
import OccName ( mkSpecOcc )
import ErrUtils ( dumpIfSet_dyn )
import OccName ( mkSpecOcc )
import ErrUtils ( dumpIfSet_dyn )
-import CmdLineOpts ( DynFlags, DynFlag(..) )
+import DynFlags ( DynFlags, DynFlag(..) )
import BasicTypes ( Activation(..) )
import BasicTypes ( Activation(..) )
-import Outputable
-
import Maybes ( orElse )
import Util ( mapAccumL, lengthAtLeast, notNull )
import List ( nubBy, partition )
import Maybes ( orElse )
import Util ( mapAccumL, lengthAtLeast, notNull )
import List ( nubBy, partition )
@@
-182,7
+180,7
@@
specConstrProgram dflags us binds
endPass dflags "SpecConstr" Opt_D_dump_spec binds'
dumpIfSet_dyn dflags Opt_D_dump_rules "Top-level specialisations"
endPass dflags "SpecConstr" Opt_D_dump_spec binds'
dumpIfSet_dyn dflags Opt_D_dump_rules "Top-level specialisations"
- (vcat (map pprTidyIdRules (concat (map bindersOf binds'))))
+ (pprRules (tidyRules emptyTidyEnv (rulesOfBinds binds')))
return binds'
where
return binds'
where
@@
-335,11
+333,9
@@
scExpr env (Note n e) = scExpr env e `thenUs` \ (usg,e') ->
scExpr env (Lam b e) = scExpr (extendBndr env b) e `thenUs` \ (usg,e') ->
returnUs (usg, Lam b e')
scExpr env (Lam b e) = scExpr (extendBndr env b) e `thenUs` \ (usg,e') ->
returnUs (usg, Lam b e')
--- gaw 2004
scExpr env (Case scrut b ty alts)
= sc_scrut scrut `thenUs` \ (scrut_usg, scrut') ->
mapAndUnzipUs sc_alt alts `thenUs` \ (alts_usgs, alts') ->
scExpr env (Case scrut b ty alts)
= sc_scrut scrut `thenUs` \ (scrut_usg, scrut') ->
mapAndUnzipUs sc_alt alts `thenUs` \ (alts_usgs, alts') ->
--- gaw 2004
returnUs (combineUsages alts_usgs `combineUsage` scrut_usg,
Case scrut' b ty alts')
where
returnUs (combineUsages alts_usgs `combineUsage` scrut_usg,
Case scrut' b ty alts')
where
@@
-514,8
+510,8
@@
spec_one env fn rhs (pats, rule_number)
rule_name = mkFastString ("SC:" ++ showSDoc (ppr fn <> int rule_number))
spec_rhs = mkLams spec_lam_args spec_body
spec_id = mkUserLocal spec_occ spec_uniq (mkPiTypes spec_lam_args body_ty) fn_loc
rule_name = mkFastString ("SC:" ++ showSDoc (ppr fn <> int rule_number))
spec_rhs = mkLams spec_lam_args spec_body
spec_id = mkUserLocal spec_occ spec_uniq (mkPiTypes spec_lam_args body_ty) fn_loc
- rule = Rule rule_name specConstrActivation
- bndrs pats (mkVarApps (Var spec_id) spec_call_args)
+ rule_rhs = mkVarApps (Var spec_id) spec_call_args
+ rule = mkLocalRule rule_name specConstrActivation fn_name bndrs pats rule_rhs
in
returnUs (rule, (spec_id, spec_rhs))
in
returnUs (rule, (spec_id, spec_rhs))