[project @ 2001-04-17 22:11:00 by lewie]

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

diff --git a/ghc/compiler/specialise/SpecConstr.lhs b/ghc/compiler/specialise/SpecConstr.lhs
index d70faf3..dfea0cb 100644 (file)
--- a/ghc/compiler/specialise/SpecConstr.lhs
+++ b/ghc/compiler/specialise/SpecConstr.lhs
@@ -12,11 +12,11 @@ module SpecConstr(
 
 import CoreSyn
 import CoreLint                ( showPass, endPass )
-import CoreUtils       ( exprType, exprIsConApp_maybe, eqExpr )
+import CoreUtils       ( exprType, eqExpr )
 import CoreFVs                 ( exprsFreeVars )
 import DataCon         ( dataConRepArity )
 import Type            ( tyConAppArgs )
-import PprCore         ( pprCoreRules )
+import PprCore         ( pprCoreRules, pprCoreRule )
 import Id              ( Id, idName, idType, idSpecialisation,
                          isDataConId_maybe,
                          mkUserLocal, mkSysLocal )
@@ -231,7 +231,11 @@ extendBndr  env bndr  = env { scope = extendVarEnv (scope env) bndr Other }
     -- case scrut of b
     --     C x y -> ...
     -- we want to bind b, and perhaps scrut too, to (C x y)
-extendCaseBndr env case_bndr scrut con alt_bndrs
+extendCaseBndrs :: ScEnv -> Id -> CoreExpr -> AltCon -> [Var] -> ScEnv
+extendCaseBndrs env case_bndr scrut DEFAULT alt_bndrs
+  = extendBndrs env (case_bndr : alt_bndrs)
+
+extendCaseBndrs env case_bndr scrut con alt_bndrs
   = case scrut of
        Var v ->   -- Bind the scrutinee in the ConstrEnv if it's a variable
                   -- Also forget if the scrutinee is a RecArg, because we're
@@ -337,7 +341,7 @@ scExpr env (Case scrut b alts)
     sc_alt (con,bs,rhs) = scExpr env1 rhs      `thenUs` \ (usg,rhs') ->
                          returnUs (usg, (con,bs,rhs'))
                        where
-                         env1 = extendCaseBndr env b scrut con bs
+                         env1 = extendCaseBndrs env b scrut con bs
 
 scExpr env (Let bind body)
   = scBind env bind    `thenUs` \ (env', bind_usg, bind') ->
@@ -426,7 +430,6 @@ specialise env fn bndrs body (SCU {calls=calls, occs=occs})
                       let (_, pats) = argsToPats con_env us call_args
                     ]
     in
-    pprTrace "specialise" (ppr all_calls $$ ppr good_calls) $
     mapAndUnzipUs (spec_one env fn (mkLams bndrs body)) 
                  (nubBy same_call good_calls `zip` [1..])
   where
@@ -442,8 +445,7 @@ good_arg con_env arg_occs (bndr, arg)
 
 bndr_usg_ok :: IdEnv ArgOcc -> Var -> CoreArg -> Bool
 bndr_usg_ok arg_occs bndr arg
-  = pprTrace "bndr_ok" (ppr bndr <+> ppr (lookupVarEnv arg_occs bndr)) $
-    case lookupVarEnv arg_occs bndr of
+  = case lookupVarEnv arg_occs bndr of
        Just CaseScrut -> True                  -- Used only by case scrutiny
        Just Both      -> case arg of           -- Used by case and elsewhere
                            App _ _ -> True     -- so the arg should be an explicit con app