X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcHsSyn.lhs;h=3fda515525a58c7f5c9164ed82b7cdea02f2bbd4;hb=2db30d0659c98890689d26faeac6446b515dfa72;hp=fb6634a2d452b51d9f362ba7792240080dabce36;hpb=32a895831dbc202fab780fdd8bee65be81e2d232;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs index fb6634a..3fda515 100644 --- a/ghc/compiler/typecheck/TcHsSyn.lhs +++ b/ghc/compiler/typecheck/TcHsSyn.lhs @@ -11,7 +11,7 @@ module TcHsSyn ( TcMonoBinds, TcHsBinds, TcPat, TcExpr, TcGRHSs, TcGRHS, TcMatch, TcStmt, TcArithSeqInfo, TcRecordBinds, - TcHsModule, TcCoreExpr, TcDictBinds, + TcHsModule, TcDictBinds, TcForeignExportDecl, TypecheckedHsBinds, TypecheckedRuleDecl, @@ -21,7 +21,7 @@ module TcHsSyn ( TypecheckedMatch, TypecheckedHsModule, TypecheckedGRHSs, TypecheckedGRHS, TypecheckedRecordBinds, TypecheckedDictBinds, - TypecheckedMatchContext, + TypecheckedMatchContext, TypecheckedCoreBind, mkHsTyApp, mkHsDictApp, mkHsConApp, mkHsTyLam, mkHsDictLam, mkHsLet, @@ -48,14 +48,14 @@ import TcEnv ( tcLookupGlobal_maybe, tcExtendGlobalValEnv, TcEnv, TcId ) import TcMonad import Type ( Type ) -import TcType ( TcType ) -import TcMType ( zonkTcTypeToType, zonkTcTyVarToTyVar, zonkTcType, zonkTcSigTyVars ) +import TcType ( TcType, tcGetTyVar ) +import TcMType ( zonkTcTypeToType, zonkTcTyVarToTyVar, zonkTcType, zonkTcTyVars ) import TysPrim ( charPrimTy, intPrimTy, floatPrimTy, doublePrimTy, addrPrimTy ) import TysWiredIn ( charTy, stringTy, intTy, integerTy, - mkListTy, mkTupleTy, unitTy ) -import CoreSyn ( Expr ) + mkListTy, mkPArrTy, mkTupleTy, unitTy ) +import CoreSyn ( Expr(..), CoreExpr, CoreBind, Bind(..), CoreAlt, Note(..) ) import Var ( isId ) import BasicTypes ( RecFlag(..), Boxity(..), IPName(..), ipNameName ) import Bag @@ -88,7 +88,6 @@ type TcArithSeqInfo = ArithSeqInfo TcId TcPat type TcRecordBinds = HsRecordBinds TcId TcPat type TcHsModule = HsModule TcId TcPat -type TcCoreExpr = Expr TcId type TcForeignExportDecl = ForeignDecl TcId type TcRuleDecl = RuleDecl TcId TcPat @@ -107,6 +106,7 @@ type TypecheckedRecordBinds = HsRecordBinds Id TypecheckedPat type TypecheckedHsModule = HsModule Id TypecheckedPat type TypecheckedForeignDecl = ForeignDecl Id type TypecheckedRuleDecl = RuleDecl Id TypecheckedPat +type TypecheckedCoreBind = (Id, CoreExpr) \end{code} \begin{code} @@ -161,6 +161,7 @@ outPatType (LazyPat pat) = outPatType pat outPatType (AsPat var pat) = idType var outPatType (ConPat _ ty _ _ _) = ty outPatType (ListPat ty _) = mkListTy ty +outPatType (PArrPat ty _) = mkPArrTy ty outPatType (TuplePat pats box) = mkTupleTy box (length pats) (map outPatType pats) outPatType (RecPat _ ty _ _ _) = ty outPatType (SigPat _ ty _) = ty @@ -190,6 +191,7 @@ collectTypedPatBinders (AsPat a pat) = a : collectTypedPatBinders pat collectTypedPatBinders (SigPat pat _ _) = collectTypedPatBinders pat collectTypedPatBinders (ConPat _ _ _ _ pats) = concat (map collectTypedPatBinders pats) collectTypedPatBinders (ListPat t pats) = concat (map collectTypedPatBinders pats) +collectTypedPatBinders (PArrPat t pats) = concat (map collectTypedPatBinders pats) collectTypedPatBinders (TuplePat pats _) = concat (map collectTypedPatBinders pats) collectTypedPatBinders (RecPat _ _ _ _ fields) = concat (map (\ (f,pat,_) -> collectTypedPatBinders pat) fields) @@ -350,9 +352,12 @@ zonkMonoBinds (AbsBinds tyvars dicts exports inlines val_bind) new_globals) where zonkExport (tyvars, global, local) - = zonkTcSigTyVars tyvars `thenNF_Tc` \ new_tyvars -> + = zonkTcTyVars tyvars `thenNF_Tc` \ tys -> + let + new_tyvars = map (tcGetTyVar "zonkExport") tys -- This isn't the binding occurrence of these tyvars - -- but they should *be* tyvars. Hence zonkTcSigTyVars. + -- but they should *be* tyvars. Hence tcGetTyVar. + in zonkIdBndr global `thenNF_Tc` \ new_global -> zonkIdOcc local `thenNF_Tc` \ new_local -> returnNF_Tc (new_tyvars, new_global, new_local) @@ -465,11 +470,11 @@ zonkExpr (HsLet binds expr) zonkExpr expr `thenNF_Tc` \ new_expr -> returnNF_Tc (HsLet new_binds new_expr) -zonkExpr (HsWith expr binds) +zonkExpr (HsWith expr binds is_with) = zonkIPBinds binds `thenNF_Tc` \ new_binds -> tcExtendGlobalValEnv (map (ipNameName . fst) new_binds) $ zonkExpr expr `thenNF_Tc` \ new_expr -> - returnNF_Tc (HsWith new_expr new_binds) + returnNF_Tc (HsWith new_expr new_binds is_with) where zonkIPBinds = mapNF_Tc zonkIPBind zonkIPBind (n, e) @@ -477,22 +482,22 @@ zonkExpr (HsWith expr binds) zonkExpr e `thenNF_Tc` \ e' -> returnNF_Tc (n', e') -zonkExpr (HsDo _ _ _) = panic "zonkExpr:HsDo" - -zonkExpr (HsDoOut do_or_lc stmts return_id then_id zero_id ty src_loc) +zonkExpr (HsDo do_or_lc stmts ids ty src_loc) = zonkStmts stmts `thenNF_Tc` \ new_stmts -> - zonkTcTypeToType ty `thenNF_Tc` \ new_ty -> - zonkIdOcc return_id `thenNF_Tc` \ new_return_id -> - zonkIdOcc then_id `thenNF_Tc` \ new_then_id -> - zonkIdOcc zero_id `thenNF_Tc` \ new_zero_id -> - returnNF_Tc (HsDoOut do_or_lc new_stmts new_return_id new_then_id new_zero_id - new_ty src_loc) + zonkTcTypeToType ty `thenNF_Tc` \ new_ty -> + mapNF_Tc zonkIdOcc ids `thenNF_Tc` \ new_ids -> + returnNF_Tc (HsDo do_or_lc new_stmts new_ids new_ty src_loc) zonkExpr (ExplicitList ty exprs) = zonkTcTypeToType ty `thenNF_Tc` \ new_ty -> mapNF_Tc zonkExpr exprs `thenNF_Tc` \ new_exprs -> returnNF_Tc (ExplicitList new_ty new_exprs) +zonkExpr (ExplicitPArr ty exprs) + = zonkTcTypeToType ty `thenNF_Tc` \ new_ty -> + mapNF_Tc zonkExpr exprs `thenNF_Tc` \ new_exprs -> + returnNF_Tc (ExplicitPArr new_ty new_exprs) + zonkExpr (ExplicitTuple exprs boxed) = mapNF_Tc zonkExpr exprs `thenNF_Tc` \ new_exprs -> returnNF_Tc (ExplicitTuple new_exprs boxed) @@ -504,22 +509,27 @@ zonkExpr (RecordConOut data_con con_expr rbinds) zonkExpr (RecordUpd _ _) = panic "zonkExpr:RecordUpd" -zonkExpr (RecordUpdOut expr in_ty out_ty dicts rbinds) +zonkExpr (RecordUpdOut expr in_ty out_ty rbinds) = zonkExpr expr `thenNF_Tc` \ new_expr -> zonkTcTypeToType in_ty `thenNF_Tc` \ new_in_ty -> zonkTcTypeToType out_ty `thenNF_Tc` \ new_out_ty -> - mapNF_Tc zonkIdOcc dicts `thenNF_Tc` \ new_dicts -> zonkRbinds rbinds `thenNF_Tc` \ new_rbinds -> - returnNF_Tc (RecordUpdOut new_expr new_in_ty new_out_ty new_dicts new_rbinds) + returnNF_Tc (RecordUpdOut new_expr new_in_ty new_out_ty new_rbinds) zonkExpr (ExprWithTySig _ _) = panic "zonkExpr:ExprWithTySig" zonkExpr (ArithSeqIn _) = panic "zonkExpr:ArithSeqIn" +zonkExpr (PArrSeqIn _) = panic "zonkExpr:PArrSeqIn" zonkExpr (ArithSeqOut expr info) = zonkExpr expr `thenNF_Tc` \ new_expr -> zonkArithSeq info `thenNF_Tc` \ new_info -> returnNF_Tc (ArithSeqOut new_expr new_info) +zonkExpr (PArrSeqOut expr info) + = zonkExpr expr `thenNF_Tc` \ new_expr -> + zonkArithSeq info `thenNF_Tc` \ new_info -> + returnNF_Tc (PArrSeqOut new_expr new_info) + zonkExpr (HsCCall fun args may_gc is_casm result_ty) = mapNF_Tc zonkExpr args `thenNF_Tc` \ new_args -> zonkTcTypeToType result_ty `thenNF_Tc` \ new_result_ty -> @@ -667,12 +677,17 @@ zonkPat (ListPat ty pats) zonkPats pats `thenNF_Tc` \ (new_pats, ids) -> returnNF_Tc (ListPat new_ty new_pats, ids) +zonkPat (PArrPat ty pats) + = zonkTcTypeToType ty `thenNF_Tc` \ new_ty -> + zonkPats pats `thenNF_Tc` \ (new_pats, ids) -> + returnNF_Tc (PArrPat new_ty new_pats, ids) + zonkPat (TuplePat pats boxed) = zonkPats pats `thenNF_Tc` \ (new_pats, ids) -> returnNF_Tc (TuplePat new_pats boxed, ids) zonkPat (ConPat n ty tvs dicts pats) - = zonkTcTypeToType ty `thenNF_Tc` \ new_ty -> + = zonkTcTypeToType ty `thenNF_Tc` \ new_ty -> mapNF_Tc zonkTcTyVarToTyVar tvs `thenNF_Tc` \ new_tvs -> mapNF_Tc zonkIdBndr dicts `thenNF_Tc` \ new_dicts -> tcExtendGlobalValEnv new_dicts $ @@ -694,7 +709,7 @@ zonkPat (RecPat n ty tvs dicts rpats) returnNF_Tc ((f, new_pat, pun), ids) zonkPat (LitPat lit ty) - = zonkTcTypeToType ty `thenNF_Tc` \ new_ty -> + = zonkTcTypeToType ty `thenNF_Tc` \ new_ty -> returnNF_Tc (LitPat lit new_ty, emptyBag) zonkPat (SigPat pat ty expr) @@ -709,15 +724,15 @@ zonkPat (NPat lit ty expr) returnNF_Tc (NPat lit new_ty new_expr, emptyBag) zonkPat (NPlusKPat n k ty e1 e2) - = zonkIdBndr n `thenNF_Tc` \ new_n -> - zonkTcTypeToType ty `thenNF_Tc` \ new_ty -> - zonkExpr e1 `thenNF_Tc` \ new_e1 -> - zonkExpr e2 `thenNF_Tc` \ new_e2 -> + = zonkIdBndr n `thenNF_Tc` \ new_n -> + zonkTcTypeToType ty `thenNF_Tc` \ new_ty -> + zonkExpr e1 `thenNF_Tc` \ new_e1 -> + zonkExpr e2 `thenNF_Tc` \ new_e2 -> returnNF_Tc (NPlusKPat new_n k new_ty new_e1 new_e2, unitBag new_n) zonkPat (DictPat ds ms) - = mapNF_Tc zonkIdBndr ds `thenNF_Tc` \ new_ds -> - mapNF_Tc zonkIdBndr ms `thenNF_Tc` \ new_ms -> + = mapNF_Tc zonkIdBndr ds `thenNF_Tc` \ new_ds -> + mapNF_Tc zonkIdBndr ms `thenNF_Tc` \ new_ms -> returnNF_Tc (DictPat new_ds new_ms, listToBag new_ds `unionBags` listToBag new_ms) @@ -743,9 +758,9 @@ zonkForeignExports :: [TcForeignExportDecl] -> NF_TcM [TypecheckedForeignDecl] zonkForeignExports ls = mapNF_Tc zonkForeignExport ls zonkForeignExport :: TcForeignExportDecl -> NF_TcM (TypecheckedForeignDecl) -zonkForeignExport (ForeignExport i hs_ty spec src_loc) = +zonkForeignExport (ForeignExport i hs_ty spec isDeprec src_loc) = zonkIdOcc i `thenNF_Tc` \ i' -> - returnNF_Tc (ForeignExport i' undefined spec src_loc) + returnNF_Tc (ForeignExport i' undefined spec isDeprec src_loc) \end{code} \begin{code} @@ -770,3 +785,4 @@ zonkRule (IfaceRuleOut fun rule) = zonkIdOcc fun `thenNF_Tc` \ fun' -> returnNF_Tc (IfaceRuleOut fun' rule) \end{code} +