TcMonoBinds, TcHsBinds, TcPat,
TcExpr, TcGRHSs, TcGRHS, TcMatch,
TcStmt, TcArithSeqInfo, TcRecordBinds,
- TcHsModule, TcCoreExpr, TcDictBinds,
+ TcHsModule, TcDictBinds,
TcForeignExportDecl,
TypecheckedHsBinds, TypecheckedRuleDecl,
TypecheckedMatch, TypecheckedHsModule,
TypecheckedGRHSs, TypecheckedGRHS,
TypecheckedRecordBinds, TypecheckedDictBinds,
- TypecheckedMatchContext,
+ TypecheckedMatchContext, TypecheckedCoreBind,
mkHsTyApp, mkHsDictApp, mkHsConApp,
mkHsTyLam, mkHsDictLam, mkHsLet,
TcId,
zonkTopBinds, zonkId, zonkIdBndr, zonkIdOcc, zonkExpr,
- zonkForeignExports, zonkRules
+ zonkForeignExports, zonkRules, zonkCoreExpr, zonkCoreBinds
) where
#include "HsVersions.h"
import TcEnv ( tcLookupGlobal_maybe, tcExtendGlobalValEnv, TcEnv, TcId )
import TcMonad
-import TypeRep ( IPName(..) ) -- For zonking
-import Type ( Type, ipNameName )
-import TcType ( TcType )
-import TcMType ( zonkTcTypeToType, zonkTcTyVarToTyVar, zonkTcType, zonkTcSigTyVars )
+import Type ( Type )
+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(..) )
+import BasicTypes ( RecFlag(..), Boxity(..), IPName(..), ipNameName )
import Bag
import Outputable
import HscTypes ( TyThing(..) )
type TcRecordBinds = HsRecordBinds TcId TcPat
type TcHsModule = HsModule TcId TcPat
-type TcCoreExpr = Expr TcId
type TcForeignExportDecl = ForeignDecl TcId
type TcRuleDecl = RuleDecl TcId TcPat
type TypecheckedHsModule = HsModule Id TypecheckedPat
type TypecheckedForeignDecl = ForeignDecl Id
type TypecheckedRuleDecl = RuleDecl Id TypecheckedPat
+type TypecheckedCoreBind = (Id, Type, CoreExpr)
\end{code}
\begin{code}
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
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)
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)
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)
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)
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 ->
-------------------------------------------------------------------------
mapIPNameTc :: (a -> NF_TcM b) -> IPName a -> NF_TcM (IPName b)
-mapIPNameTc f (Dupable n) = f n `thenNF_Tc` \ r -> returnNF_Tc (Dupable r)
-mapIPNameTc f (MustSplit n) = f n `thenNF_Tc` \ r -> returnNF_Tc (MustSplit r)
+mapIPNameTc f (Dupable n) = f n `thenNF_Tc` \ r -> returnNF_Tc (Dupable r)
+mapIPNameTc f (Linear n) = f n `thenNF_Tc` \ r -> returnNF_Tc (Linear r)
\end{code}
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 $
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)
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)
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}
= zonkIdOcc fun `thenNF_Tc` \ fun' ->
returnNF_Tc (IfaceRuleOut fun' rule)
\end{code}
+
+\begin{code}
+zonkCoreBinds :: [TypecheckedCoreBind] -> NF_TcM [TypecheckedCoreBind]
+zonkCoreBinds ls = mapNF_Tc zonkOne ls
+ where
+ zonkOne (i, t, e) =
+ zonkIdOcc i `thenNF_Tc` \ i' ->
+ zonkTcTypeToType t `thenNF_Tc` \ t' ->
+ zonkCoreExpr e `thenNF_Tc` \ e' ->
+ returnNF_Tc (i',t',e')
+
+-- needed?
+zonkCoreExpr :: CoreExpr -> NF_TcM CoreExpr
+zonkCoreExpr e =
+ case e of
+ Var i ->
+ zonkIdOcc i `thenNF_Tc` \ i' ->
+ returnNF_Tc (Var i')
+ Lit l -> returnNF_Tc (Lit l)
+ App f arg ->
+ zonkCoreExpr f `thenNF_Tc` \ f' ->
+ zonkCoreExpr arg `thenNF_Tc` \ arg' ->
+ returnNF_Tc (App f' arg')
+ Lam b e ->
+ zonkIdOcc b `thenNF_Tc` \ b' ->
+ zonkCoreExpr e `thenNF_Tc` \ e' ->
+ returnNF_Tc (Lam b' e')
+ Case scrut n alts ->
+ zonkCoreExpr scrut `thenNF_Tc` \ scrut' ->
+ zonkIdOcc n `thenNF_Tc` \ n' ->
+ mapNF_Tc zonkCoreAlt alts `thenNF_Tc` \ alts' ->
+ returnNF_Tc (Case scrut' n' alts')
+ Let b rhs ->
+ zonkCoreBind b `thenNF_Tc` \ b' ->
+ zonkCoreExpr rhs `thenNF_Tc` \ rhs' ->
+ returnNF_Tc (Let b' rhs')
+ Note note e ->
+ zonkNote note `thenNF_Tc` \ note' ->
+ zonkCoreExpr e `thenNF_Tc` \ e' ->
+ returnNF_Tc (Note note' e')
+ Type t ->
+ zonkTcTypeToType t `thenNF_Tc` \ t' ->
+ returnNF_Tc (Type t')
+
+zonkCoreBind :: CoreBind -> NF_TcM CoreBind
+zonkCoreBind (NonRec b e) =
+ zonkIdOcc b `thenNF_Tc` \ b' ->
+ zonkCoreExpr e `thenNF_Tc` \ e' ->
+ returnNF_Tc (NonRec b' e')
+zonkCoreBind (Rec bs) =
+ mapNF_Tc zonkIt bs `thenNF_Tc` \ bs' ->
+ returnNF_Tc (Rec bs')
+ where
+ zonkIt (b,e) =
+ zonkIdOcc b `thenNF_Tc` \ b' ->
+ zonkCoreExpr e `thenNF_Tc` \ e' ->
+ returnNF_Tc (b',e')
+
+
+zonkCoreAlt :: CoreAlt -> NF_TcM CoreAlt
+zonkCoreAlt (ac, bs, rhs) =
+ mapNF_Tc zonkIdOcc bs `thenNF_Tc` \ bs' ->
+ zonkCoreExpr rhs `thenNF_Tc` \ rhs' ->
+ returnNF_Tc (ac, bs', rhs')
+
+zonkNote :: Note -> NF_TcM Note
+zonkNote n =
+ case n of
+ Coerce t f ->
+ zonkTcTypeToType t `thenNF_Tc` \ t' ->
+ zonkTcTypeToType f `thenNF_Tc` \ f' ->
+ returnNF_Tc (Coerce t' f')
+ _ -> returnNF_Tc n
+
+\end{code}
projects / ghc-hetmet.git / blobdiff