Make simplifier report which phase it is doing in -ddump output

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

diff --git a/compiler/specialise/SpecConstr.lhs b/compiler/specialise/SpecConstr.lhs
index 74944da..921dc04 100644 (file)
--- a/compiler/specialise/SpecConstr.lhs
+++ b/compiler/specialise/SpecConstr.lhs
@@ -211,6 +211,10 @@ data ConValue  = CV AltCon [CoreArg]
        -- Variables known to be bound to a constructor
        -- in a particular case alternative
 
+
+instance Outputable ConValue where
+   ppr (CV con args) = ppr con <+> interpp'SP args
+
 refineConstrEnv :: Subst -> ConstrEnv -> ConstrEnv
 -- The substitution is a type substitution only
 refineConstrEnv subst env = mapVarEnv refine_con_value env
@@ -262,6 +266,9 @@ extendCaseBndrs env case_bndr scrut con@(DataAlt data_con) alt_bndrs
                   map varToCoreExpr alt_bndrs
 
     gadt_args = map (substExpr subst . varToCoreExpr) alt_bndrs
+       -- This call generates some bogus warnings from substExpr,
+       -- because it's inconvenient to put all the Ids in scope
+       -- Will be fixed when we move to FC
 
     (alt_tvs, _) = span isTyVar alt_bndrs
     Just (tv_subst, is_local) = coreRefineTys data_con alt_tvs (idType case_bndr)
@@ -388,29 +395,30 @@ scExpr env e@(App _ _)
   = let 
        (fn, args) = collectArgs e
     in
-    mapAndUnzipUs (scExpr env) args    `thenUs` \ (usgs, args') ->
+    mapAndUnzipUs (scExpr env) (fn:args)       `thenUs` \ (usgs, (fn':args')) ->
+       -- Process the function too.   It's almost always a variable,
+       -- but not always.  In particular, if this pass follows float-in,
+       -- which it may, we can get 
+       --      (let f = ...f... in f) arg1 arg2
     let
-       arg_usg = combineUsages usgs
-       fn_usg  | Var f <- fn,
-                 Just RecFun <- lookupScopeEnv env f
-               = SCU { calls = unitVarEnv f [(cons env, args)], 
-                       occs  = emptyVarEnv }
-               | otherwise
-               = nullUsage
+       call_usg = case fn of
+                       Var f | Just RecFun <- lookupScopeEnv env f
+                             -> SCU { calls = unitVarEnv f [(cons env, args)], 
+                                      occs  = emptyVarEnv }
+                       other -> nullUsage
     in
-    returnUs (arg_usg `combineUsage` fn_usg, mkApps fn args')
-       -- Don't bother to look inside fn;
-       -- it's almost always a variable
+    returnUs (combineUsages usgs `combineUsage` call_usg, mkApps fn' args')
+
 
 ----------------------
 scBind :: ScEnv -> CoreBind -> UniqSM (ScEnv, ScUsage, CoreBind)
 scBind env (Rec [(fn,rhs)])
   | notNull val_bndrs
   = scExpr env_fn_body body            `thenUs` \ (usg, body') ->
+    specialise env fn bndrs body usg   `thenUs` \ (rules, spec_prs) ->
     let
        SCU { calls = calls, occs = occs } = usg
     in
-    specialise env fn bndrs body usg   `thenUs` \ (rules, spec_prs) ->
     returnUs (extendBndr env fn,       -- For the body of the letrec, just
                                        -- extend the env with Other to record 
                                        -- that it's in scope; no funny RecFun business
@@ -463,7 +471,7 @@ specialise env fn bndrs body (SCU {calls=calls, occs=occs})
        good_calls = [ pats
                     | (con_env, call_args) <- all_calls,
                       call_args `lengthAtLeast` n_bndrs,           -- App is saturated
-                      let call = (bndrs `zip` call_args),
+                      let call = bndrs `zip` call_args,
                       any (good_arg con_env occs) call,    -- At least one arg is a constr app
                       let (_, pats) = argsToPats con_env us call_args
                     ]