X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcUnify.lhs;h=e00c8ef105f646470454986c2106a194e907bc6c;hb=49ea1fa53acd2569b0b74c86a981b0d3779515dd;hp=23cc9e21760724b982b42322863af6001fe1b13b;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcUnify.lhs b/compiler/typecheck/TcUnify.lhs
index 23cc9e2..e00c8ef 100644
--- a/compiler/typecheck/TcUnify.lhs
+++ b/compiler/typecheck/TcUnify.lhs
@@ -32,14 +32,14 @@ import TcMType		( lookupTcTyVar, LookupTyVarResult(..),
                           tcInstSkolType, newKindVar, newMetaTyVar,
 			  tcInstBoxy, newBoxyTyVar, newBoxyTyVarTys, readFilledBox, 
 			  readMetaTyVar, writeMetaTyVar, newFlexiTyVarTy,
-			  tcInstSkolTyVars, 
+			  tcInstSkolTyVars, tcInstTyVar,
 			  zonkTcKind, zonkType, zonkTcType,  zonkTcTyVarsAndFV, 
 			  readKindVar, writeKindVar )
 import TcSimplify	( tcSimplifyCheck )
 import TcEnv		( tcGetGlobalTyVars, findGlobals )
 import TcIface		( checkWiredInTyCon )
 import TcRnMonad         -- TcType, amongst others
-import TcType		( TcKind, TcType, TcTyVar, TcTauType,
+import TcType		( TcKind, TcType, TcTyVar, BoxyTyVar, TcTauType,
 			  BoxySigmaType, BoxyRhoType, BoxyType, 
 			  TcTyVarSet, TcThetaType, TcTyVarDetails(..), BoxInfo(..), 
 			  SkolemInfo( GenSkol, UnkSkol ), MetaDetails(..), isImmutableTyVar,
@@ -53,7 +53,8 @@ import TcType		( TcKind, TcType, TcTyVar, TcTauType,
 			  TvSubst, mkTvSubst, zipTyEnv, substTy, emptyTvSubst, 
 			  lookupTyVar, extendTvSubst )
 import Kind		( Kind(..), SimpleKind, KindVar, isArgTypeKind,
-			  openTypeKind, liftedTypeKind, mkArrowKind, defaultKind,
+			  openTypeKind, liftedTypeKind, unliftedTypeKind, 
+			  mkArrowKind, defaultKind,
 			  isOpenTypeKind, argTypeKind, isLiftedTypeKind, isUnliftedTypeKind,
 			  isSubKind, pprKind, splitKindFunTys )
 import TysPrim		( alphaTy, betaTy )
@@ -1079,13 +1080,18 @@ uUnfilledVars outer swapped tv1 (MetaTv info1 ref1) tv2 (MetaTv info2 ref2)
     update_tv1 = updateMeta tv1 ref1 (mkTyVarTy tv2)
     update_tv2 = updateMeta tv2 ref2 (mkTyVarTy tv1)
 
-    box_meets_box | k1_sub_k2 = fill_with k1
-		  | k2_sub_k1 = fill_with k2
+    box_meets_box | k1_sub_k2 = if k2_sub_k1 && nicer_to_update_tv1
+				then fill_from tv2
+				else fill_from tv1
+		  | k2_sub_k1 = fill_from tv2
 		  | otherwise = kind_err
 
-    fill_with kind = do { tau_ty <- newFlexiTyVarTy kind
-		        ; updateMeta tv1 ref1 tau_ty
-		        ; updateMeta tv2 ref2 tau_ty }
+	-- Update *both* tyvars with a TauTv whose name and kind
+	-- are gotten from tv (avoid losing nice names is poss)
+    fill_from tv = do { tv' <- tcInstTyVar tv
+		      ; let tau_ty = mkTyVarTy tv'
+		      ; updateMeta tv1 ref1 tau_ty
+		      ; updateMeta tv2 ref2 tau_ty }
 
     kind_err = addErrCtxtM (unifyKindCtxt swapped tv1 (mkTyVarTy tv2))	$
 	       unifyKindMisMatch k1 k2
@@ -1181,9 +1187,7 @@ checkTauTvUpdate orig_tv orig_ty
 	     ; case cts of
 		  Indirect ty -> go ty 
 		  Flexi -> case box of
-				BoxTv -> do { tau <- newFlexiTyVarTy (tyVarKind tv)
-				   	    ; writeMutVar ref (Indirect tau)
-					    ; return tau }
+				BoxTv -> fillBoxWithTau tv ref
 				other -> return (TyVarTy tv)
 	     }
 
@@ -1201,6 +1205,19 @@ checkTauTvUpdate orig_tv orig_ty
 					(tcView (TyConApp tc tys)))
 				-- Try again, expanding the synonym
 	     }
+
+fillBoxWithTau :: BoxyTyVar -> IORef MetaDetails -> TcM TcType
+-- (fillBoxWithTau tv ref) fills ref with a freshly allocated 
+--  tau-type meta-variable, whose print-name is the same as tv
+-- Choosing the same name is good: when we instantiate a function
+-- we allocate boxy tyvars with the same print-name as the quantified
+-- tyvar; and then we often fill the box with a tau-tyvar, and again
+-- we want to choose the same name.
+fillBoxWithTau tv ref 
+  = do	{ tv' <- tcInstTyVar tv		-- Do not gratuitously forget
+	; let tau = mkTyVarTy tv'	-- name of the type variable
+	; writeMutVar ref (Indirect tau)
+	; return tau }
 \end{code}
 
 Note [Type synonyms and the occur check]
@@ -1271,13 +1288,11 @@ unBox (TyVarTy tv)
   , MetaTv BoxTv ref <- tcTyVarDetails tv	-- NB: non-TcTyVars are possible
   = do	{ cts <- readMutVar ref			--     under nested quantifiers
 	; case cts of
+	    Flexi	-> fillBoxWithTau tv ref
 	    Indirect ty -> do { non_boxy_ty <- unBox ty
 			      ; if isTauTy non_boxy_ty 
 				then return non_boxy_ty
 				else notMonoType non_boxy_ty }
-	    Flexi -> do { tau <- newFlexiTyVarTy (tyVarKind tv)
-			; writeMutVar ref (Indirect tau)
-			; return tau }
 	}
   | otherwise 	-- Skolems, and meta-tau-variables
   = return (TyVarTy tv)
@@ -1490,6 +1505,7 @@ kindSimpleKind orig_swapped orig_kind
     go True OpenTypeKind = return liftedTypeKind
     go True ArgTypeKind  = return liftedTypeKind
     go sw LiftedTypeKind  = return liftedTypeKind
+    go sw UnliftedTypeKind = return unliftedTypeKind
     go sw k@(KindVar _)	  = return k	-- KindVars are always simple
     go swapped kind = failWithTc (ptext SLIT("Unexpected kind unification failure:")
 				  <+> ppr orig_swapped <+> ppr orig_kind)