X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fiface%2FTcIface.lhs;h=5bfb406c026807d6aa1af13f9474ebaa93716225;hp=c39b713f9fc57ed2ebe6b08996b8b4cce6d56ebd;hb=2c8aabcad1d2f2c469cb8a10afa7b66beeaedd45;hpb=9a81ddfb43b96cfeae2236c9616ca3552250b235 diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index c39b713..5bfb406 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -21,6 +21,7 @@ import BuildTyCl import TcRnMonad import TcType import Type +import Coercion import TypeRep import HscTypes import Annotations @@ -38,15 +39,16 @@ import Class import TyCon import DataCon import TysWiredIn -import TysPrim ( anyTyConOfKind ) -import Var ( Var, TyVar ) -import BasicTypes ( Arity, nonRuleLoopBreaker ) +import TysPrim ( anyTyConOfKind ) +import BasicTypes ( Arity, nonRuleLoopBreaker ) import qualified Var import VarEnv +import VarSet import Name import NameEnv -import OccurAnal ( occurAnalyseExpr ) -import Demand ( isBottomingSig ) +import NameSet +import OccurAnal ( occurAnalyseExpr ) +import Demand ( isBottomingSig ) import Module import UniqFM import UniqSupply @@ -433,7 +435,6 @@ tc_iface_decl parent _ (IfaceData {ifName = occ_name, ifCtxt = ctxt, ifGadtSyntax = gadt_syn, ifCons = rdr_cons, ifRec = is_rec, - ifGeneric = want_generic, ifFamInst = mb_family }) = bindIfaceTyVars_AT tv_bndrs $ \ tyvars -> do { tc_name <- lookupIfaceTop occ_name @@ -442,7 +443,7 @@ tc_iface_decl parent _ (IfaceData {ifName = occ_name, ; cons <- tcIfaceDataCons tc_name tycon tyvars rdr_cons ; mb_fam_inst <- tcFamInst mb_family ; buildAlgTyCon tc_name tyvars stupid_theta cons is_rec - want_generic gadt_syn parent mb_fam_inst + gadt_syn parent mb_fam_inst }) ; traceIf (text "tcIfaceDecl4" <+> ppr tycon) ; return (ATyCon tycon) } @@ -690,28 +691,32 @@ tcIfaceAnnTarget (ModuleTarget mod) = do %************************************************************************ -%* * - Vectorisation information -%* * +%* * + Vectorisation information +%* * %************************************************************************ \begin{code} tcIfaceVectInfo :: Module -> TypeEnv -> IfaceVectInfo -> IfL VectInfo tcIfaceVectInfo mod typeEnv (IfaceVectInfo - { ifaceVectInfoVar = vars - , ifaceVectInfoTyCon = tycons - , ifaceVectInfoTyConReuse = tyconsReuse + { ifaceVectInfoVar = vars + , ifaceVectInfoTyCon = tycons + , ifaceVectInfoTyConReuse = tyconsReuse + , ifaceVectInfoScalarVars = scalarVars + , ifaceVectInfoScalarTyCons = scalarTyCons }) = do { vVars <- mapM vectVarMapping vars ; tyConRes1 <- mapM vectTyConMapping tycons ; tyConRes2 <- mapM vectTyConReuseMapping tyconsReuse ; let (vTyCons, vDataCons, vPAs, vIsos) = unzip4 (tyConRes1 ++ tyConRes2) ; return $ VectInfo - { vectInfoVar = mkVarEnv vVars - , vectInfoTyCon = mkNameEnv vTyCons - , vectInfoDataCon = mkNameEnv (concat vDataCons) - , vectInfoPADFun = mkNameEnv vPAs - , vectInfoIso = mkNameEnv vIsos + { vectInfoVar = mkVarEnv vVars + , vectInfoTyCon = mkNameEnv vTyCons + , vectInfoDataCon = mkNameEnv (concat vDataCons) + , vectInfoPADFun = mkNameEnv vPAs + , vectInfoIso = mkNameEnv vIsos + , vectInfoScalarVars = mkVarSet (map lookupVar scalarVars) + , vectInfoScalarTyCons = mkNameSet scalarTyCons } } where @@ -779,9 +784,9 @@ tcIfaceVectInfo mod typeEnv (IfaceVectInfo \end{code} %************************************************************************ -%* * - Types -%* * +%* * + Types +%* * %************************************************************************ \begin{code} @@ -791,20 +796,56 @@ tcIfaceType (IfaceAppTy t1 t2) = do { t1' <- tcIfaceType t1; t2' <- tcIfaceTy tcIfaceType (IfaceFunTy t1 t2) = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (FunTy t1' t2') } tcIfaceType (IfaceTyConApp tc ts) = do { tc' <- tcIfaceTyCon tc; ts' <- tcIfaceTypes ts; return (mkTyConApp tc' ts') } tcIfaceType (IfaceForAllTy tv t) = bindIfaceTyVar tv $ \ tv' -> do { t' <- tcIfaceType t; return (ForAllTy tv' t') } -tcIfaceType (IfacePredTy st) = do { st' <- tcIfacePredType st; return (PredTy st') } +tcIfaceType (IfacePredTy st) = do { st' <- tcIfacePred tcIfaceType st; return (PredTy st') } +tcIfaceType t@(IfaceCoConApp {}) = pprPanic "tcIfaceType" (ppr t) tcIfaceTypes :: [IfaceType] -> IfL [Type] tcIfaceTypes tys = mapM tcIfaceType tys ----------------------------------------- -tcIfacePredType :: IfacePredType -> IfL PredType -tcIfacePredType (IfaceClassP cls ts) = do { cls' <- tcIfaceClass cls; ts' <- tcIfaceTypes ts; return (ClassP cls' ts') } -tcIfacePredType (IfaceIParam ip t) = do { ip' <- newIPName ip; t' <- tcIfaceType t; return (IParam ip' t') } -tcIfacePredType (IfaceEqPred t1 t2) = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (EqPred t1' t2') } +tcIfacePred :: (IfaceType -> IfL a) -> IfacePredType -> IfL (Pred a) +tcIfacePred tc (IfaceClassP cls ts) + = do { cls' <- tcIfaceClass cls; ts' <- mapM tc ts; return (ClassP cls' ts') } +tcIfacePred tc (IfaceIParam ip t) + = do { ip' <- newIPName ip; t' <- tc t; return (IParam ip' t') } +tcIfacePred tc (IfaceEqPred t1 t2) + = do { t1' <- tc t1; t2' <- tc t2; return (EqPred t1' t2') } ----------------------------------------- tcIfaceCtxt :: IfaceContext -> IfL ThetaType -tcIfaceCtxt sts = mapM tcIfacePredType sts +tcIfaceCtxt sts = mapM (tcIfacePred tcIfaceType) sts +\end{code} + +%************************************************************************ +%* * + Coercions +%* * +%************************************************************************ + +\begin{code} +tcIfaceCo :: IfaceType -> IfL Coercion +tcIfaceCo (IfaceTyVar n) = mkCoVarCo <$> tcIfaceCoVar n +tcIfaceCo (IfaceAppTy t1 t2) = mkAppCo <$> tcIfaceCo t1 <*> tcIfaceCo t2 +tcIfaceCo (IfaceFunTy t1 t2) = mkFunCo <$> tcIfaceCo t1 <*> tcIfaceCo t2 +tcIfaceCo (IfaceTyConApp tc ts) = mkTyConAppCo <$> tcIfaceTyCon tc <*> mapM tcIfaceCo ts +tcIfaceCo (IfaceCoConApp tc ts) = tcIfaceCoApp tc ts +tcIfaceCo (IfaceForAllTy tv t) = bindIfaceTyVar tv $ \ tv' -> + mkForAllCo tv' <$> tcIfaceCo t +-- tcIfaceCo (IfacePredTy co) = mkPredCo <$> tcIfacePred tcIfaceCo co +tcIfaceCo (IfacePredTy _) = panic "tcIfaceCo" + +tcIfaceCoApp :: IfaceCoCon -> [IfaceType] -> IfL Coercion +tcIfaceCoApp IfaceReflCo [t] = Refl <$> tcIfaceType t +tcIfaceCoApp (IfaceCoAx n) ts = AxiomInstCo <$> tcIfaceCoAxiom n <*> mapM tcIfaceCo ts +tcIfaceCoApp IfaceUnsafeCo [t1,t2] = UnsafeCo <$> tcIfaceType t1 <*> tcIfaceType t2 +tcIfaceCoApp IfaceSymCo [t] = SymCo <$> tcIfaceCo t +tcIfaceCoApp IfaceTransCo [t1,t2] = TransCo <$> tcIfaceCo t1 <*> tcIfaceCo t2 +tcIfaceCoApp IfaceInstCo [t1,t2] = InstCo <$> tcIfaceCo t1 <*> tcIfaceType t2 +tcIfaceCoApp (IfaceNthCo d) [t] = NthCo d <$> tcIfaceCo t +tcIfaceCoApp cc ts = pprPanic "toIfaceCoApp" (ppr cc <+> ppr ts) + +tcIfaceCoVar :: FastString -> IfL CoVar +tcIfaceCoVar = tcIfaceLclId \end{code} @@ -819,6 +860,12 @@ tcIfaceExpr :: IfaceExpr -> IfL CoreExpr tcIfaceExpr (IfaceType ty) = Type <$> tcIfaceType ty +tcIfaceExpr (IfaceCo co) + = Coercion <$> tcIfaceCo co + +tcIfaceExpr (IfaceCast expr co) + = Cast <$> tcIfaceExpr expr <*> tcIfaceCo co + tcIfaceExpr (IfaceLcl name) = Var <$> tcIfaceLclId name @@ -853,7 +900,7 @@ tcIfaceExpr (IfaceLam bndr body) tcIfaceExpr (IfaceApp fun arg) = App <$> tcIfaceExpr fun <*> tcIfaceExpr arg -tcIfaceExpr (IfaceCase scrut case_bndr ty alts) = do +tcIfaceExpr (IfaceCase scrut case_bndr alts) = do scrut' <- tcIfaceExpr scrut case_bndr_name <- newIfaceName (mkVarOccFS case_bndr) let @@ -868,28 +915,34 @@ tcIfaceExpr (IfaceCase scrut case_bndr ty alts) = do extendIfaceIdEnv [case_bndr'] $ do alts' <- mapM (tcIfaceAlt scrut' tc_app) alts - ty' <- tcIfaceType ty - return (Case scrut' case_bndr' ty' alts') + return (Case scrut' case_bndr' (coreAltsType alts') alts') -tcIfaceExpr (IfaceLet (IfaceNonRec bndr rhs) body) = do - rhs' <- tcIfaceExpr rhs - id <- tcIfaceLetBndr bndr - body' <- extendIfaceIdEnv [id] (tcIfaceExpr body) - return (Let (NonRec id rhs') body') - -tcIfaceExpr (IfaceLet (IfaceRec pairs) body) = do - ids <- mapM tcIfaceLetBndr bndrs - extendIfaceIdEnv ids $ do - rhss' <- mapM tcIfaceExpr rhss - body' <- tcIfaceExpr body - return (Let (Rec (ids `zip` rhss')) body') - where - (bndrs, rhss) = unzip pairs - -tcIfaceExpr (IfaceCast expr co) = do - expr' <- tcIfaceExpr expr - co' <- tcIfaceType co - return (Cast expr' co') +tcIfaceExpr (IfaceLet (IfaceNonRec (IfLetBndr fs ty info) rhs) body) + = do { name <- newIfaceName (mkVarOccFS fs) + ; ty' <- tcIfaceType ty + ; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -} + name ty' info + ; let id = mkLocalIdWithInfo name ty' id_info + ; rhs' <- tcIfaceExpr rhs + ; body' <- extendIfaceIdEnv [id] (tcIfaceExpr body) + ; return (Let (NonRec id rhs') body') } + +tcIfaceExpr (IfaceLet (IfaceRec pairs) body) + = do { ids <- mapM tc_rec_bndr (map fst pairs) + ; extendIfaceIdEnv ids $ do + { pairs' <- zipWithM tc_pair pairs ids + ; body' <- tcIfaceExpr body + ; return (Let (Rec pairs') body') } } + where + tc_rec_bndr (IfLetBndr fs ty _) + = do { name <- newIfaceName (mkVarOccFS fs) + ; ty' <- tcIfaceType ty + ; return (mkLocalId name ty') } + tc_pair (IfLetBndr _ _ info, rhs) id + = do { rhs' <- tcIfaceExpr rhs + ; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -} + (idName id) (idType id) info + ; return (setIdInfo id id_info, rhs') } tcIfaceExpr (IfaceNote note expr) = do expr' <- tcIfaceExpr expr @@ -930,14 +983,13 @@ tcIfaceDataAlt :: DataCon -> [Type] -> [FastString] -> IfaceExpr tcIfaceDataAlt con inst_tys arg_strs rhs = do { us <- newUniqueSupply ; let uniqs = uniqsFromSupply us - ; let (ex_tvs, co_tvs, arg_ids) + ; let (ex_tvs, arg_ids) = dataConRepFSInstPat arg_strs uniqs con inst_tys - all_tvs = ex_tvs ++ co_tvs - ; rhs' <- extendIfaceTyVarEnv all_tvs $ + ; rhs' <- extendIfaceTyVarEnv ex_tvs $ extendIfaceIdEnv arg_ids $ tcIfaceExpr rhs - ; return (DataAlt con, all_tvs ++ arg_ids, rhs') } + ; return (DataAlt con, ex_tvs ++ arg_ids, rhs') } \end{code} @@ -974,10 +1026,10 @@ do_one (IfaceRec pairs) thing_inside \begin{code} tcIdDetails :: Type -> IfaceIdDetails -> IfL IdDetails tcIdDetails _ IfVanillaId = return VanillaId -tcIdDetails ty IfDFunId - = return (DFunId (isNewTyCon (classTyCon cls))) +tcIdDetails ty (IfDFunId ns) + = return (DFunId ns (isNewTyCon (classTyCon cls))) where - (_, cls, _) = tcSplitDFunTy ty + (_, _, cls, _) = tcSplitDFunTy ty tcIdDetails _ (IfRecSelId tc naughty) = do { tc' <- tcIfaceTyCon tc @@ -1039,12 +1091,15 @@ tcUnfolding name _ _ (IfInlineRule arity unsat_ok boring_ok if_expr) } tcUnfolding name dfun_ty _ (IfDFunUnfold ops) - = do { mb_ops1 <- forkM_maybe doc $ mapM tcIfaceExpr ops + = do { mb_ops1 <- forkM_maybe doc $ mapM tc_arg ops ; return (case mb_ops1 of Nothing -> noUnfolding Just ops1 -> mkDFunUnfolding dfun_ty ops1) } where doc = text "Class ops for dfun" <+> ppr name + tc_arg (DFunPolyArg e) = do { e' <- tcIfaceExpr e; return (DFunPolyArg e') } + tc_arg (DFunConstArg e) = do { e' <- tcIfaceExpr e; return (DFunConstArg e') } + tc_arg (DFunLamArg i) = return (DFunLamArg i) tcUnfolding name ty info (IfExtWrapper arity wkr) = tcIfaceWrapper name ty info arity (tcIfaceExtId wkr) @@ -1091,7 +1146,9 @@ tcPragExpr name expr Just fail_msg -> do { mod <- getIfModule ; pprPanic "Iface Lint failure" (vcat [ ptext (sLit "In interface for") <+> ppr mod - , hang doc 2 fail_msg ]) } + , hang doc 2 fail_msg + , ppr name <+> equals <+> ppr core_expr' + , ptext (sLit "Iface expr =") <+> ppr expr ]) } return core_expr' where doc = text "Unfolding of" <+> ppr name @@ -1099,14 +1156,14 @@ tcPragExpr name expr get_in_scope :: IfL [Var] -- Totally disgusting; but just for linting get_in_scope = do { (gbl_env, lcl_env) <- getEnvs - ; setLclEnv () $ do - { case if_rec_types gbl_env of { - Nothing -> return [] ; - Just (_, get_env) -> do - { type_env <- get_env + ; rec_ids <- case if_rec_types gbl_env of + Nothing -> return [] + Just (_, get_env) -> do + { type_env <- setLclEnv () get_env + ; return (typeEnvIds type_env) } ; return (varEnvElts (if_tv_env lcl_env) ++ varEnvElts (if_id_env lcl_env) ++ - typeEnvIds type_env) }}}} + rec_ids) } \end{code} @@ -1200,6 +1257,10 @@ tcIfaceClass :: Name -> IfL Class tcIfaceClass name = do { thing <- tcIfaceGlobal name ; return (tyThingClass thing) } +tcIfaceCoAxiom :: Name -> IfL CoAxiom +tcIfaceCoAxiom name = do { thing <- tcIfaceGlobal name + ; return (tyThingCoAxiom thing) } + tcIfaceDataCon :: Name -> IfL DataCon tcIfaceDataCon name = do { thing <- tcIfaceGlobal name ; case thing of @@ -1236,16 +1297,6 @@ bindIfaceBndrs (b:bs) thing_inside bindIfaceBndrs bs $ \ bs' -> thing_inside (b':bs') - ------------------------ -tcIfaceLetBndr :: IfaceLetBndr -> IfL Id -tcIfaceLetBndr (IfLetBndr fs ty info) - = do { name <- newIfaceName (mkVarOccFS fs) - ; ty' <- tcIfaceType ty - ; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -} - name ty' info - ; return (mkLocalIdWithInfo name ty' id_info) } - ----------------------- newExtCoreBndr :: IfaceLetBndr -> IfL Id newExtCoreBndr (IfLetBndr var ty _) -- Ignoring IdInfo for now