Merge branch 'master' of http://darcs.haskell.org//ghc

6 files changed, 110 insertions, 65 deletions

diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs
index 34046e8159..c7dc1a6524 100644
--- a/compiler/coreSyn/CoreUtils.lhs
+++ b/compiler/coreSyn/CoreUtils.lhs
@@ -1350,10 +1350,11 @@ eqExprX id_unfolding_fun env e1 e2
         (bs2,rs2) = unzip ps2
         env' = rnBndrs2 env bs1 bs2
 
-    go env (Case e1 b1 _ a1) (Case e2 b2 _ a2)
-      =  go env e1 e2
-      && eqTypeX env (idType b1) (idType b2)
-      && all2 (go_alt (rnBndr2 env b1 b2)) a1 a2
+    go env (Case e1 b1 t1 a1) (Case e2 b2 t2 a2)
+      | null a1   -- See Note [Empty case alternatives] in TrieMap
+      = null a2 && go env e1 e2 && eqTypeX env t1 t2
+      | otherwise
+      =  go env e1 e2 && all2 (go_alt (rnBndr2 env b1 b2)) a1 a2
 
     go _ _ _ = False
 
diff --git a/compiler/coreSyn/TrieMap.lhs b/compiler/coreSyn/TrieMap.lhs
index e551d6423c..18e4dd82a6 100644
--- a/compiler/coreSyn/TrieMap.lhs
+++ b/compiler/coreSyn/TrieMap.lhs
@@ -239,22 +239,37 @@ Note [Binders]
      - the binders in an alternative
    because they are totally fixed by the context
 
