Fix scoped type variables for expression type signatures

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

diff --git a/compiler/specialise/SpecConstr.lhs b/compiler/specialise/SpecConstr.lhs
index afd53de..e5583e1 100644 (file)
--- a/compiler/specialise/SpecConstr.lhs
+++ b/compiler/specialise/SpecConstr.lhs
@@ -14,14 +14,12 @@ import CoreSyn
 import CoreLint                ( showPass, endPass )
 import CoreUtils       ( exprType, mkPiTypes )
 import CoreFVs                 ( exprsFreeVars )
-import CoreSubst       ( Subst, mkSubst, substExpr )
 import CoreTidy                ( tidyRules )
 import PprCore         ( pprRules )
 import WwLib           ( mkWorkerArgs )
-import DataCon         ( dataConRepArity, isVanillaDataCon, dataConTyVars )
-import Type            ( Type, tyConAppArgs, tyVarsOfTypes )
+import DataCon         ( dataConRepArity, dataConUnivTyVars )
+import Type            ( Type, tyConAppArgs )
 import Rules           ( matchN )
-import Unify           ( coreRefineTys )
 import Id              ( Id, idName, idType, isDataConWorkId_maybe, 
                          mkUserLocal, mkSysLocal, idUnfolding, isLocalId )
 import Var             ( Var )
@@ -429,12 +427,6 @@ data ConValue  = CV AltCon [CoreArg]
 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
-  where
-    refine_con_value (CV con args) = CV con (map (substExpr subst) args)
-
 emptyScEnv = SCE { scope = emptyVarEnv, cons = emptyVarEnv }
 
 data HowBound = RecFun -- These are the recursive functions for which 
@@ -483,28 +475,11 @@ extendCaseBndrs env case_bndr scrut con alt_bndrs
                  Var v -> lookupVarEnv cur_scope v `orElse` Other
                  other -> Other
 
-    extend_data_con data_con
-       | isVanillaDataCon data_con = extendCons env1 scrut case_bndr (CV con vanilla_args)
-       | otherwise                 = extendCons env2 scrut case_bndr (CV con gadt_args)
-               -- Note env2 for GADTs
+    extend_data_con data_con = 
+      extendCons env1 scrut case_bndr (CV con vanilla_args)
        where
-    
            vanilla_args = map Type (tyConAppArgs (idType case_bndr)) ++
-                          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)
-           subst = mkSubst in_scope tv_subst emptyVarEnv       -- No Id substitition
-           in_scope = mkInScopeSet (tyVarsOfTypes (varEnvElts tv_subst))
-       
-           env2 | is_local  = env1
-                | otherwise = env1 { cons = refineConstrEnv subst (cons env) }
-
+                          varsToCoreExprs alt_bndrs
 
 extendCons :: ScEnv -> CoreExpr -> Id -> ConValue -> ScEnv
 extendCons env scrut case_bndr val
@@ -608,10 +583,7 @@ conArgOccs :: ArgOcc -> AltCon -> [ArgOcc]
 
 conArgOccs (ScrutOcc fm) (DataAlt dc) 
   | Just pat_arg_occs <- lookupUFM fm dc
-  = tyvar_unks ++ pat_arg_occs
-  where
-    tyvar_unks | isVanillaDataCon dc = [UnkOcc | tv <- dataConTyVars dc]
-              | otherwise           = []
+  = [UnkOcc | tv <- dataConUnivTyVars dc] ++ pat_arg_occs
 
 conArgOccs other con = repeat UnkOcc
 \end{code}
@@ -636,6 +608,8 @@ scExpr env e@(Lit l)  = returnUs (nullUsage, e)
 scExpr env e@(Var v)  = returnUs (varUsage env v UnkOcc, e)
 scExpr env (Note n e) = scExpr env e   `thenUs` \ (usg,e') ->
                        returnUs (usg, Note n e')
+scExpr env (Cast e co)= scExpr env e   `thenUs` \ (usg,e') ->
+                        returnUs (usg, Cast e' co)
 scExpr env (Lam b e)  = scExpr (extendBndr env b) e    `thenUs` \ (usg,e') ->
                        returnUs (usg, Lam b e')
 
@@ -761,9 +735,8 @@ specialise env fn bndrs body body_usg
                         [ exprsFreeVars pats `delVarSetList` vs 
                         | (vs,pats) <- good_calls ]
              uniq_calls = nubBy (same_call in_scope) good_calls
-    in
-    mapAndUnzipUs (spec_one env fn (mkLams bndrs body)) 
-                 (uniq_calls `zip` [1..]) }
+       ; mapAndUnzipUs (spec_one env fn (mkLams bndrs body)) 
+                       (uniq_calls `zip` [1..]) }
   where
        -- Two calls are the same if they match both ways
     same_call in_scope (vs1,as1)(vs2,as2)
@@ -902,6 +875,13 @@ argToPat in_scope con_env (Var v) arg_occ
     then return (True, Var v)
     else wildCardPat (idType v)
 
+argToPat in_scope con_env (Let _ arg) arg_occ
+  = argToPat in_scope con_env arg arg_occ
+       -- Look through let expressions
+       -- e.g.         f (let v = rhs in \y -> ...v...)
+       -- Here we can specialise for f (\y -> ...)
+       -- because the rule-matcher will look through the let.
+
 argToPat in_scope con_env arg arg_occ
   | is_value_lam arg
   = return (True, arg)
@@ -980,4 +960,5 @@ is_con_app_maybe env expr
 mk_con_app :: AltCon -> [CoreArg] -> CoreExpr
 mk_con_app (LitAlt lit)  []   = Lit lit
 mk_con_app (DataAlt con) args = mkConApp con args
+mk_con_app other args = panic "SpecConstr.mk_con_app"
 \end{code}