X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcHsSyn.lhs;h=074ab39537e08f7fe739965ac54fdf946277699b;hb=d2ce0f52d42edf32bb9f13796e6ba6edba8bd516;hp=170834997a4d6a3eac4dda45c20cfd735d8547a0;hpb=0084ab49ab3c0123c4b7f9523d092af45bccfd41;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs index 1708349..074ab39 100644 --- a/compiler/typecheck/TcHsSyn.lhs +++ b/compiler/typecheck/TcHsSyn.lhs @@ -1,4 +1,4 @@ -% +1% % (c) The University of Glasgow 2006 % (c) The AQUA Project, Glasgow University, 1996-1998 % @@ -17,7 +17,7 @@ module TcHsSyn ( shortCutLit, hsOverLitName, -- re-exported from TcMonad - TcId, TcIdSet, TcDictBinds, + TcId, TcIdSet, zonkTopDecls, zonkTopExpr, zonkTopLExpr, zonkId, zonkTopBndrs @@ -46,7 +46,6 @@ import Literal import BasicTypes import Maybes import SrcLoc -import Util import Bag import Outputable \end{code} @@ -56,9 +55,6 @@ import Outputable thenM :: Monad a => a b -> (b -> a c) -> a c thenM = (>>=) -thenM_ :: Monad a => a b -> a c -> a c -thenM_ = (>>) - returnM :: Monad m => a -> m a returnM = return @@ -181,18 +177,21 @@ the environment manipulation is tiresome. \begin{code} data ZonkEnv = ZonkEnv (TcType -> TcM Type) -- How to zonk a type - (IdEnv Id) -- What variables are in scope - -- Maps an Id to its zonked version; both have the same Name + (VarEnv Var) -- What variables are in scope + -- Maps an Id or EvVar to its zonked version; both have the same Name + -- Note that all evidence (coercion variables as well as dictionaries) + -- are kept in the ZonkEnv + -- Only *type* abstraction is done by side effect -- Is only consulted lazily; hence knot-tying emptyZonkEnv :: ZonkEnv emptyZonkEnv = ZonkEnv zonkTypeZapping emptyVarEnv -extendZonkEnv :: ZonkEnv -> [Id] -> ZonkEnv +extendZonkEnv :: ZonkEnv -> [Var] -> ZonkEnv extendZonkEnv (ZonkEnv zonk_ty env) ids = ZonkEnv zonk_ty (extendVarEnvList env [(id,id) | id <- ids]) -extendZonkEnv1 :: ZonkEnv -> Id -> ZonkEnv +extendZonkEnv1 :: ZonkEnv -> Var -> ZonkEnv extendZonkEnv1 (ZonkEnv zonk_ty env) id = ZonkEnv zonk_ty (extendVarEnv env id id) @@ -235,27 +234,27 @@ zonkIdBndr env id zonkIdBndrs :: ZonkEnv -> [TcId] -> TcM [Id] zonkIdBndrs env ids = mappM (zonkIdBndr env) ids -zonkDictBndrs :: ZonkEnv -> [Var] -> TcM [Var] --- "Dictionary" binders can be coercion variables or dictionary variables -zonkDictBndrs env ids = mappM (zonkDictBndr env) ids - -zonkDictBndr :: ZonkEnv -> Var -> TcM Var -zonkDictBndr env var | isTyVar var = zonkTyVarBndr env var - | otherwise = zonkIdBndr env var - zonkTopBndrs :: [TcId] -> TcM [Id] zonkTopBndrs ids = zonkIdBndrs emptyZonkEnv ids --- Zonk the kind of a non-TC tyvar in case it is a coercion variable (their --- kind contains types). --- -zonkTyVarBndr :: ZonkEnv -> TyVar -> TcM TyVar -zonkTyVarBndr env tv - | isCoVar tv - = do { kind <- zonkTcTypeToType env (tyVarKind tv) - ; return $ setTyVarKind tv kind - } - | otherwise = return tv +zonkEvBndrsX :: ZonkEnv -> [EvVar] -> TcM (ZonkEnv, [Var]) +zonkEvBndrsX = mapAccumLM zonkEvBndrX + +zonkEvBndrX :: ZonkEnv -> EvVar -> TcM (ZonkEnv, EvVar) +-- Works for dictionaries and coercions +zonkEvBndrX env var + = do { var' <- zonkEvBndr env var + ; return (extendZonkEnv1 env var', var') } + +zonkEvBndr :: ZonkEnv -> EvVar -> TcM EvVar +-- Works for dictionaries and coercions +-- Does not extend the ZonkEnv +zonkEvBndr env var + = do { ty' <- zonkTcTypeToType env (varType var) + ; return (setVarType var ty') } + +zonkEvVarOcc :: ZonkEnv -> EvVar -> EvVar +zonkEvVarOcc env v = zonkIdOcc env v \end{code} @@ -266,17 +265,20 @@ zonkTopExpr e = zonkExpr emptyZonkEnv e zonkTopLExpr :: LHsExpr TcId -> TcM (LHsExpr Id) zonkTopLExpr e = zonkLExpr emptyZonkEnv e -zonkTopDecls :: LHsBinds TcId -> [LRuleDecl TcId] -> [LForeignDecl TcId] +zonkTopDecls :: Bag EvBind -> LHsBinds TcId -> [LRuleDecl TcId] -> [LForeignDecl TcId] -> TcM ([Id], + Bag EvBind, Bag (LHsBind Id), [LForeignDecl Id], [LRuleDecl Id]) -zonkTopDecls binds rules fords - = do { (env, binds') <- zonkRecMonoBinds emptyZonkEnv binds +zonkTopDecls ev_binds binds rules fords + = do { (env1, ev_binds') <- zonkEvBinds emptyZonkEnv ev_binds + + ; (env2, binds') <- zonkRecMonoBinds env1 binds -- Top level is implicitly recursive - ; rules' <- zonkRules env rules - ; fords' <- zonkForeignExports env fords - ; return (zonkEnvIds env, binds', fords', rules') } + ; rules' <- zonkRules env2 rules + ; fords' <- zonkForeignExports env2 fords + ; return (zonkEnvIds env2, ev_binds', binds', fords', rules') } --------------------------------------------- zonkLocalBinds :: ZonkEnv -> HsLocalBinds TcId -> TcM (ZonkEnv, HsLocalBinds Id) @@ -292,7 +294,7 @@ zonkLocalBinds env (HsIPBinds (IPBinds binds dict_binds)) let env1 = extendZonkEnv env [ipNameName n | L _ (IPBind n _) <- new_binds] in - zonkRecMonoBinds env1 dict_binds `thenM` \ (env2, new_dict_binds) -> + zonkTcEvBinds env1 dict_binds `thenM` \ (env2, new_dict_binds) -> returnM (env2, HsIPBinds (IPBinds new_binds new_dict_binds)) where zonk_ip_bind (IPBind n e) @@ -338,37 +340,38 @@ zonk_bind env (VarBind { var_id = var, var_rhs = expr, var_inline = inl }) zonkLExpr env expr `thenM` \ new_expr -> returnM (VarBind { var_id = new_var, var_rhs = new_expr, var_inline = inl }) -zonk_bind env bind@(FunBind { fun_id = var, fun_matches = ms, fun_co_fn = co_fn }) +zonk_bind env bind@(FunBind { fun_id = var, fun_matches = ms + , fun_co_fn = co_fn }) = wrapLocM (zonkIdBndr env) var `thenM` \ new_var -> zonkCoFn env co_fn `thenM` \ (env1, new_co_fn) -> zonkMatchGroup env1 ms `thenM` \ new_ms -> - returnM (bind { fun_id = new_var, fun_matches = new_ms, fun_co_fn = new_co_fn }) + returnM (bind { fun_id = new_var, fun_matches = new_ms + , fun_co_fn = new_co_fn }) -zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_dicts = dicts, +zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs, abs_ev_binds = ev_binds, abs_exports = exports, abs_binds = val_binds }) = ASSERT( all isImmutableTyVar tyvars ) - zonkDictBndrs env dicts `thenM` \ new_dicts -> - fixM (\ ~(new_val_binds, _) -> - let - env1 = extendZonkEnv env new_dicts - env2 = extendZonkEnv env1 (collectHsBindsBinders new_val_binds) - in - zonkMonoBinds env2 val_binds `thenM` \ new_val_binds -> - mappM (zonkExport env2) exports `thenM` \ new_exports -> - returnM (new_val_binds, new_exports) - ) `thenM` \ (new_val_bind, new_exports) -> - returnM (AbsBinds { abs_tvs = tyvars, abs_dicts = new_dicts, - abs_exports = new_exports, abs_binds = new_val_bind }) + do { (env1, new_evs) <- zonkEvBndrsX env evs + ; (env2, new_ev_binds) <- zonkTcEvBinds env1 ev_binds + ; (new_val_bind, new_exports) <- fixM $ \ ~(new_val_binds, _) -> + do { let env3 = extendZonkEnv env2 (collectHsBindsBinders new_val_binds) + ; new_val_binds <- zonkMonoBinds env3 val_binds + ; new_exports <- mapM (zonkExport env3) exports + ; return (new_val_binds, new_exports) } + ; return (AbsBinds { abs_tvs = tyvars, abs_ev_vars = new_evs, abs_ev_binds = new_ev_binds + , abs_exports = new_exports, abs_binds = new_val_bind }) } where zonkExport env (tyvars, global, local, prags) -- The tyvars are already zonked = zonkIdBndr env global `thenM` \ new_global -> - zonk_prags prags `thenM` \ new_prags -> + zonkSpecPrags env prags `thenM` \ new_prags -> returnM (tyvars, new_global, zonkIdOcc env local, new_prags) - zonk_prags IsDefaultMethod = return IsDefaultMethod - zonk_prags (SpecPrags ps) = do { ps' <- mapM zonk_prag ps; return (SpecPrags ps') } - +zonkSpecPrags :: ZonkEnv -> TcSpecPrags -> TcM TcSpecPrags +zonkSpecPrags _ IsDefaultMethod = return IsDefaultMethod +zonkSpecPrags env (SpecPrags ps) = do { ps' <- mapM zonk_prag ps + ; return (SpecPrags ps') } + where zonk_prag (L loc (SpecPrag co_fn inl)) = do { (_, co_fn') <- zonkCoFn env co_fn ; return (L loc (SpecPrag co_fn' inl)) } @@ -510,8 +513,8 @@ zonkExpr env (HsDo do_or_lc stmts body ty) = zonkStmts env stmts `thenM` \ (new_env, new_stmts) -> zonkLExpr new_env body `thenM` \ new_body -> zonkTcTypeToType env ty `thenM` \ new_ty -> - returnM (HsDo (zonkDo env do_or_lc) - new_stmts new_body new_ty) + zonkDo env do_or_lc `thenM` \ new_do_or_lc -> + returnM (HsDo new_do_or_lc new_stmts new_body new_ty) zonkExpr env (ExplicitList ty exprs) = zonkTcTypeToType env ty `thenM` \ new_ty -> @@ -607,31 +610,23 @@ zonkCoFn env (WpCompose c1 c2) = do { (env1, c1') <- zonkCoFn env c1 ; return (env2, WpCompose c1' c2') } zonkCoFn env (WpCast co) = do { co' <- zonkTcTypeToType env co ; return (env, WpCast co') } -zonkCoFn env (WpLam id) = do { id' <- zonkDictBndr env id - ; let env1 = extendZonkEnv1 env id' - ; return (env1, WpLam id') } +zonkCoFn env (WpEvLam ev) = do { (env', ev') <- zonkEvBndrX env ev + ; return (env', WpEvLam ev') } +zonkCoFn env (WpEvApp arg) = do { arg' <- zonkEvTerm env arg + ; return (env, WpEvApp arg') } zonkCoFn env (WpTyLam tv) = ASSERT( isImmutableTyVar tv ) - do { tv' <- zonkTyVarBndr env tv - ; return (env, WpTyLam tv') } -zonkCoFn env (WpApp v) - | isTcTyVar v = do { co <- zonkTcTyVar v - ; return (env, WpTyApp co) } - -- Yuk! A mutable coercion variable is a TcTyVar - -- not a CoVar, so don't use isCoVar! - -- Yuk! A WpApp can't hold the zonked type, - -- so we switch to WpTyApp - | otherwise = return (env, WpApp (zonkIdOcc env v)) + return (env, WpTyLam tv) zonkCoFn env (WpTyApp ty) = do { ty' <- zonkTcTypeToType env ty ; return (env, WpTyApp ty') } -zonkCoFn env (WpLet bs) = do { (env1, bs') <- zonkRecMonoBinds env bs +zonkCoFn env (WpLet bs) = do { (env1, bs') <- zonkTcEvBinds env bs ; return (env1, WpLet bs') } - ------------------------------------------------------------------------- -zonkDo :: ZonkEnv -> HsStmtContext Name -> HsStmtContext Name +zonkDo :: ZonkEnv -> HsStmtContext Name -> TcM (HsStmtContext Name) -- Only used for 'do', so the only Ids are in a MDoExpr table -zonkDo env (MDoExpr tbl) = MDoExpr (mapSnd (zonkIdOcc env) tbl) -zonkDo _ do_or_lc = do_or_lc +zonkDo env (MDoExpr tbl) = do { tbl' <- mapSndM (zonkExpr env) tbl + ; return (MDoExpr tbl') } +zonkDo _ do_or_lc = return do_or_lc ------------------------------------------------------------------------- zonkOverLit :: ZonkEnv -> HsOverLit TcId -> TcM (HsOverLit Id) @@ -697,7 +692,7 @@ zonkStmt env (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_rec_id -- has the polymorphic bindings in the envt ; new_rets <- mapM (zonkExpr env2) rets ; let env3 = extendZonkEnv env new_lvs -- Only the lvs are needed - ; (env4, new_binds) <- zonkRecMonoBinds env3 binds + ; (env4, new_binds) <- zonkTcEvBinds env3 binds ; return (env4, RecStmt { recS_stmts = new_segStmts, recS_later_ids = new_lvs , recS_rec_ids = new_rvs, recS_ret_fn = new_ret_id @@ -791,7 +786,7 @@ zonk_pat env (VarPat v) zonk_pat env (VarPatOut v binds) = do { v' <- zonkIdBndr env v - ; (env', binds') <- zonkRecMonoBinds (extendZonkEnv1 env v') binds + ; (env', binds') <- zonkTcEvBinds (extendZonkEnv1 env v') binds ; returnM (env', VarPatOut v' binds') } zonk_pat env (LazyPat pat) @@ -828,14 +823,13 @@ zonk_pat env (TuplePat pats boxed ty) ; (env', pats') <- zonkPats env pats ; return (env', TuplePat pats' boxed ty') } -zonk_pat env p@(ConPatOut { pat_ty = ty, pat_dicts = dicts, pat_binds = binds, pat_args = args }) +zonk_pat env p@(ConPatOut { pat_ty = ty, pat_dicts = evs, pat_binds = binds, pat_args = args }) = ASSERT( all isImmutableTyVar (pat_tvs p) ) do { new_ty <- zonkTcTypeToType env ty - ; new_dicts <- zonkDictBndrs env dicts - ; let env1 = extendZonkEnv env new_dicts - ; (env2, new_binds) <- zonkRecMonoBinds env1 binds + ; (env1, new_evs) <- zonkEvBndrsX env evs + ; (env2, new_binds) <- zonkTcEvBinds env1 binds ; (env', new_args) <- zonkConStuff env2 args - ; returnM (env', p { pat_ty = new_ty, pat_dicts = new_dicts, + ; returnM (env', p { pat_ty = new_ty, pat_dicts = new_evs, pat_binds = new_binds, pat_args = new_args }) } zonk_pat env (LitPat lit) = return (env, LitPat lit) @@ -921,14 +915,10 @@ zonkRules env rs = mappM (wrapLocM (zonkRule env)) rs zonkRule :: ZonkEnv -> RuleDecl TcId -> TcM (RuleDecl Id) zonkRule env (HsRule name act (vars{-::[RuleBndr TcId]-}) lhs fv_lhs rhs fv_rhs) - = mappM zonk_bndr vars `thenM` \ new_bndrs -> - newMutVar emptyVarSet `thenM` \ unbound_tv_set -> - let - env_rhs = extendZonkEnv env [id | b <- new_bndrs, let id = unLoc b, isId id] - -- Type variables don't need an envt - -- They are bound through the mutable mechanism + = do { (env_rhs, new_bndrs) <- mapAccumLM zonk_bndr env vars - env_lhs = setZonkType env_rhs (zonkTypeCollecting unbound_tv_set) + ; unbound_tv_set <- newMutVar emptyVarSet + ; let env_lhs = setZonkType env_rhs (zonkTypeCollecting unbound_tv_set) -- We need to gather the type variables mentioned on the LHS so we can -- quantify over them. Example: -- data T a = C @@ -947,28 +937,78 @@ zonkRule env (HsRule name act (vars{-::[RuleBndr TcId]-}) lhs fv_lhs rhs fv_rhs) -- are tiresome, because (a) the data type is big and (b) finding the -- free type vars of an expression is necessarily monadic operation. -- (consider /\a -> f @ b, where b is side-effected to a) - in - zonkLExpr env_lhs lhs `thenM` \ new_lhs -> - zonkLExpr env_rhs rhs `thenM` \ new_rhs -> - readMutVar unbound_tv_set `thenM` \ unbound_tvs -> - let - final_bndrs :: [Located Var] - final_bndrs = map noLoc (varSetElems unbound_tvs) ++ new_bndrs - in - returnM (HsRule name act (map RuleBndr final_bndrs) new_lhs fv_lhs new_rhs fv_rhs) - -- I hate this map RuleBndr stuff + ; new_lhs <- zonkLExpr env_lhs lhs + ; new_rhs <- zonkLExpr env_rhs rhs + + ; unbound_tvs <- readMutVar unbound_tv_set + ; let final_bndrs :: [RuleBndr Var] + final_bndrs = map (RuleBndr . noLoc) (varSetElems unbound_tvs) ++ new_bndrs + + ; return (HsRule name act final_bndrs new_lhs fv_lhs new_rhs fv_rhs) } where - zonk_bndr (RuleBndr v) - | isId (unLoc v) = wrapLocM (zonkIdBndr env) v - | otherwise = ASSERT( isImmutableTyVar (unLoc v) ) - return v - zonk_bndr (RuleBndrSig {}) = panic "zonk_bndr RuleBndrSig" + zonk_bndr env (RuleBndr (L loc v)) + = do { (env', v') <- zonk_it env v; return (env', RuleBndr (L loc v')) } + zonk_bndr _ (RuleBndrSig {}) = panic "zonk_bndr RuleBndrSig" + + zonk_it env v + | isId v = do { v' <- zonkIdBndr env v; return (extendZonkEnv1 env v', v') } + | isCoVar v = do { v' <- zonkEvBndr env v; return (extendZonkEnv1 env v', v') } + | otherwise = ASSERT( isImmutableTyVar v) return (env, v) \end{code} %************************************************************************ %* * + Constraints and evidence +%* * +%************************************************************************ + +\begin{code} +zonkEvTerm :: ZonkEnv -> EvTerm -> TcM EvTerm +zonkEvTerm env (EvId v) = ASSERT2( isId v, ppr v ) + return (EvId (zonkIdOcc env v)) +zonkEvTerm env (EvCoercion co) = do { co' <- zonkTcTypeToType env co + ; return (EvCoercion co') } +zonkEvTerm env (EvCast v co) = ASSERT( isId v) + do { co' <- zonkTcTypeToType env co + ; return (EvCast (zonkIdOcc env v) co') } +zonkEvTerm env (EvSuperClass d n) = return (EvSuperClass (zonkIdOcc env d) n) +zonkEvTerm env (EvDFunApp df tys tms) + = do { tys' <- zonkTcTypeToTypes env tys + ; let tms' = map (zonkEvVarOcc env) tms + ; return (EvDFunApp (zonkIdOcc env df) tys' tms') } + +zonkTcEvBinds :: ZonkEnv -> TcEvBinds -> TcM (ZonkEnv, TcEvBinds) +zonkTcEvBinds env (TcEvBinds var) = do { (env', bs') <- zonkEvBindsVar env var + ; return (env', EvBinds bs') } +zonkTcEvBinds env (EvBinds bs) = do { (env', bs') <- zonkEvBinds env bs + ; return (env', EvBinds bs') } + +zonkEvBindsVar :: ZonkEnv -> EvBindsVar -> TcM (ZonkEnv, Bag EvBind) +zonkEvBindsVar env (EvBindsVar ref _) = do { bs <- readMutVar ref + ; zonkEvBinds env (evBindMapBinds bs) } + +zonkEvBinds :: ZonkEnv -> Bag EvBind -> TcM (ZonkEnv, Bag EvBind) +zonkEvBinds env binds + = fixM (\ ~( _, new_binds) -> do + { let env1 = extendZonkEnv env (collect_ev_bndrs new_binds) + ; binds' <- mapBagM (zonkEvBind env1) binds + ; return (env1, binds') }) + where + collect_ev_bndrs :: Bag EvBind -> [EvVar] + collect_ev_bndrs = foldrBag add [] + add (EvBind var _) vars = var : vars + +zonkEvBind :: ZonkEnv -> EvBind -> TcM EvBind +zonkEvBind env (EvBind var term) + = do { var' <- zonkEvBndr env var + ; term' <- zonkEvTerm env term + ; return (EvBind var' term') } +\end{code} + +%************************************************************************ +%* * \subsection[BackSubst-Foreign]{Foreign exports} %* * %************************************************************************ @@ -983,19 +1023,19 @@ zonkTcTypeToTypes env tys = mapM (zonkTcTypeToType env) tys zonkTypeCollecting :: TcRef TyVarSet -> TcType -> TcM Type -- This variant collects unbound type variables in a mutable variable zonkTypeCollecting unbound_tv_set - = zonkType zonk_unbound_tyvar + = zonkType (mkZonkTcTyVar zonk_unbound_tyvar) where zonk_unbound_tyvar tv - = zonkQuantifiedTyVar tv `thenM` \ tv' -> - readMutVar unbound_tv_set `thenM` \ tv_set -> - writeMutVar unbound_tv_set (extendVarSet tv_set tv') `thenM_` - return (mkTyVarTy tv') + = do { tv' <- zonkQuantifiedTyVar tv + ; tv_set <- readMutVar unbound_tv_set + ; writeMutVar unbound_tv_set (extendVarSet tv_set tv') + ; return (mkTyVarTy tv') } zonkTypeZapping :: TcType -> TcM Type -- This variant is used for everything except the LHS of rules -- It zaps unbound type variables to (), or some other arbitrary type zonkTypeZapping ty - = zonkType zonk_unbound_tyvar ty + = zonkType (mkZonkTcTyVar zonk_unbound_tyvar) ty where -- Zonk a mutable but unbound type variable to an arbitrary type -- We know it's unbound even though we don't carry an environment,