Make -fliberate-case work for GADTs

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

diff --git a/ghc/compiler/specialise/Specialise.lhs b/ghc/compiler/specialise/Specialise.lhs
index f276cae..0e66b0b 100644 (file)
--- a/ghc/compiler/specialise/Specialise.lhs
+++ b/ghc/compiler/specialise/Specialise.lhs
@@ -18,16 +18,15 @@ import CoreSubst    ( Subst, mkEmptySubst, extendTvSubstList, lookupIdSubst,
                          substBndr, substBndrs, substTy, substInScope,
                          cloneIdBndr, cloneIdBndrs, cloneRecIdBndrs
                        ) 
-import Var             ( zapSpecPragmaId )
 import VarSet
 import VarEnv
 import CoreSyn
 import CoreUtils       ( applyTypeToArgs, mkPiTypes )
-import CoreFVs         ( exprFreeVars, exprsFreeVars )
-import CoreTidy                ( pprTidyIdRules )
+import CoreFVs         ( exprFreeVars, exprsFreeVars, idRuleVars )
+import CoreTidy                ( tidyRules )
 import CoreLint                ( showPass, endPass )
-import Rules           ( addIdSpecialisations, lookupRule, emptyRuleBase )
-
+import Rules           ( addIdSpecialisations, mkLocalRule, lookupRule, emptyRuleBase, rulesOfBinds )
+import PprCore         ( pprRules )
 import UniqSupply      ( UniqSupply,
                          UniqSM, initUs_, thenUs, returnUs, getUniqueUs, 
                          getUs, mapUs
@@ -586,7 +585,7 @@ specProgram dflags us binds
        endPass dflags "Specialise" 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
@@ -801,7 +800,7 @@ specDefn subst calls (fn, rhs)
     let
        (spec_defns, spec_uds, spec_rules) = unzip3 stuff
 
-       fn' = addIdSpecialisations zapped_fn spec_rules
+       fn' = addIdSpecialisations fn spec_rules
     in
     returnSM ((fn',rhs'), 
              spec_defns, 
@@ -809,14 +808,9 @@ specDefn subst calls (fn, rhs)
 
   | otherwise  -- No calls or RHS doesn't fit our preconceptions
   = specExpr subst rhs                 `thenSM` \ (rhs', rhs_uds) ->
-    returnSM ((zapped_fn, rhs'), [], rhs_uds)
+    returnSM ((fn, rhs'), [], rhs_uds)
   
   where
-    zapped_fn           = zapSpecPragmaId fn
-       -- If the fn is a SpecPragmaId, make it discardable
-       -- It's role as a holder for a call instance is o'er
-       -- But it might be alive for some other reason by now.
-
     fn_type           = idType fn
     (tyvars, theta, _) = tcSplitSigmaTy fn_type
     n_tyvars          = length tyvars
@@ -888,8 +882,8 @@ specDefn subst calls (fn, rhs)
        let
                -- The rule to put in the function's specialisation is:
                --      forall b,d, d1',d2'.  f t1 b t3 d d1' d2' = f1 b d  
-           spec_env_rule = Rule (mkFastString ("SPEC " ++ showSDoc (ppr fn)))
-                               AlwaysActive
+           spec_env_rule = mkLocalRule (mkFastString ("SPEC " ++ showSDoc (ppr fn)))
+                               AlwaysActive (idName fn)
                                (poly_tyvars ++ rhs_dicts')
                                inst_args 
                                (mkVarApps (Var spec_f) app_args)
@@ -1050,11 +1044,16 @@ zapCalls ids uds = uds {calls = delListFromFM (calls uds) ids}
 
 mkDB bind = (bind, bind_fvs bind)
 
-bind_fvs (NonRec bndr rhs) = exprFreeVars rhs
+bind_fvs (NonRec bndr rhs) = pair_fvs (bndr,rhs)
 bind_fvs (Rec prs)        = foldl delVarSet rhs_fvs bndrs
                           where
                             bndrs = map fst prs
-                            rhs_fvs = unionVarSets [exprFreeVars rhs | (bndr,rhs) <- prs]
+                            rhs_fvs = unionVarSets (map pair_fvs prs)
+
+pair_fvs (bndr, rhs) = exprFreeVars rhs `unionVarSet` idRuleVars bndr
+       -- Don't forget variables mentioned in the
+       -- rules of the bndr.  C.f. OccAnal.addRuleUsage
+
 
 addDictBind (dict,rhs) uds = uds { dict_binds = mkDB (NonRec dict rhs) `consBag` dict_binds uds }