X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcRnTypes.lhs;h=4abb40836f0f936b6b6a037d789e1757e32f5225;hp=fce06d14f7cd0ea12c67963358dc0e5243159224;hb=b10d7d079ec9c3fc22d4700fe484dd297bddb805;hpb=e8fa04cf0d656c4a2ff737278b8cea9fce3b5a2b

diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs
index fce06d1..4abb408 100644
--- a/compiler/typecheck/TcRnTypes.lhs
+++ b/compiler/typecheck/TcRnTypes.lhs
@@ -28,7 +28,7 @@ module TcRnTypes(
 	ArrowCtxt(NoArrowCtxt), newArrowScope, escapeArrowScope,
 
 	-- Constraints
-        Untouchables,
+        Untouchables(..), inTouchableRange, isNoUntouchables,
   	WantedConstraints, emptyWanteds, andWanteds, extendWanteds,
 	WantedConstraint(..), WantedEvVar(..), wantedEvVarLoc, 
         wantedEvVarToVar, wantedEvVarPred, splitWanteds,
@@ -68,11 +68,12 @@ import NameSet
 import Var
 import VarEnv
 import Module
-import UniqFM
 import SrcLoc
 import VarSet
 import ErrUtils
+import UniqFM
 import UniqSupply
+import Unique
 import BasicTypes
 import Bag
 import Outputable
@@ -257,6 +258,7 @@ data TcGblEnv
         tcg_ev_binds  :: Bag EvBind,	    -- Top-level evidence bindings
 	tcg_binds     :: LHsBinds Id,	    -- Value bindings in this module
         tcg_sigs      :: NameSet, 	    -- ...Top-level names that *lack* a signature
+        tcg_imp_specs :: [LTcSpecPrag],     -- ...SPECIALISE prags for imported Ids
 	tcg_warns     :: Warnings,	    -- ...Warnings and deprecations
 	tcg_anns      :: [Annotation],      -- ...Annotations
 	tcg_insts     :: [Instance],	    -- ...Instances
@@ -382,7 +384,13 @@ data TcLclEnv		-- Changes as we move inside an expression
                         -- Why mutable? see notes with tcGetGlobalTyVars
 
 	tcl_lie   :: TcRef WantedConstraints,    -- Place to accumulate type constraints
-	tcl_untch :: Untouchables		 -- Untouchables
+
+	-- TcMetaTyVars have 
+	tcl_meta  :: TcRef Unique,  -- The next free unique for TcMetaTyVars
+		     		    -- Guaranteed to be allocated linearly
+	tcl_untch :: Unique	    -- Any TcMetaTyVar with 
+		     		    --     unique >= tcl_untch is touchable
+		     		    --     unique <  tcl_untch is untouchable
     }
 
 type TcTypeEnv = NameEnv TcTyThing
@@ -677,7 +685,29 @@ instance Outputable WhereFrom where
 v%************************************************************************
 
 \begin{code}
-type Untouchables = TcTyVarSet	-- All MetaTyVars
+data Untouchables = NoUntouchables
+                  | TouchableRange
+                          Unique  -- Low end
+                          Unique  -- High end
+ -- A TcMetaTyvar is *touchable* iff its unique u satisfies
+ --   u >= low
+ --   u < high
+
+instance Outputable Untouchables where
+  ppr NoUntouchables = ptext (sLit "No untouchables")
+  ppr (TouchableRange low high) = ptext (sLit "Touchable range:") <+> 
+                                  ppr low <+> char '-' <+> ppr high
+
+isNoUntouchables :: Untouchables -> Bool
+isNoUntouchables NoUntouchables      = True
+isNoUntouchables (TouchableRange {}) = False
+
+inTouchableRange :: Untouchables -> TcTyVar -> Bool
+inTouchableRange NoUntouchables _ = True
+inTouchableRange (TouchableRange low high) tv 
+  = uniq >= low && uniq < high
+  where
+    uniq = varUnique tv
 
 type WantedConstraints = Bag WantedConstraint
 
@@ -703,11 +733,11 @@ type GivenLoc  = CtLoc SkolemInfo
 
 data Implication
   = Implic {  
-      ic_env_tvs :: Untouchables, -- Untouchables: unification variables
+      ic_untch :: Untouchables, -- Untouchables: unification variables
                                   -- free in the environment
-      ic_env     :: TcTypeEnv,    -- The type environment
+      ic_env   :: TcTypeEnv,    -- The type environment
       		      	      	  -- Used only when generating error messages
-	  -- Generally, ic_env_tvs = tvsof(ic_env)
+	  -- Generally, ic_untch is a superset of tvsof(ic_env)
 	  -- However, we don't zonk ic_env when zonking the Implication
 	  -- Instead we do that when generating a skolem-escape error message
 
@@ -813,10 +843,10 @@ pprWantedEvVarWithLoc (WantedEvVar v loc) = hang (pprEvVarWithType v)
 pprWantedEvVar        (WantedEvVar v _)   = pprEvVarWithType v
 
 instance Outputable Implication where
-  ppr (Implic { ic_env_tvs = env_tvs, ic_skols = skols, ic_given = given
+  ppr (Implic { ic_untch = untch, ic_skols = skols, ic_given = given
               , ic_wanted = wanted, ic_binds = binds, ic_loc = loc })
    = ptext (sLit "Implic") <+> braces 
-     (sep [ ptext (sLit "Untouchables = ") <+> ppr env_tvs
+     (sep [ ptext (sLit "Untouchables = ") <+> ppr untch
           , ptext (sLit "Skolems = ") <+> ppr skols
           , ptext (sLit "Given = ") <+> pprEvVars given
           , ptext (sLit "Wanted = ") <+> ppr wanted