X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcHsSyn.lhs;h=21ca4be9b43c6cf9016dc3f9e2b8161c91b25aa7;hb=33aac1f993ade9a0a8aee67eaad1584df8705d67;hp=942d22eb35b2c4d0202065e8e61ef0d1ea2bd8c2;hpb=a8e1967fbb90eae923042827cef98a98d66d18e7;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs index 942d22e..21ca4be 100644 --- a/ghc/compiler/typecheck/TcHsSyn.lhs +++ b/ghc/compiler/typecheck/TcHsSyn.lhs @@ -24,12 +24,11 @@ module TcHsSyn ( mkHsTyApp, mkHsDictApp, mkHsConApp, mkHsTyLam, mkHsDictLam, mkHsLet, - idsToMonoBinds, -- re-exported from TcEnv - TcId, tcInstId, + TcId, - zonkTopBinds, zonkId, zonkIdOcc, + zonkTopBinds, zonkId, zonkIdBndr, zonkIdOcc, zonkExpr, zonkForeignExports, zonkRules ) where @@ -39,21 +38,20 @@ module TcHsSyn ( import HsSyn -- oodles of it -- others: -import Id ( idName, idType, idUnfolding, setIdType, omitIfaceSigForId, isIP, Id ) +import Id ( idName, idType, setIdType, Id ) import DataCon ( dataConWrapId ) -import TcEnv ( tcLookupValueMaybe, tcExtendGlobalValEnv, tcGetValueEnv, - ValueEnv, TcId, tcInstId +import TcEnv ( tcLookupGlobal_maybe, tcExtendGlobalValEnv, + TcEnv, TcId ) import TcMonad import TcType ( zonkTcTypeToType, zonkTcTyVarToTyVar, zonkTcType, zonkTcSigTyVars ) -import Name ( isLocallyDefined ) import CoreSyn ( Expr ) -import CoreUnfold( unfoldingTemplate ) import BasicTypes ( RecFlag(..) ) import Bag import Outputable +import HscTypes ( TyThing(..) ) \end{code} @@ -118,12 +116,6 @@ mkHsLet EmptyMonoBinds expr = expr mkHsLet mbinds expr = HsLet (MonoBind mbinds [] Recursive) expr mkHsConApp data_con tys args = foldl HsApp (HsVar (dataConWrapId data_con) `mkHsTyApp` tys) args - -idsToMonoBinds :: [Id] -> TcMonoBinds -idsToMonoBinds ids - = andMonoBindList [ CoreMonoBind id (unfoldingTemplate (idUnfolding id)) - | id <- ids - ] \end{code} %************************************************************************ @@ -150,49 +142,51 @@ the environment manipulation is tiresome. \begin{code} -- zonkId is used *during* typechecking just to zonk the Id's type -zonkId :: TcId -> NF_TcM s TcId +zonkId :: TcId -> NF_TcM TcId zonkId id = zonkTcType (idType id) `thenNF_Tc` \ ty' -> returnNF_Tc (setIdType id ty') -- zonkIdBndr is used *after* typechecking to get the Id's type -- to its final form. The TyVarEnv give -zonkIdBndr :: TcId -> NF_TcM s Id +zonkIdBndr :: TcId -> NF_TcM Id zonkIdBndr id = zonkTcTypeToType (idType id) `thenNF_Tc` \ ty' -> returnNF_Tc (setIdType id ty') -zonkIdOcc :: TcId -> NF_TcM s Id +zonkIdOcc :: TcId -> NF_TcM Id zonkIdOcc id - | not (isLocallyDefined id) || omitIfaceSigForId id || isIP id - -- The omitIfaceSigForId thing may look wierd but it's quite - -- sensible really. We're avoiding looking up superclass selectors - -- and constructors; zonking them is a no-op anyway, and the + = tcLookupGlobal_maybe (idName id) `thenNF_Tc` \ maybe_id' -> + -- We're even look up up superclass selectors and constructors; + -- even though zonking them is a no-op anyway, and the -- superclass selectors aren't in the environment anyway. - = returnNF_Tc id - | otherwise - = tcLookupValueMaybe (idName id) `thenNF_Tc` \ maybe_id' -> + -- But we don't want to call isLocalId to find out whether + -- it's a superclass selector (for example) because that looks + -- at the IdInfo field, which in turn be in a knot because of + -- the big knot in typecheckModule let new_id = case maybe_id' of - Just id' -> id' - Nothing -> pprTrace "zonkIdOcc: " (ppr id) id + Just (AnId id') -> id' + other -> id -- WARN( isLocalId id, ppr id ) id + -- Oops: the warning can give a black hole + -- because it looks at the idinfo in returnNF_Tc new_id \end{code} \begin{code} -zonkTopBinds :: TcMonoBinds -> NF_TcM s (TypecheckedMonoBinds, ValueEnv) +zonkTopBinds :: TcMonoBinds -> NF_TcM (TypecheckedMonoBinds, TcEnv) zonkTopBinds binds -- Top level is implicitly recursive = fixNF_Tc (\ ~(_, new_ids) -> tcExtendGlobalValEnv (bagToList new_ids) $ zonkMonoBinds binds `thenNF_Tc` \ (binds', new_ids) -> - tcGetValueEnv `thenNF_Tc` \ env -> + tcGetEnv `thenNF_Tc` \ env -> returnNF_Tc ((binds', env), new_ids) ) `thenNF_Tc` \ (stuff, _) -> returnNF_Tc stuff -zonkBinds :: TcHsBinds -> NF_TcM s (TypecheckedHsBinds, TcEnv) +zonkBinds :: TcHsBinds -> NF_TcM (TypecheckedHsBinds, TcEnv) zonkBinds binds = go binds (\ binds' -> tcGetEnv `thenNF_Tc` \ env -> @@ -200,9 +194,9 @@ zonkBinds binds where -- go :: TcHsBinds -- -> (TypecheckedHsBinds - -- -> NF_TcM s (TypecheckedHsBinds, TcEnv) + -- -> NF_TcM (TypecheckedHsBinds, TcEnv) -- ) - -- -> NF_TcM s (TypecheckedHsBinds, TcEnv) + -- -> NF_TcM (TypecheckedHsBinds, TcEnv) go (ThenBinds b1 b2) thing_inside = go b1 $ \ b1' -> go b2 $ \ b2' -> @@ -224,7 +218,7 @@ zonkBinds binds \begin{code} ------------------------------------------------------------------------- zonkMonoBinds :: TcMonoBinds - -> NF_TcM s (TypecheckedMonoBinds, Bag Id) + -> NF_TcM (TypecheckedMonoBinds, Bag Id) zonkMonoBinds EmptyMonoBinds = returnNF_Tc (EmptyMonoBinds, emptyBag) @@ -290,7 +284,7 @@ zonkMonoBinds (AbsBinds tyvars dicts exports inlines val_bind) %************************************************************************ \begin{code} -zonkMatch :: TcMatch -> NF_TcM s TypecheckedMatch +zonkMatch :: TcMatch -> NF_TcM TypecheckedMatch zonkMatch (Match _ pats _ grhss) = zonkPats pats `thenNF_Tc` \ (new_pats, new_ids) -> @@ -300,7 +294,7 @@ zonkMatch (Match _ pats _ grhss) ------------------------------------------------------------------------- zonkGRHSs :: TcGRHSs - -> NF_TcM s TypecheckedGRHSs + -> NF_TcM TypecheckedGRHSs zonkGRHSs (GRHSs grhss binds (Just ty)) = zonkBinds binds `thenNF_Tc` \ (new_binds, new_env) -> @@ -322,7 +316,7 @@ zonkGRHSs (GRHSs grhss binds (Just ty)) %************************************************************************ \begin{code} -zonkExpr :: TcExpr -> NF_TcM s TypecheckedHsExpr +zonkExpr :: TcExpr -> NF_TcM TypecheckedHsExpr zonkExpr (HsVar id) = zonkIdOcc id `thenNF_Tc` \ id' -> @@ -360,8 +354,8 @@ zonkExpr (OpApp e1 op fixity e2) zonkExpr e2 `thenNF_Tc` \ new_e2 -> returnNF_Tc (OpApp new_e1 new_op fixity new_e2) -zonkExpr (NegApp _ _) = panic "zonkExpr: NegApp" -zonkExpr (HsPar _) = panic "zonkExpr: HsPar" +zonkExpr (NegApp _) = panic "zonkExpr: NegApp" +zonkExpr (HsPar _) = panic "zonkExpr: HsPar" zonkExpr (SectionL expr op) = zonkExpr expr `thenNF_Tc` \ new_expr -> @@ -481,7 +475,7 @@ zonkExpr (DictApp expr dicts) ------------------------------------------------------------------------- -zonkArithSeq :: TcArithSeqInfo -> NF_TcM s TypecheckedArithSeqInfo +zonkArithSeq :: TcArithSeqInfo -> NF_TcM TypecheckedArithSeqInfo zonkArithSeq (From e) = zonkExpr e `thenNF_Tc` \ new_e -> @@ -505,24 +499,24 @@ zonkArithSeq (FromThenTo e1 e2 e3) ------------------------------------------------------------------------- zonkStmts :: [TcStmt] - -> NF_TcM s [TypecheckedStmt] + -> NF_TcM [TypecheckedStmt] zonkStmts [] = returnNF_Tc [] -zonkStmts [ReturnStmt expr] - = zonkExpr expr `thenNF_Tc` \ new_expr -> - returnNF_Tc [ReturnStmt new_expr] +zonkStmts (ParStmtOut bndrstmtss : stmts) + = mapNF_Tc (mapNF_Tc zonkId) bndrss `thenNF_Tc` \ new_bndrss -> + let new_binders = concat new_bndrss in + mapNF_Tc zonkStmts stmtss `thenNF_Tc` \ new_stmtss -> + tcExtendGlobalValEnv new_binders $ + zonkStmts stmts `thenNF_Tc` \ new_stmts -> + returnNF_Tc (ParStmtOut (zip new_bndrss new_stmtss) : new_stmts) + where (bndrss, stmtss) = unzip bndrstmtss zonkStmts (ExprStmt expr locn : stmts) = zonkExpr expr `thenNF_Tc` \ new_expr -> zonkStmts stmts `thenNF_Tc` \ new_stmts -> returnNF_Tc (ExprStmt new_expr locn : new_stmts) -zonkStmts (GuardStmt expr locn : stmts) - = zonkExpr expr `thenNF_Tc` \ new_expr -> - zonkStmts stmts `thenNF_Tc` \ new_stmts -> - returnNF_Tc (GuardStmt new_expr locn : new_stmts) - zonkStmts (LetStmt binds : stmts) = zonkBinds binds `thenNF_Tc` \ (new_binds, new_env) -> tcSetEnv new_env $ @@ -539,7 +533,7 @@ zonkStmts (BindStmt pat expr locn : stmts) ------------------------------------------------------------------------- -zonkRbinds :: TcRecordBinds -> NF_TcM s TypecheckedRecordBinds +zonkRbinds :: TcRecordBinds -> NF_TcM TypecheckedRecordBinds zonkRbinds rbinds = mapNF_Tc zonk_rbind rbinds @@ -557,7 +551,7 @@ zonkRbinds rbinds %************************************************************************ \begin{code} -zonkPat :: TcPat -> NF_TcM s (TypecheckedPat, Bag Id) +zonkPat :: TcPat -> NF_TcM (TypecheckedPat, Bag Id) zonkPat (WildPat ty) = zonkTcTypeToType ty `thenNF_Tc` \ new_ty -> @@ -647,17 +641,17 @@ zonkPats (pat:pats) \begin{code} -zonkForeignExports :: [TcForeignExportDecl] -> NF_TcM s [TypecheckedForeignDecl] +zonkForeignExports :: [TcForeignExportDecl] -> NF_TcM [TypecheckedForeignDecl] zonkForeignExports ls = mapNF_Tc zonkForeignExport ls -zonkForeignExport :: TcForeignExportDecl -> NF_TcM s (TypecheckedForeignDecl) +zonkForeignExport :: TcForeignExportDecl -> NF_TcM (TypecheckedForeignDecl) zonkForeignExport (ForeignDecl i imp_exp hs_ty ext_nm cconv src_loc) = zonkIdOcc i `thenNF_Tc` \ i' -> returnNF_Tc (ForeignDecl i' imp_exp undefined ext_nm cconv src_loc) \end{code} \begin{code} -zonkRules :: [TcRuleDecl] -> NF_TcM s [TypecheckedRuleDecl] +zonkRules :: [TcRuleDecl] -> NF_TcM [TypecheckedRuleDecl] zonkRules rs = mapNF_Tc zonkRule rs zonkRule (HsRule name tyvars vars lhs rhs loc)