Make -fliberate-case work for GADTs

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

diff --git a/ghc/compiler/specialise/Rules.lhs b/ghc/compiler/specialise/Rules.lhs
index 9220604..4d74314 100644 (file)
--- a/ghc/compiler/specialise/Rules.lhs
+++ b/ghc/compiler/specialise/Rules.lhs
@@ -22,14 +22,14 @@ import CoreFVs              ( exprFreeVars, exprsFreeVars, rulesRhsFreeVars )
 import CoreUnfold      ( isCheapUnfolding, unfoldingTemplate )
 import CoreUtils       ( tcEqExprX )
 import PprCore         ( pprRules )
-import Type            ( Type )
+import Type            ( TvSubstEnv )
 import TcType          ( tcSplitTyConApp_maybe )
 import CoreTidy                ( tidyRules )
 import Id              ( Id, idUnfolding, isLocalId, isGlobalId, idName,
                          idSpecialisation, idCoreRules, setIdSpecialisation ) 
 import IdInfo          ( SpecInfo( SpecInfo ) )
 import Var             ( Var )
-import VarEnv          ( IdEnv, TyVarEnv, InScopeSet, emptyTidyEnv,
+import VarEnv          ( IdEnv, InScopeSet, emptyTidyEnv,
                          emptyInScopeSet, mkInScopeSet, extendInScopeSetList, 
                          emptyVarEnv, lookupVarEnv, extendVarEnv, 
                          nukeRnEnvL, mkRnEnv2, rnOccR, rnOccL, inRnEnvR,
@@ -37,12 +37,11 @@ import VarEnv               ( IdEnv, TyVarEnv, InScopeSet, emptyTidyEnv,
 import VarSet
 import Name            ( Name, NamedThing(..), nameOccName )
 import NameEnv
-import Unify           ( tcMatchTyX, MatchEnv(..) )
+import Unify           ( ruleMatchTyX, MatchEnv(..) )
 import BasicTypes      ( Activation, CompilerPhase, isActive )
-
 import Outputable
 import FastString
-import Maybe           ( isJust )
+import Maybes          ( isJust, orElse )
 import Bag
 import Util            ( singleton )
 import List            ( isPrefixOf )
@@ -198,10 +197,13 @@ lookupRule :: (Activation -> Bool) -> InScopeSet
 lookupRule is_active in_scope rule_base fn args
   = matchRules is_active in_scope fn args rules
   where
-    rules | isLocalId fn = idCoreRules fn
-         | otherwise    = case lookupNameEnv rule_base (idName fn) of
-                               Just rules -> rules
-                               Nothing    -> []
+       -- The rules for an Id come from two places:
+       --      (a) the ones it is born with (idCoreRules fn)
+       --      (b) rules added in subsequent modules (extra_rules)
+       -- PrimOps, for example, are born with a bunch of rules under (a)
+    rules = extra_rules ++ idCoreRules fn
+    extra_rules | isLocalId fn = []
+               | otherwise    = lookupNameEnv rule_base (idName fn) `orElse` []
 
 matchRules :: (Activation -> Bool) -> InScopeSet
           -> Id -> [CoreExpr]
@@ -350,7 +352,6 @@ matchN in_scope tmpl_vars tmpl_es target_es
 -- for uniformity with IdSubstEnv
 type SubstEnv   = (TvSubstEnv, IdSubstEnv)     
 type IdSubstEnv = IdEnv    CoreExpr            
-type TvSubstEnv = TyVarEnv Type
 
 emptySubstEnv :: SubstEnv
 emptySubstEnv = (emptyVarEnv, emptyVarEnv)
@@ -512,7 +513,7 @@ We only want to replace (f T) with f', not (f Int).
 \begin{code}
 ------------------------------------------
 match_ty menv (tv_subst, id_subst) ty1 ty2
-  = do { tv_subst' <- Unify.tcMatchTyX menv tv_subst ty1 ty2
+  = do { tv_subst' <- Unify.ruleMatchTyX menv tv_subst ty1 ty2
        ; return (tv_subst', id_subst) }
 \end{code}