+Note [Empty case alternatives]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+* For a key (Case e b ty (alt:alts))  we don't need to look the return type
+  'ty', because every alternative has that type.
+
+* For a key (Case e b ty []) we MUST look at the return type 'ty', because
+  otherwise (Case (error () "urk") _ Int  []) would compare equal to 
+            (Case (error () "urk") _ Bool [])
+  which is utterly wrong (Trac #6097)
+
+We could compare the return type regardless, but the wildly common case
+is that it's unnecesary, so we have two fields (cm_case and cm_ecase)
+for the two possibilities.  Only cm_ecase looks at the type.
+
+See also Note [Empty case alternatives] in CoreSyn.
 
 \begin{code}
 data CoreMap a
   = EmptyCM
-  | CM { cm_var  :: VarMap a
-       , cm_lit  :: LiteralMap a
-       , cm_co   :: CoercionMap a
-       , cm_type :: TypeMap a
-       , cm_cast :: CoreMap (CoercionMap a)
-       , cm_source :: CoreMap (TickishMap a)
-       , cm_app  :: CoreMap (CoreMap a)
-       , cm_lam  :: CoreMap (TypeMap a)
-       , cm_letn :: CoreMap (CoreMap (BndrMap a))
-       , cm_letr :: ListMap CoreMap (CoreMap (ListMap BndrMap a))
-       , cm_case :: CoreMap (ListMap AltMap a)
-       	 -- Note [Binders]
+  | CM { cm_var   :: VarMap a
+       , cm_lit   :: LiteralMap a
+       , cm_co    :: CoercionMap a
+       , cm_type  :: TypeMap a
+       , cm_cast  :: CoreMap (CoercionMap a)
+       , cm_tick :: CoreMap (TickishMap a)
+       , cm_app   :: CoreMap (CoreMap a)
+       , cm_lam   :: CoreMap (TypeMap a)    -- Note [Binders]
+       , cm_letn  :: CoreMap (CoreMap (BndrMap a))
+       , cm_letr  :: ListMap CoreMap (CoreMap (ListMap BndrMap a))
+       , cm_case  :: CoreMap (ListMap AltMap a)
+       , cm_ecase :: CoreMap (TypeMap a)    -- Note [Empty case alternatives]
      }
 
 
@@ -264,7 +279,7 @@ wrapEmptyCM = CM { cm_var = emptyTM, cm_lit = emptyLiteralMap
  		 , cm_cast = emptyTM, cm_app = emptyTM 
  		 , cm_lam = emptyTM, cm_letn = emptyTM 
  		 , cm_letr = emptyTM, cm_case = emptyTM
-                 , cm_source = emptyTM }
+                 , cm_ecase = emptyTM, cm_tick = emptyTM }
 
 instance TrieMap CoreMap where
    type Key CoreMap = CoreExpr
@@ -298,12 +313,13 @@ fdE k m
   . foldTM k (cm_co m)
   . foldTM k (cm_type m)
   . foldTM (foldTM k) (cm_cast m)
-  . foldTM (foldTM k) (cm_source m)
+  . foldTM (foldTM k) (cm_tick m)
   . foldTM (foldTM k) (cm_app m)
   . foldTM (foldTM k) (cm_lam m)
   . foldTM (foldTM (foldTM k)) (cm_letn m)
   . foldTM (foldTM (foldTM k)) (cm_letr m)
   . foldTM (foldTM k) (cm_case m)
+  . foldTM (foldTM k) (cm_ecase m)
 
 lkE :: CmEnv -> CoreExpr -> CoreMap a -> Maybe a
 -- lkE: lookup in trie for expressions
@@ -316,9 +332,9 @@ lkE env expr cm
     go (Type t) 	    = cm_type >.> lkT env t
     go (Coercion c)         = cm_co   >.> lkC env c
     go (Cast e c)           = cm_cast >.> lkE env e >=> lkC env c
-    go (Tick tickish e)   = cm_source >.> lkE env e >=> lkTickish tickish
-    go (App e1 e2)          = cm_app >.> lkE env e2 >=> lkE env e1
-    go (Lam v e)            = cm_lam >.> lkE (extendCME env v) e >=> lkBndr env v
+    go (Tick tickish e)     = cm_tick >.> lkE env e >=> lkTickish tickish
+    go (App e1 e2)          = cm_app  >.> lkE env e2 >=> lkE env e1
+    go (Lam v e)            = cm_lam  >.> lkE (extendCME env v) e >=> lkBndr env v
     go (Let (NonRec b r) e) = cm_letn >.> lkE env r 
                               >=> lkE (extendCME env b) e >=> lkBndr env b
     go (Let (Rec prs) e)    = let (bndrs,rhss) = unzip prs
@@ -326,7 +342,9 @@ lkE env expr cm
                               in cm_letr
                                  >.> lkList (lkE env1) rhss >=> lkE env1 e
                                  >=> lkList (lkBndr env1) bndrs
-    go (Case e b _ as)      = cm_case >.> lkE env e 
+    go (Case e b ty as)     -- See Note [Empty case alternatives]
+               | null as    = cm_ecase >.> lkE env e >=> lkT env ty
+               | otherwise  = cm_case >.> lkE env e 
                               >=> lkList (lkA (extendCME env b)) as
 
 xtE :: CmEnv -> CoreExpr -> XT a -> CoreMap a -> CoreMap a
@@ -337,7 +355,7 @@ xtE env (Coercion c)         f m = m { cm_co   = cm_co m   |> xtC env c f }
 xtE _   (Lit l)              f m = m { cm_lit  = cm_lit m  |> xtLit l f }
 xtE env (Cast e c)           f m = m { cm_cast = cm_cast m |> xtE env e |>>
                                                  xtC env c f }
-xtE env (Tick t e)         f m = m { cm_source = cm_source m |> xtE env e |>> xtTickish t f }
+xtE env (Tick t e)           f m = m { cm_tick = cm_tick m |> xtE env e |>> xtTickish t f }
 xtE env (App e1 e2)          f m = m { cm_app = cm_app m |> xtE env e2 |>> xtE env e1 f }
 xtE env (Lam v e)            f m = m { cm_lam = cm_lam m |> xtE (extendCME env v) e
                                                  |>> xtBndr env v f }
@@ -350,7 +368,9 @@ xtE env (Let (Rec prs) e)    f m = m { cm_letr = let (bndrs,rhss) = unzip prs
                                                     |>  xtList (xtE env1) rhss 
                                                     |>> xtE env1 e 
                                                     |>> xtList (xtBndr env1) bndrs f }
-xtE env (Case e b _ as)      f m = m { cm_case = cm_case m |> xtE env e 
+xtE env (Case e b ty as)     f m 
+                     | null as   = m { cm_ecase = cm_ecase m |> xtE env e |>> xtT env ty f }
+                     | otherwise = m { cm_case = cm_case m |> xtE env e 
                                                  |>> let env1 = extendCME env b
                                                      in xtList (xtA env1) as f }
 
diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs
index 44d6a8d01f..e3b6a33298 100644
--- a/compiler/typecheck/TcInteract.lhs
+++ b/compiler/typecheck/TcInteract.lhs
@@ -1320,11 +1320,9 @@ rewriteWithFunDeps eqn_pred_locs xis wloc
 
 instFunDepEqn :: WantedLoc -> Equation -> TcS [(Int,CtEvidence)]
 -- Post: Returns the position index as well as the corresponding FunDep equality
-instFunDepEqn wl (FDEqn { fd_qtvs = qtvs, fd_eqs = eqs
+instFunDepEqn wl (FDEqn { fd_qtvs = tvs, fd_eqs = eqs
                         , fd_pred1 = d1, fd_pred2 = d2 })
-  = do { let tvs = varSetElems qtvs
-       ; tys' <- mapM instFlexiTcS tvs  -- IA0_TODO: we might need to do kind substitution
-       ; let subst = zipTopTvSubst tvs tys'
+  = do { (subst, _) <- instFlexiTcS tvs  -- Takes account of kind substitution
        ; foldM (do_one subst) [] eqs }
   where 
     do_one subst ievs (FDEq { fd_pos = i, fd_ty_left = ty1, fd_ty_right = ty2 })
diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs
index 287783cb88..5a40df94ae 100644
--- a/compiler/typecheck/TcSMonad.lhs
+++ b/compiler/typecheck/TcSMonad.lhs
@@ -1337,11 +1337,15 @@ instDFunType dfun_id mb_inst_tys
            ; return (ty : tys, phi) }
     go _ _ _ = pprPanic "instDFunTypes" (ppr dfun_id $$ ppr mb_inst_tys)
 
-instFlexiTcS :: TyVar -> TcS TcType 
+instFlexiTcS :: [TKVar] -> TcS (TvSubst, [TcType])
 -- Like TcM.instMetaTyVar but the variable that is created is 
 -- always touchable; we are supposed to guess its instantiation.
 -- See Note [Touchable meta type variables] 
-instFlexiTcS tv = wrapTcS (instFlexiTcSHelper (tyVarName tv) (tyVarKind tv) )
+instFlexiTcS tvs = wrapTcS (mapAccumLM inst_one emptyTvSubst tvs)
+  where
+     inst_one subst tv = do { ty' <- instFlexiTcSHelper (tyVarName tv) 
+                                                        (substTy subst (tyVarKind tv))
+                            ; return (extendTvSubst subst tv ty', ty') }
 
 newFlexiTcSTy :: Kind -> TcS TcType  
 newFlexiTcSTy knd 
diff --git a/compiler/types/FunDeps.lhs b/compiler/types/FunDeps.lhs
index 31ef9cc7ab..ab1007f29d 100644
--- a/compiler/types/FunDeps.lhs
+++ b/compiler/types/FunDeps.lhs
@@ -28,7 +28,9 @@ module FunDeps (
 import Name
 import Var
 import Class
+import Id( idType )
 import Type
+import TcType( tcSplitDFunTy )
 import Unify
 import InstEnv
 import VarSet
@@ -208,7 +210,7 @@ Finally, the position parameters will help us rewrite the wanted constraint ``on
 type Pred_Loc = (PredType, SDoc)	-- SDoc says where the Pred comes from
 
 data Equation 
-   = FDEqn { fd_qtvs :: TyVarSet		-- Instantiate these to fresh unification vars
+   = FDEqn { fd_qtvs :: [TyVar]   		-- Instantiate these type and kind vars to fresh unification vars
            , fd_eqs  :: [FDEq]			--   and then make these equal
            , fd_pred1, fd_pred2 :: Pred_Loc }	-- The Equation arose from
 	     	       		   	    	-- combining these two constraints
@@ -286,7 +288,7 @@ improveFromAnother pred1@(ty1, _) pred2@(ty2, _)
   | Just (cls1, tys1) <- getClassPredTys_maybe ty1
   , Just (cls2, tys2) <- getClassPredTys_maybe ty2
   , tys1 `lengthAtLeast` 2 && cls1 == cls2
-  = [ FDEqn { fd_qtvs = emptyVarSet, fd_eqs = eqs, fd_pred1 = pred1, fd_pred2 = pred2 }
+  = [ FDEqn { fd_qtvs = [], fd_eqs = eqs, fd_pred1 = pred1, fd_pred2 = pred2 }
     | let (cls_tvs, cls_fds) = classTvsFds cls1
     , fd <- cls_fds
     , let (ltys1, rs1)  = instFD         fd cls_tvs tys1
@@ -303,7 +305,7 @@ improveFromAnother _ _ = []
 
 pprEquation :: Equation -> SDoc
 pprEquation (FDEqn { fd_qtvs = qtvs, fd_eqs = pairs }) 
-  = vcat [ptext (sLit "forall") <+> braces (pprWithCommas ppr (varSetElems qtvs)),
+  = vcat [ptext (sLit "forall") <+> braces (pprWithCommas ppr qtvs),
 	  nest 2 (vcat [ ppr t1 <+> ptext (sLit "~") <+> ppr t2 | (FDEq _ t1 t2) <- pairs])]
 
 improveFromInstEnv :: (InstEnv,InstEnv)
@@ -320,7 +322,7 @@ improveFromInstEnv inst_env pred@(ty, _)
   , let (cls_tvs, cls_fds) = classTvsFds cls
         instances          = classInstances inst_env cls
         rough_tcs          = roughMatchTcs tys
-  = [ FDEqn { fd_qtvs = qtvs, fd_eqs = eqs, fd_pred1 = p_inst, fd_pred2=pred }
+  = [ FDEqn { fd_qtvs = meta_tvs, fd_eqs = eqs, fd_pred1 = p_inst, fd_pred2=pred }
     | fd <- cls_fds		-- Iterate through the fundeps first,
 				-- because there often are none!
     , let trimmed_tcs = trimRoughMatchTcs cls_tvs fd rough_tcs
@@ -328,25 +330,27 @@ improveFromInstEnv inst_env pred@(ty, _)
 		-- Remember that instanceCantMatch treats both argumnents
 		-- symmetrically, so it's ok to trim the rough_tcs,
 		-- rather than trimming each inst_tcs in turn
-    , ispec@(ClsInst { is_tvs = qtvs, is_tys = tys_inst,
-		 	is_tcs = inst_tcs }) <- instances
-    , not (instanceCantMatch inst_tcs trimmed_tcs)
-    , let p_inst = (mkClassPred cls tys_inst,
+    , ispec <- instances
+    , (meta_tvs, eqs) <- checkClsFD fd cls_tvs ispec 
+                                    emptyVarSet tys trimmed_tcs -- NB: orientation
+    , let p_inst = (mkClassPred cls (is_tys ispec),
 		    sep [ ptext (sLit "arising from the dependency") <+> quotes (pprFunDep fd)	
 		        , ptext (sLit "in the instance declaration")
 			  <+> pprNameDefnLoc (getName ispec)])
-    , (qtvs, eqs) <- checkClsFD qtvs fd cls_tvs tys_inst tys -- NB: orientation
-    , not (null eqs)
     ]
 improveFromInstEnv _ _ = []
 
 
-checkClsFD :: TyVarSet 			-- Quantified type variables; see note below
-	   -> FunDep TyVar -> [TyVar] 	-- One functional dependency from the class
-	   -> [Type] -> [Type]
-	   -> [(TyVarSet, [FDEq])]
+checkClsFD :: FunDep TyVar -> [TyVar] 	          -- One functional dependency from the class
+           -> ClsInst                             -- An instance template
+           -> TyVarSet -> [Type] -> [Maybe Name]  -- Arguments of this (C tys) predicate
+                                                  -- TyVarSet are extra tyvars that can be instantiated
+	   -> [([TyVar], [FDEq])]
+
+checkClsFD fd clas_tvs 
+           (ClsInst { is_tvs = qtvs, is_tys = tys_inst, is_tcs = rough_tcs_inst, is_dfun = dfun })
+           extra_qtvs tys_actual rough_tcs_actual
 
-checkClsFD qtvs fd clas_tvs tys1 tys2
 -- 'qtvs' are the quantified type variables, the ones which an be instantiated 
 -- to make the types match.  For example, given
 --	class C a b | a->b where ...
@@ -355,8 +359,8 @@ checkClsFD qtvs fd clas_tvs tys1 tys2
 -- and an Inst of form (C (Maybe t1) t2), 
 -- then we will call checkClsFD with
 --
---	qtvs = {x}, tys1 = [Maybe x,  Tree x]
---		    tys2 = [Maybe t1, t2]
+--	is_qtvs = {x}, is_tys = [Maybe x,  Tree x]
+--		       tys_actual = [Maybe t1, t2]
 --
 -- We can instantiate x to t1, and then we want to force
 -- 	(Tree x) [t1/x]  ~   t2
@@ -368,10 +372,14 @@ checkClsFD qtvs fd clas_tvs tys1 tys2
 -- This function is also used by InstEnv.badFunDeps, which needs to *unify*
 -- For the one-sided matching case, the qtvs are just from the template,
 -- so we get matching
---
-  = ASSERT2( length tys1 == length tys2     && 
-	     length tys1 == length clas_tvs 
-	    , ppr tys1 <+> ppr tys2 )
+
+  | instanceCantMatch rough_tcs_inst rough_tcs_actual
+  = []		-- Filter out ones that can't possibly match, 
+
+  | otherwise
+  = ASSERT2( length tys_inst == length tys_actual     && 
+	     length tys_inst == length clas_tvs 
+	    , ppr tys_inst <+> ppr tys_actual )
 
     case tcUnifyTys bind_fn ltys1 ltys2 of
 	Nothing  -> []
@@ -391,8 +399,11 @@ checkClsFD qtvs fd clas_tvs tys1 tys2
                         -- so we would produce no FDs, which is clearly wrong. 
                   -> [] 
 
+                  | null fdeqs
+                  -> []
+
                   | otherwise
-                  -> [(qtvs', fdeqs)]
+                  -> [(meta_tvs, fdeqs)]
 		  	-- We could avoid this substTy stuff by producing the eqn
 		  	-- (qtvs, ls1++rs1, ls2++rs2)
 		  	-- which will re-do the ls1/ls2 unification when the equation is
@@ -409,8 +420,10 @@ checkClsFD qtvs fd clas_tvs tys1 tys2
                         -- eqType again, since we know for sure that /at least one/ 
                         -- equation in there is useful)
 
-		    qtvs' = filterVarSet (`notElemTvSubst` subst) qtvs
-		        -- qtvs' are the quantified type variables
+                    (dfun_tvs, _, _, _) = tcSplitDFunTy (idType dfun)
+		    meta_tvs = [ setVarType tv (substTy subst (varType tv))
+                               | tv <- dfun_tvs, tv `notElemTvSubst` subst ]
+		        -- meta_tvs are the quantified type variables
 		        -- that have not been substituted out
 		        --	
 		        -- Eg. 	class C a b | a -> b
@@ -418,12 +431,21 @@ checkClsFD qtvs fd clas_tvs tys1 tys2
 		        -- Given constraint C Int z
 		        -- we generate the equation
 		        --	({y}, [y], z)
+                        --
+                        -- But note (a) we get them from the dfun_id, so they are *in order*
+                        --              because the kind variables may be mentioned in the
+                        --              type variabes' kinds
+                        --          (b) we must apply 'subst' to the kinds, in case we have
+                        --              matched out a kind variable, but not a type variable
+                        --              whose kind mentions that kind variable!
+                        --          Trac #6015, #6068
   where
-    bind_fn tv | tv `elemVarSet` qtvs = BindMe
-	       | otherwise	      = Skolem
+    bind_fn tv | tv `elemVarSet` qtvs       = BindMe
+               | tv `elemVarSet` extra_qtvs = BindMe
+	       | otherwise	            = Skolem
 
-    (ltys1, rtys1) = instFD         fd clas_tvs tys1
-    (ltys2, irs2)  = instFD_WithPos fd clas_tvs tys2
+    (ltys1, rtys1) = instFD         fd clas_tvs tys_inst
+    (ltys2, irs2)  = instFD_WithPos fd clas_tvs tys_actual
 \end{code}
 
 
@@ -529,13 +551,8 @@ badFunDeps cls_insts clas ins_tv_set ins_tys
   = nubBy eq_inst $
     [ ispec | fd <- fds,	-- fds is often empty, so do this first!
 	      let trimmed_tcs = trimRoughMatchTcs clas_tvs fd rough_tcs,
-	      ispec@(ClsInst { is_tcs = inst_tcs, is_tvs = tvs, 
-				is_tys = tys }) <- cls_insts,
-		-- Filter out ones that can't possibly match, 
-		-- based on the head of the fundep
-	      not (instanceCantMatch inst_tcs trimmed_tcs),	
-	      notNull (checkClsFD (tvs `unionVarSet` ins_tv_set) 
-				   fd clas_tvs tys ins_tys)
+	      ispec <- cls_insts,
+	      notNull (checkClsFD fd clas_tvs ispec ins_tv_set ins_tys trimmed_tcs)
     ]
   where
     (clas_tvs, fds) = classTvsFds clas
diff --git a/rts/PrimOps.cmm b/rts/PrimOps.cmm
index 93ef23a71e..2ab26f7ba4 100644
--- a/rts/PrimOps.cmm
+++ b/rts/PrimOps.cmm
@@ -665,6 +665,11 @@ stg_forkOnzh
 
 stg_yieldzh
 {
+  // when we yield to the scheduler, we have to tell it to put the
+  // current thread to the back of the queue by setting the
+  // context_switch flag.  If we don't do this, it will run the same
+  // thread again.
+  Capability_context_switch(MyCapability()) = 1 :: CInt;
   jump stg_yield_noregs;
 }