X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcSMonad.lhs;h=3c1961b13a6480df31cf6aaa8bdaeece1507c104;hb=27225b0c9f799a251c96242f502e8cfd6bf76d7c;hp=a71548c912216c468b6c4b4ef11d1dc438705aa0;hpb=2b0c363dcaa51295571bc72a2fa0b72bf0ff353a;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs index a71548c..3c1961b 100644 --- a/compiler/typecheck/TcSMonad.lhs +++ b/compiler/typecheck/TcSMonad.lhs @@ -10,7 +10,7 @@ module TcSMonad ( makeGivens, makeSolved, CtFlavor (..), isWanted, isGiven, isDerived, canRewrite, - joinFlavors, mkGivenFlavor, + combineCtLoc, mkGivenFlavor, TcS, runTcS, failTcS, panicTcS, traceTcS, traceTcS0, -- Basic functionality tryTcS, nestImplicTcS, wrapErrTcS, wrapWarnTcS, @@ -30,7 +30,7 @@ module TcSMonad ( newTcEvBindsTcS, getInstEnvs, getFamInstEnvs, -- Getting the environments - getTopEnv, getGblEnv, getTcEvBinds, getUntouchablesTcS, + getTopEnv, getGblEnv, getTcEvBinds, getUntouchables, getTcEvBindsBag, getTcSContext, getTcSTyBinds, getTcSTyBindsMap, @@ -100,7 +100,6 @@ import FunDeps import TcRnTypes -import Control.Monad import Data.IORef \end{code} @@ -298,12 +297,13 @@ canRewrite (Derived {}) (Derived {}) = True canRewrite (Wanted {}) (Wanted {}) = True canRewrite _ _ = False -joinFlavors :: CtFlavor -> CtFlavor -> CtFlavor -joinFlavors (Wanted loc) _ = Wanted loc -joinFlavors _ (Wanted loc) = Wanted loc -joinFlavors (Derived loc) _ = Derived loc -joinFlavors _ (Derived loc) = Derived loc -joinFlavors (Given loc) _ = Given loc +combineCtLoc :: CtFlavor -> CtFlavor -> WantedLoc +-- Precondition: At least one of them should be wanted +combineCtLoc (Wanted loc) _ = loc +combineCtLoc _ (Wanted loc) = loc +combineCtLoc (Derived loc) _ = loc +combineCtLoc _ (Derived loc) = loc +combineCtLoc _ _ = panic "combineCtLoc: both given" mkGivenFlavor :: CtFlavor -> SkolemInfo -> CtFlavor mkGivenFlavor (Wanted loc) sk = Given (setCtLocOrigin loc sk) @@ -340,7 +340,9 @@ data TcSEnv tcs_ty_binds :: IORef (TyVarEnv (TcTyVar, TcType)), -- Global type bindings - tcs_context :: SimplContext + tcs_context :: SimplContext, + + tcs_untch :: Untouchables } data SimplContext @@ -412,7 +414,7 @@ traceTcS0 :: String -> SDoc -> TcS () traceTcS0 herald doc = TcS $ \_env -> TcM.traceTcN 0 herald doc runTcS :: SimplContext - -> TcTyVarSet -- Untouchables + -> Untouchables -- Untouchables -> TcS a -- What to run -> TcM (a, Bag EvBind) runTcS context untouch tcs @@ -420,10 +422,11 @@ runTcS context untouch tcs ; ev_binds_var@(EvBindsVar evb_ref _) <- TcM.newTcEvBinds ; let env = TcSEnv { tcs_ev_binds = ev_binds_var , tcs_ty_binds = ty_binds_var - , tcs_context = context } + , tcs_context = context + , tcs_untch = untouch } -- Run the computation - ; res <- TcM.setUntouchables untouch (unTcS tcs env) + ; res <- unTcS tcs env -- Perform the type unifications required ; ty_binds <- TcM.readTcRef ty_binds_var @@ -436,30 +439,31 @@ runTcS context untouch tcs do_unification (tv,ty) = TcM.writeMetaTyVar tv ty -nestImplicTcS :: EvBindsVar -> TcTyVarSet -> TcS a -> TcS a -nestImplicTcS ref untouch tcs +nestImplicTcS :: EvBindsVar -> Untouchables -> TcS a -> TcS a +nestImplicTcS ref untch (TcS thing_inside) = TcS $ \ TcSEnv { tcs_ty_binds = ty_binds, tcs_context = ctxt } -> let nest_env = TcSEnv { tcs_ev_binds = ref , tcs_ty_binds = ty_binds - , tcs_context = ctxtUnderImplic ctxt } + , tcs_untch = untch + , tcs_context = ctxtUnderImplic ctxt } in - TcM.setUntouchables untouch (unTcS tcs nest_env) + thing_inside nest_env ctxtUnderImplic :: SimplContext -> SimplContext -- See Note [Simplifying RULE lhs constraints] in TcSimplify ctxtUnderImplic SimplRuleLhs = SimplCheck ctxtUnderImplic ctxt = ctxt -tryTcS :: TcTyVarSet -> TcS a -> TcS a +tryTcS :: TcS a -> TcS a -- Like runTcS, but from within the TcS monad -- Ignore all the evidence generated, and do not affect caller's evidence! -tryTcS untch tcs +tryTcS tcs = TcS (\env -> do { ty_binds_var <- TcM.newTcRef emptyVarEnv ; ev_binds_var <- TcM.newTcEvBinds ; let env1 = env { tcs_ev_binds = ev_binds_var , tcs_ty_binds = ty_binds_var } - ; TcM.setUntouchables untch (unTcS tcs env1) }) + ; unTcS tcs env1 }) -- Update TcEvBinds -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -473,6 +477,9 @@ getTcSContext = TcS (return . tcs_context) getTcEvBinds :: TcS EvBindsVar getTcEvBinds = TcS (return . tcs_ev_binds) +getUntouchables :: TcS Untouchables +getUntouchables = TcS (return . tcs_untch) + getTcSTyBinds :: TcS (IORef (TyVarEnv (TcTyVar, TcType))) getTcSTyBinds = TcS (return . tcs_ty_binds) @@ -543,9 +550,6 @@ getTopEnv = wrapTcS $ TcM.getTopEnv getGblEnv :: TcS TcGblEnv getGblEnv = wrapTcS $ TcM.getGblEnv -getUntouchablesTcS :: TcS TcTyVarSet -getUntouchablesTcS = wrapTcS $ TcM.getUntouchables - -- Various smaller utilities [TODO, maybe will be absorbed in the instance matcher] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -562,40 +566,58 @@ pprEq :: TcType -> TcType -> SDoc pprEq ty1 ty2 = pprPred $ mkEqPred (ty1,ty2) isTouchableMetaTyVar :: TcTyVar -> TcS Bool --- is touchable variable! -isTouchableMetaTyVar v - | isMetaTyVar v = wrapTcS $ do { untch <- TcM.isUntouchable v; - ; return (not untch) } - | otherwise = return False +isTouchableMetaTyVar tv + = case tcTyVarDetails tv of + MetaTv TcsTv _ -> return True -- See Note [Touchable meta type variables] + MetaTv {} -> do { untch <- getUntouchables + ; return (inTouchableRange untch tv) } + _ -> return False +\end{code} + +Note [Touchable meta type variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Meta type variables allocated *by the constraint solver itself* are always +touchable. Example: + instance C a b => D [a] where... +if we use this instance declaration we "make up" a fresh meta type +variable for 'b', which we must later guess. (Perhaps C has a +functional dependency.) But since we aren't in the constraint *generator* +we can't allocate a Unique in the touchable range for this implication +constraint. Instead, we mark it as a "TcsTv", which makes it always-touchable. +\begin{code} -- Flatten skolems -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ newFlattenSkolemTy :: TcType -> TcS TcType newFlattenSkolemTy ty = mkTyVarTy <$> newFlattenSkolemTyVar ty - where newFlattenSkolemTyVar :: TcType -> TcS TcTyVar - newFlattenSkolemTyVar ty - = wrapTcS $ do { uniq <- TcM.newUnique - ; let name = mkSysTvName uniq (fsLit "f") - ; return $ - mkTcTyVar name (typeKind ty) (FlatSkol ty) - } + +newFlattenSkolemTyVar :: TcType -> TcS TcTyVar +newFlattenSkolemTyVar ty + = wrapTcS $ do { uniq <- TcM.newUnique + ; let name = mkSysTvName uniq (fsLit "f") + ; return $ mkTcTyVar name (typeKind ty) (FlatSkol ty) } -- Instantiations -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ instDFunTypes :: [Either TyVar TcType] -> TcS [TcType] -instDFunTypes mb_inst_tys = - let inst_tv :: Either TyVar TcType -> TcS Type - inst_tv (Left tv) = wrapTcS $ TcM.tcInstTyVar tv >>= return . mkTyVarTy - inst_tv (Right ty) = return ty - in mapM inst_tv mb_inst_tys - +instDFunTypes mb_inst_tys + = mapM inst_tv mb_inst_tys + where + inst_tv :: Either TyVar TcType -> TcS Type + inst_tv (Left tv) = mkTyVarTy <$> newFlexiTcS tv + inst_tv (Right ty) = return ty instDFunConstraints :: TcThetaType -> TcS [EvVar] instDFunConstraints preds = wrapTcS $ TcM.newWantedEvVars preds +newFlexiTcS :: TyVar -> TcS TcTyVar +-- Make a TcsTv meta tyvar; it is always touchable, +-- but we are supposed to guess its instantiation +-- See Note [Touchable meta type variables] +newFlexiTcS tv = wrapTcS $ TcM.instMetaTyVar TcsTv tv -- Superclasses and recursive dictionaries -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -796,11 +818,13 @@ mkWantedFunDepEqns loc eqns where to_work_item :: (Equation, (PredType,SDoc), (PredType,SDoc)) -> TcS [WantedEvVar] to_work_item ((qtvs, pairs), _, _) - = do { (_, _, tenv) <- wrapTcS $ TcM.tcInstTyVars (varSetElems qtvs) - ; mapM (do_one tenv) pairs } + = do { let tvs = varSetElems qtvs + ; tvs' <- mapM newFlexiTcS tvs + ; let subst = zipTopTvSubst tvs (mkTyVarTys tvs') + ; mapM (do_one subst) pairs } - do_one tenv (ty1, ty2) = do { let sty1 = substTy tenv ty1 - sty2 = substTy tenv ty2 + do_one subst (ty1, ty2) = do { let sty1 = substTy subst ty1 + sty2 = substTy subst ty2 ; ev <- newWantedCoVar sty1 sty2 ; return (WantedEvVar ev loc) }