X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fiface%2FTcIface.lhs;h=5bfb406c026807d6aa1af13f9474ebaa93716225;hp=7db955162fb2122ecd2161db8a036eb492163266;hb=86add45dbfb6f962b65e371143dd467ae783f9e7;hpb=703ca1542c8e0983cc9d8eebce6e9f3dd3fd71e2 diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index 7db9551..5bfb406 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -19,7 +19,9 @@ import LoadIface import IfaceEnv import BuildTyCl import TcRnMonad +import TcType import Type +import Coercion import TypeRep import HscTypes import Annotations @@ -37,13 +39,18 @@ import Class import TyCon import DataCon import TysWiredIn -import Var ( TyVar ) +import TysPrim ( anyTyConOfKind ) +import BasicTypes ( Arity, nonRuleLoopBreaker ) import qualified Var import VarEnv +import VarSet import Name import NameEnv +import NameSet +import OccurAnal ( occurAnalyseExpr ) +import Demand ( isBottomingSig ) import Module -import LazyUniqFM +import UniqFM import UniqSupply import Outputable import ErrUtils @@ -52,7 +59,6 @@ import SrcLoc import DynFlags import Util import FastString -import BasicTypes (Arity) import Control.Monad import Data.List @@ -410,54 +416,57 @@ the forkM stuff. tcIfaceDecl :: Bool -- True <=> discard IdInfo on IfaceId bindings -> IfaceDecl -> IfL TyThing - -tcIfaceDecl ignore_prags (IfaceId {ifName = occ_name, ifType = iface_type, - ifIdDetails = details, ifIdInfo = info}) +tcIfaceDecl = tc_iface_decl NoParentTyCon + +tc_iface_decl :: TyConParent -- For nested declarations + -> Bool -- True <=> discard IdInfo on IfaceId bindings + -> IfaceDecl + -> IfL TyThing +tc_iface_decl _ ignore_prags (IfaceId {ifName = occ_name, ifType = iface_type, + ifIdDetails = details, ifIdInfo = info}) = do { name <- lookupIfaceTop occ_name ; ty <- tcIfaceType iface_type - ; details <- tcIdDetails details + ; details <- tcIdDetails ty details ; info <- tcIdInfo ignore_prags name ty info ; return (AnId (mkGlobalId details name ty info)) } -tcIfaceDecl _ (IfaceData {ifName = occ_name, +tc_iface_decl parent _ (IfaceData {ifName = occ_name, ifTyVars = tv_bndrs, 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 ; tycon <- fixM ( \ tycon -> do { stupid_theta <- tcIfaceCtxt ctxt - ; mb_fam_inst <- tcFamInst mb_family ; cons <- tcIfaceDataCons tc_name tycon tyvars rdr_cons - ; buildAlgTyCon tc_name tyvars stupid_theta - cons is_rec want_generic gadt_syn mb_fam_inst + ; mb_fam_inst <- tcFamInst mb_family + ; buildAlgTyCon tc_name tyvars stupid_theta cons is_rec + gadt_syn parent mb_fam_inst }) ; traceIf (text "tcIfaceDecl4" <+> ppr tycon) ; return (ATyCon tycon) } -tcIfaceDecl _ (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs, - ifSynRhs = mb_rhs_ty, - ifSynKind = kind, ifFamInst = mb_family}) +tc_iface_decl parent _ (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs, + ifSynRhs = mb_rhs_ty, + ifSynKind = kind, ifFamInst = mb_family}) = bindIfaceTyVars_AT tv_bndrs $ \ tyvars -> do - { tc_name <- lookupIfaceTop occ_name + { tc_name <- lookupIfaceTop occ_name ; rhs_kind <- tcIfaceType kind -- Note [Synonym kind loop] - ; ~(rhs, fam) <- forkM (mk_doc tc_name) $ - do { rhs <- tc_syn_rhs rhs_kind mb_rhs_ty - ; fam <- tcFamInst mb_family - ; return (rhs, fam) } - ; tycon <- buildSynTyCon tc_name tyvars rhs rhs_kind fam - ; return $ ATyCon tycon + ; rhs <- forkM (mk_doc tc_name) $ + tc_syn_rhs mb_rhs_ty + ; fam_info <- tcFamInst mb_family + ; tycon <- buildSynTyCon tc_name tyvars rhs rhs_kind parent fam_info + ; return (ATyCon tycon) } where mk_doc n = ptext (sLit "Type syonym") <+> ppr n - tc_syn_rhs kind Nothing = return (OpenSynTyCon kind Nothing) - tc_syn_rhs _ (Just ty) = do { rhs_ty <- tcIfaceType ty - ; return (SynonymTyCon rhs_ty) } + tc_syn_rhs Nothing = return SynFamilyTyCon + tc_syn_rhs (Just ty) = do { rhs_ty <- tcIfaceType ty + ; return (SynonymTyCon rhs_ty) } -tcIfaceDecl ignore_prags +tc_iface_decl _parent ignore_prags (IfaceClass {ifCtxt = rdr_ctxt, ifName = occ_name, ifTyVars = tv_bndrs, ifFDs = rdr_fds, ifATs = rdr_ats, ifSigs = rdr_sigs, @@ -469,9 +478,9 @@ tcIfaceDecl ignore_prags ; ctxt <- tcIfaceCtxt rdr_ctxt ; sigs <- mapM tc_sig rdr_sigs ; fds <- mapM tc_fd rdr_fds - ; ats' <- mapM (tcIfaceDecl ignore_prags) rdr_ats - ; let ats = map (setAssocFamilyPermutation tyvars) ats' - ; cls <- buildClass ignore_prags cls_name tyvars ctxt fds ats sigs tc_isrec + ; cls <- fixM $ \ cls -> do + { ats <- mapM (tc_iface_decl (AssocFamilyTyCon cls) ignore_prags) rdr_ats + ; buildClass ignore_prags cls_name tyvars ctxt fds ats sigs tc_isrec } ; return (AClass cls) } where tc_sig (IfaceClassOp occ dm rdr_ty) @@ -488,7 +497,7 @@ tcIfaceDecl ignore_prags ; tvs2' <- mapM tcIfaceTyVar tvs2 ; return (tvs1', tvs2') } -tcIfaceDecl _ (IfaceForeign {ifName = rdr_name, ifExtName = ext_name}) +tc_iface_decl _ _ (IfaceForeign {ifName = rdr_name, ifExtName = ext_name}) = do { name <- lookupIfaceTop rdr_name ; return (ATyCon (mkForeignTyCon name ext_name liftedTypeKind 0)) } @@ -503,7 +512,7 @@ tcIfaceDataCons :: Name -> TyCon -> [TyVar] -> IfaceConDecls -> IfL AlgTyConRhs tcIfaceDataCons tycon_name tycon _ if_cons = case if_cons of IfAbstractTyCon -> return mkAbstractTyConRhs - IfOpenDataTyCon -> return mkOpenDataTyConRhs + IfOpenDataTyCon -> return DataFamilyTyCon IfDataTyCon cons -> do { data_cons <- mapM tc_con_decl cons ; return (mkDataTyConRhs data_cons) } IfNewTyCon con -> do { data_con <- tc_con_decl con @@ -619,7 +628,8 @@ tcIfaceRules ignore_prags if_rules tcIfaceRule :: IfaceRule -> IfL CoreRule tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs, - ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs }) + ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs, + ifRuleAuto = auto }) = do { ~(bndrs', args', rhs') <- -- Typecheck the payload lazily, in the hope it'll never be looked at forkM (ptext (sLit "Rule") <+> ftext name) $ @@ -630,8 +640,9 @@ tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bnd ; let mb_tcs = map ifTopFreeName args ; return (Rule { ru_name = name, ru_fn = fn, ru_act = act, ru_bndrs = bndrs', ru_args = args', - ru_rhs = rhs', + ru_rhs = occurAnalyseExpr rhs', ru_rough = mb_tcs, + ru_auto = auto, ru_local = False }) } -- An imported RULE is never for a local Id -- or, even if it is (module loop, perhaps) -- we'll just leave it in the non-local set @@ -680,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 @@ -769,9 +784,9 @@ tcIfaceVectInfo mod typeEnv (IfaceVectInfo \end{code} %************************************************************************ -%* * - Types -%* * +%* * + Types +%* * %************************************************************************ \begin{code} @@ -781,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} @@ -809,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 @@ -843,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 @@ -858,33 +915,38 @@ 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') - -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') + return (Case scrut' case_bndr' (coreAltsType alts') alts') + +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 case note of - IfaceInlineMe -> return (Note InlineMe expr') IfaceSCC cc -> return (Note (SCC cc) expr') IfaceCoreNote n -> return (Note (CoreNote n) expr') @@ -912,7 +974,7 @@ tcIfaceAlt scrut (tycon, inst_tys) (IfaceDataAlt data_occ, arg_strs, rhs) ; tcIfaceDataAlt con inst_tys arg_strs rhs } tcIfaceAlt _ (tycon, inst_tys) (IfaceTupleAlt _boxity, arg_occs, rhs) - = ASSERT( isTupleTyCon tycon ) + = ASSERT2( isTupleTyCon tycon, ppr tycon ) do { let [data_con] = tyConDataCons tycon ; tcIfaceDataAlt data_con inst_tys arg_occs rhs } @@ -921,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} @@ -963,10 +1024,14 @@ do_one (IfaceRec pairs) thing_inside %************************************************************************ \begin{code} -tcIdDetails :: IfaceIdDetails -> IfL IdDetails -tcIdDetails IfVanillaId = return VanillaId -tcIdDetails IfDFunId = return DFunId -tcIdDetails (IfRecSelId tc naughty) +tcIdDetails :: Type -> IfaceIdDetails -> IfL IdDetails +tcIdDetails _ IfVanillaId = return VanillaId +tcIdDetails ty (IfDFunId ns) + = return (DFunId ns (isNewTyCon (classTyCon cls))) + where + (_, _, cls, _) = tcSplitDFunTy ty + +tcIdDetails _ (IfRecSelId tc naughty) = do { tc' <- tcIfaceTyCon tc ; return (RecSelId { sel_tycon = tc', sel_naughty = naughty }) } @@ -982,52 +1047,86 @@ tcIdInfo ignore_prags name ty info init_info = vanillaIdInfo tcPrag :: IdInfo -> IfaceInfoItem -> IfL IdInfo - tcPrag info HsNoCafRefs = return (info `setCafInfo` NoCafRefs) - tcPrag info (HsArity arity) = return (info `setArityInfo` arity) - tcPrag info (HsStrictness str) = return (info `setAllStrictnessInfo` Just str) + tcPrag info HsNoCafRefs = return (info `setCafInfo` NoCafRefs) + tcPrag info (HsArity arity) = return (info `setArityInfo` arity) + tcPrag info (HsStrictness str) = return (info `setStrictnessInfo` Just str) + tcPrag info (HsInline prag) = return (info `setInlinePragInfo` prag) -- The next two are lazy, so they don't transitively suck stuff in - tcPrag info (HsWorker nm arity) = tcWorkerInfo ty info nm arity - tcPrag info (HsInline inline_prag) = return (info `setInlinePragInfo` inline_prag) - tcPrag info (HsUnfold expr) = do - maybe_expr' <- tcPragExpr name expr - let - -- maybe_expr' doesn't get looked at if the unfolding - -- is never inspected; so the typecheck doesn't even happen - unfold_info = case maybe_expr' of - Nothing -> noUnfolding - Just expr' -> mkTopUnfolding expr' - return (info `setUnfoldingInfoLazily` unfold_info) + tcPrag info (HsUnfold lb if_unf) + = do { unf <- tcUnfolding name ty info if_unf + ; let info1 | lb = info `setOccInfo` nonRuleLoopBreaker + | otherwise = info + ; return (info1 `setUnfoldingInfoLazily` unf) } \end{code} \begin{code} -tcWorkerInfo :: Type -> IdInfo -> Name -> Arity -> IfL IdInfo -tcWorkerInfo ty info wkr arity - = do { mb_wkr_id <- forkM_maybe doc (tcIfaceExtId wkr) - - -- We return without testing maybe_wkr_id, but as soon as info is - -- looked at we will test it. That's ok, because its outside the - -- knot; and there seems no big reason to further defer the - -- tcIfaceId lookup. (Contrast with tcPragExpr, where postponing walking - -- over the unfolding until it's actually used does seem worth while.) - ; us <- newUniqueSupply +tcUnfolding :: Name -> Type -> IdInfo -> IfaceUnfolding -> IfL Unfolding +tcUnfolding name _ info (IfCoreUnfold stable if_expr) + = do { mb_expr <- tcPragExpr name if_expr + ; let unf_src = if stable then InlineStable else InlineRhs + ; return (case mb_expr of + Nothing -> NoUnfolding + Just expr -> mkUnfolding unf_src + True {- Top level -} + is_bottoming expr) } + where + -- Strictness should occur before unfolding! + is_bottoming = case strictnessInfo info of + Just sig -> isBottomingSig sig + Nothing -> False + +tcUnfolding name _ _ (IfCompulsory if_expr) + = do { mb_expr <- tcPragExpr name if_expr + ; return (case mb_expr of + Nothing -> NoUnfolding + Just expr -> mkCompulsoryUnfolding expr) } + +tcUnfolding name _ _ (IfInlineRule arity unsat_ok boring_ok if_expr) + = do { mb_expr <- tcPragExpr name if_expr + ; return (case mb_expr of + Nothing -> NoUnfolding + Just expr -> mkCoreUnfolding InlineStable True expr arity + (UnfWhen unsat_ok boring_ok)) + } +tcUnfolding name dfun_ty _ (IfDFunUnfold 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) +tcUnfolding name ty info (IfLclWrapper arity wkr) + = tcIfaceWrapper name ty info arity (tcIfaceLclId wkr) + +------------- +tcIfaceWrapper :: Name -> Type -> IdInfo -> Arity -> IfL Id -> IfL Unfolding +tcIfaceWrapper name ty info arity get_worker + = do { mb_wkr_id <- forkM_maybe doc get_worker + ; us <- newUniqueSupply ; return (case mb_wkr_id of - Nothing -> info - Just wkr_id -> add_wkr_info us wkr_id info) } + Nothing -> noUnfolding + Just wkr_id -> make_inline_rule wkr_id us) } where - doc = text "Worker for" <+> ppr wkr - add_wkr_info us wkr_id info - = info `setUnfoldingInfoLazily` mk_unfolding us wkr_id - `setWorkerInfo` HasWorker wkr_id arity + doc = text "Worker for" <+> ppr name - mk_unfolding us wkr_id = mkTopUnfolding (initUs_ us (mkWrapper ty strict_sig) wkr_id) + make_inline_rule wkr_id us + = mkWwInlineRule wkr_id + (initUs_ us (mkWrapper ty strict_sig) wkr_id) + arity - -- We are relying here on strictness info always appearing - -- before worker info, fingers crossed .... - strict_sig = case newStrictnessInfo info of + -- Again we rely here on strictness info always appearing + -- before unfolding + strict_sig = case strictnessInfo info of Just sig -> sig - Nothing -> pprPanic "Worker info but no strictness for" (ppr wkr) + Nothing -> pprPanic "Worker info but no strictness for" (ppr name) \end{code} For unfoldings we try to do the job lazily, so that we never type check @@ -1040,23 +1139,31 @@ tcPragExpr name expr core_expr' <- tcIfaceExpr expr -- Check for type consistency in the unfolding - ifOptM Opt_DoCoreLinting $ do - in_scope <- get_in_scope_ids + ifDOptM Opt_DoCoreLinting $ do + in_scope <- get_in_scope case lintUnfolding noSrcLoc in_scope core_expr' of Nothing -> return () - Just fail_msg -> pprPanic "Iface Lint failure" (hang doc 2 fail_msg) - + Just fail_msg -> do { mod <- getIfModule + ; pprPanic "Iface Lint failure" + (vcat [ ptext (sLit "In interface for") <+> ppr mod + , 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 - get_in_scope_ids -- Urgh; but just for linting - = setLclEnv () $ - do { env <- getGblEnv - ; case if_rec_types env of { - Nothing -> return [] ; - Just (_, get_env) -> do - { type_env <- get_env - ; return (typeEnvIds type_env) }}} + + get_in_scope :: IfL [Var] -- Totally disgusting; but just for linting + get_in_scope + = do { (gbl_env, lcl_env) <- getEnvs + ; 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) ++ + rec_ids) } \end{code} @@ -1122,6 +1229,8 @@ tcIfaceTyCon IfaceCharTc = tcWiredInTyCon charTyCon tcIfaceTyCon IfaceListTc = tcWiredInTyCon listTyCon tcIfaceTyCon IfacePArrTc = tcWiredInTyCon parrTyCon tcIfaceTyCon (IfaceTupTc bx ar) = tcWiredInTyCon (tupleTyCon bx ar) +tcIfaceTyCon (IfaceAnyTc kind) = do { tc_kind <- tcIfaceType kind + ; tcWiredInTyCon (anyTyConOfKind tc_kind) } tcIfaceTyCon (IfaceTc name) = do { thing <- tcIfaceGlobal name ; return (check_tc (tyThingTyCon thing)) } where @@ -1148,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 @@ -1184,24 +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 - ; case info of - NoInfo -> return (mkLocalId name ty') - HasInfo i -> return (mkLocalIdWithInfo name ty' (tc_info i)) } - where - -- Similar to tcIdInfo, but much simpler - tc_info [] = vanillaIdInfo - tc_info (HsInline p : i) = tc_info i `setInlinePragInfo` p - tc_info (HsArity a : i) = tc_info i `setArityInfo` a - tc_info (HsStrictness s : i) = tc_info i `setAllStrictnessInfo` Just s - tc_info (other : i) = pprTrace "tcIfaceLetBndr: discarding unexpected IdInfo" - (ppr other) (tc_info i) - ----------------------- newExtCoreBndr :: IfaceLetBndr -> IfL Id newExtCoreBndr (IfLetBndr var ty _) -- Ignoring IdInfo for now