X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcUnify.lhs;h=ade2db0d4935692b3334cb8f2a492a2ee553d77a;hb=14a496fd0b3aa821b69eb02736d5f41086576761;hp=2b9838bcc7ed3421608f69bebaddcee1329e9486;hpb=67ed735fab12c12a1d48878d7bda33588c67fb78;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcUnify.lhs b/compiler/typecheck/TcUnify.lhs index 2b9838b..ade2db0 100644 --- a/compiler/typecheck/TcUnify.lhs +++ b/compiler/typecheck/TcUnify.lhs @@ -30,7 +30,6 @@ import TypeRep import TcErrors ( typeExtraInfoMsg, unifyCtxt ) import TcMType -import TcEnv import TcIface import TcRnMonad import TcType @@ -305,9 +304,8 @@ tcSubType :: CtOrigin -> SkolemInfo -> TcSigmaType -> TcSigmaType -> TcM HsWrapp -- Returns a wrapper of shape ty_actual ~ ty_expected tcSubType origin skol_info ty_actual ty_expected | isSigmaTy ty_actual - = do { let extra_tvs = tyVarsOfType ty_actual - ; (sk_wrap, inst_wrap) - <- tcGen skol_info extra_tvs ty_expected $ \ _ sk_rho -> do + = do { (sk_wrap, inst_wrap) + <- tcGen skol_info ty_expected $ \ _ sk_rho -> do { (in_wrap, in_rho) <- deeplyInstantiate origin ty_actual ; coi <- unifyType in_rho sk_rho ; return (coiToHsWrapper coi <.> in_wrap) } @@ -355,14 +353,14 @@ wrapFunResCoercion arg_tys co_fn_res %************************************************************************ \begin{code} -tcGen :: SkolemInfo -> TcTyVarSet -> TcType +tcGen :: SkolemInfo -> TcType -> ([TcTyVar] -> TcRhoType -> TcM result) -> TcM (HsWrapper, result) -- The expression has type: spec_ty -> expected_ty -tcGen skol_info extra_tvs - expected_ty thing_inside -- We expect expected_ty to be a forall-type - -- If not, the call is a no-op +tcGen skol_info expected_ty thing_inside + -- We expect expected_ty to be a forall-type + -- If not, the call is a no-op = do { traceTc "tcGen" empty ; (wrap, tvs', given, rho') <- deeplySkolemise skol_info expected_ty @@ -371,7 +369,7 @@ tcGen skol_info extra_tvs text "expected_ty" <+> ppr expected_ty, text "inst ty" <+> ppr tvs' <+> ppr rho' ] - -- In 'free_tvs' we must check that the "forall_tvs" havn't been constrained + -- Generally we must check that the "forall_tvs" havn't been constrained -- The interesting bit here is that we must include the free variables -- of the expected_ty. Here's an example: -- runST (newVar True) @@ -379,10 +377,12 @@ tcGen skol_info extra_tvs -- for (newVar True), with s fresh. Then we unify with the runST's arg type -- forall s'. ST s' a. That unifies s' with s, and a with MutVar s Bool. -- So now s' isn't unconstrained because it's linked to a. - -- Conclusion: pass the free vars of the expected_ty to checkConsraints - ; let free_tvs = tyVarsOfType expected_ty `unionVarSet` extra_tvs + -- + -- However [Oct 10] now that the untouchables are a range of + -- TcTyVars, all tihs is handled automatically with no need for + -- extra faffing around - ; (ev_binds, result) <- checkConstraints skol_info free_tvs tvs' given $ + ; (ev_binds, result) <- checkConstraints skol_info tvs' given $ thing_inside tvs' rho' ; return (wrap <.> mkWpLet ev_binds, result) } @@ -390,38 +390,32 @@ tcGen skol_info extra_tvs -- often empty, in which case mkWpLet is a no-op checkConstraints :: SkolemInfo - -> TcTyVarSet -- Free variables (other than the type envt) - -- for the skolem escape check -> [TcTyVar] -- Skolems -> [EvVar] -- Given -> TcM result -> TcM (TcEvBinds, result) -checkConstraints skol_info free_tvs skol_tvs given thing_inside +checkConstraints skol_info skol_tvs given thing_inside | null skol_tvs && null given = do { res <- thing_inside; return (emptyTcEvBinds, res) } -- Just for efficiency. We check every function argument with -- tcPolyExpr, which uses tcGen and hence checkConstraints. | otherwise - = do { (ev_binds, wanted, result) <- newImplication skol_info free_tvs + = do { (ev_binds, wanted, result) <- newImplication skol_info skol_tvs given thing_inside ; emitConstraints wanted ; return (ev_binds, result) } -newImplication :: SkolemInfo -> TcTyVarSet -> [TcTyVar] +newImplication :: SkolemInfo -> [TcTyVar] -> [EvVar] -> TcM result -> TcM (TcEvBinds, WantedConstraints, result) -newImplication skol_info free_tvs skol_tvs given thing_inside +newImplication skol_info skol_tvs given thing_inside = ASSERT2( all isTcTyVar skol_tvs, ppr skol_tvs ) ASSERT2( all isSkolemTyVar skol_tvs, ppr skol_tvs ) - do { gbl_tvs <- tcGetGlobalTyVars - ; free_tvs <- zonkTcTyVarsAndFV free_tvs - ; let untch = gbl_tvs `unionVarSet` free_tvs - - ; (result, wanted) <- getConstraints $ - setUntouchables untch $ - thing_inside + do { ((result, untch), wanted) <- captureConstraints $ + captureUntouchables $ + thing_inside ; if isEmptyBag wanted && not (hasEqualities given) -- Optimisation : if there are no wanteds, and the givens @@ -619,7 +613,6 @@ uType_np origin orig_ty1 orig_ty2 go _ ty1 ty2 | tcIsForAllTy ty1 || tcIsForAllTy ty2 -{-- | isSigmaTy ty1 || isSigmaTy ty2 --} = unifySigmaTy origin ty1 ty2 -- Anything else fails @@ -636,12 +629,11 @@ unifySigmaTy origin ty1 ty2 in_scope = mkInScopeSet (mkVarSet skol_tvs) phi1 = substTy (mkTvSubst in_scope (zipTyEnv tvs1 tys)) body1 phi2 = substTy (mkTvSubst in_scope (zipTyEnv tvs2 tys)) body2 - untch = tyVarsOfType ty1 `unionVarSet` tyVarsOfType ty2 - - ; (coi, lie) <- getConstraints $ - setUntouchables untch $ - uType origin phi1 phi2 +-- untch = tyVarsOfType ty1 `unionVarSet` tyVarsOfType ty2 + ; ((coi, _untch), lie) <- captureConstraints $ + captureUntouchables $ + uType origin phi1 phi2 -- Check for escape; e.g. (forall a. a->b) ~ (forall a. a->a) ; let bad_lie = filterBag is_bad lie is_bad w = any (`elemVarSet` tyVarsOfWanted w) skol_tvs