X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fiface%2FTcIface.lhs;h=c39b713f9fc57ed2ebe6b08996b8b4cce6d56ebd;hp=d8bd414edde3c6a2cb6f3c0e708e7b042cf36cb9;hb=9a81ddfb43b96cfeae2236c9616ca3552250b235;hpb=c9959e41ee1d72aa0ca28d51580f1ad3c06f0e8b diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index d8bd414..c39b713 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -39,8 +39,8 @@ import TyCon import DataCon import TysWiredIn import TysPrim ( anyTyConOfKind ) -import Var ( TyVar ) -import BasicTypes ( nonRuleLoopBreaker ) +import Var ( Var, TyVar ) +import BasicTypes ( Arity, nonRuleLoopBreaker ) import qualified Var import VarEnv import Name @@ -414,16 +414,21 @@ 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 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, @@ -434,34 +439,33 @@ tcIfaceDecl _ (IfaceData {ifName = occ_name, { 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 + want_generic 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, @@ -473,9 +477,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) @@ -492,7 +496,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)) } @@ -507,7 +511,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 @@ -623,7 +627,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) $ @@ -636,6 +641,7 @@ tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bnd ru_bndrs = bndrs', ru_args = args', 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 @@ -915,7 +921,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 } @@ -1004,11 +1010,14 @@ tcIdInfo ignore_prags name ty info \begin{code} tcUnfolding :: Name -> Type -> IdInfo -> IfaceUnfolding -> IfL Unfolding -tcUnfolding name _ info (IfCoreUnfold if_expr) +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 -> mkTopUnfolding is_bottoming expr) } + 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 @@ -1025,12 +1034,27 @@ 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 True InlineRule expr arity + Just expr -> mkCoreUnfolding InlineStable True expr arity (UnfWhen unsat_ok boring_ok)) } -tcUnfolding name ty info (IfWrapper arity wkr) - = do { mb_wkr_id <- forkM_maybe doc (tcIfaceExtId wkr) +tcUnfolding name dfun_ty _ (IfDFunUnfold ops) + = do { mb_ops1 <- forkM_maybe doc $ mapM tcIfaceExpr ops + ; return (case mb_ops1 of + Nothing -> noUnfolding + Just ops1 -> mkDFunUnfolding dfun_ty ops1) } + where + doc = text "Class ops for dfun" <+> ppr name + +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 -> noUnfolding @@ -1047,17 +1071,7 @@ tcUnfolding name ty info (IfWrapper arity wkr) -- before unfolding strict_sig = case strictnessInfo info of Just sig -> sig - Nothing -> pprPanic "Worker info but no strictness for" (ppr wkr) - -tcUnfolding name dfun_ty _ (IfDFunUnfold ops) - = do { mb_ops1 <- forkM_maybe doc $ mapM tcIfaceExpr ops - ; return (case mb_ops1 of - Nothing -> noUnfolding - Just ops1 -> DFunUnfolding data_con ops1) } - where - doc = text "Class ops for dfun" <+> ppr name - (_, cls, _) = tcSplitDFunTy dfun_ty - data_con = classDataCon cls + 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 @@ -1070,23 +1084,29 @@ 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 ]) } 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 + ; setLclEnv () $ do + { case if_rec_types gbl_env of { + Nothing -> return [] ; + Just (_, get_env) -> do + { type_env <- get_env + ; return (varEnvElts (if_tv_env lcl_env) ++ + varEnvElts (if_id_env lcl_env) ++ + typeEnvIds type_env) }}}} \end{code} @@ -1222,17 +1242,9 @@ 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 `setStrictnessInfo` Just s - tc_info (other : i) = pprTrace "tcIfaceLetBndr: discarding unexpected IdInfo" - (ppr other) (tc_info i) + ; 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