turn on unregisterised by default for alpha, hppa

[ghc-hetmet.git] / ghc / compiler / specialise / SpecConstr.lhs

diff --git a/ghc/compiler/specialise/SpecConstr.lhs b/ghc/compiler/specialise/SpecConstr.lhs
index 603c2a6..6a2cd92 100644 (file)
--- a/ghc/compiler/specialise/SpecConstr.lhs
+++ b/ghc/compiler/specialise/SpecConstr.lhs
@@ -12,26 +12,24 @@ module SpecConstr(
 
 import CoreSyn
 import CoreLint                ( showPass, endPass )
-import CoreUtils       ( exprType, eqExpr, mkPiTypes )
+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 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 )
-import Rules           ( addIdSpecialisations )
+import Rules           ( addIdSpecialisations, mkLocalRule, rulesOfBinds )
 import OccName         ( mkSpecOcc )
 import ErrUtils                ( dumpIfSet_dyn )
-import CmdLineOpts     ( DynFlags, DynFlag(..) )
+import DynFlags                ( DynFlags, DynFlag(..) )
 import BasicTypes      ( Activation(..) )
-import Outputable
-
 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"
-                 (vcat (map pprTidyIdRules (concat (map bindersOf binds'))))
+                 (pprRules (tidyRules emptyTidyEnv (rulesOfBinds binds')))
 
        return binds'
   where
@@ -335,11 +333,11 @@ 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 (Case scrut b alts) 
+scExpr env (Case scrut b ty alts) 
   = sc_scrut scrut             `thenUs` \ (scrut_usg, scrut') ->
     mapAndUnzipUs sc_alt alts  `thenUs` \ (alts_usgs, alts') ->
     returnUs (combineUsages alts_usgs `combineUsage` scrut_usg,
-             Case scrut' b alts')
+             Case scrut' b ty alts')
   where
     sc_scrut e@(Var v) = returnUs (varUsage env v CaseScrut, e)
     sc_scrut e        = scExpr env e
@@ -442,7 +440,7 @@ specialise env fn bndrs body (SCU {calls=calls, occs=occs})
                  (nubBy same_call good_calls `zip` [1..])
   where
     n_bndrs  = length bndrs
-    same_call as1 as2 = and (zipWith eqExpr as1 as2)
+    same_call as1 as2 = and (zipWith tcEqExpr as1 as2)
 
 ---------------------
 good_arg :: ConstrEnv -> IdEnv ArgOcc -> (CoreBndr, CoreArg) -> Bool
@@ -512,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      = 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))