X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fiface%2FTcIface.lhs;h=f29bf856c8452384536b523cd07f7963d0b669c6;hp=7416a5f0d886c236937512ae11659a892aab4ec1;hb=b2524b3960999fffdb3767900f58825903f6560f;hpb=b0c46848af7e431a2898af1a8aa1fbb0d2499137 diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index 7416a5f..f29bf85 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -9,7 +9,7 @@ Type checking of type signatures in interface files module TcIface ( tcImportDecl, checkWiredInTyCon, tcHiBootIface, typecheckIface, tcIfaceDecl, tcIfaceInst, tcIfaceFamInst, tcIfaceRules, - tcIfaceVectInfo, tcIfaceGlobal, tcExtCoreBindings + tcIfaceVectInfo, tcIfaceAnnotations, tcIfaceGlobal, tcExtCoreBindings ) where #include "HsVersions.h" @@ -19,9 +19,12 @@ import LoadIface import IfaceEnv import BuildTyCl import TcRnMonad +import TcType import Type +import Coercion import TypeRep import HscTypes +import Annotations import InstEnv import FamInstEnv import CoreSyn @@ -36,12 +39,14 @@ import Class import TyCon import DataCon import TysWiredIn -import Var ( TyVar ) +import TysPrim ( anyTyConOfKind ) +import BasicTypes ( Arity, nonRuleLoopBreaker ) import qualified Var import VarEnv import Name import NameEnv -import OccName +import OccurAnal ( occurAnalyseExpr ) +import Demand ( isBottomingSig ) import Module import UniqFM import UniqSupply @@ -50,10 +55,11 @@ import ErrUtils import Maybes import SrcLoc import DynFlags -import Control.Monad +import Util +import FastString +import Control.Monad import Data.List -import Data.Maybe \end{code} This module takes @@ -65,7 +71,7 @@ This module takes An IfaceDecl is populated with RdrNames, and these are not renamed to Names before typechecking, because there should be no scope errors etc. - -- For (b) consider: f = $(...h....) + -- For (b) consider: f = \$(...h....) -- where h is imported, and calls f via an hi-boot file. -- This is bad! But it is not seen as a staging error, because h -- is indeed imported. We don't want the type-checker to black-hole @@ -104,8 +110,9 @@ tcImportDecl :: Name -> TcM TyThing -- Entry point for *source-code* uses of importDecl tcImportDecl name | Just thing <- wiredInNameTyThing_maybe name - = do { initIfaceTcRn (loadWiredInHomeIface name) - -- See Note [Loading instances] in LoadIface + = do { when (needWiredInHomeIface thing) + (initIfaceTcRn (loadWiredInHomeIface name)) + -- See Note [Loading instances for wired-in things] ; return thing } | otherwise = do { traceIf (text "tcImportDecl" <+> ppr name) @@ -114,25 +121,6 @@ tcImportDecl name Succeeded thing -> return thing Failed err -> failWithTc err } -checkWiredInTyCon :: TyCon -> TcM () --- Ensure that the home module of the TyCon (and hence its instances) --- are loaded. See See Note [Loading instances] in LoadIface --- It might not be a wired-in tycon (see the calls in TcUnify), --- in which case this is a no-op. -checkWiredInTyCon tc - | not (isWiredInName tc_name) - = return () - | otherwise - = do { mod <- getModule - ; unless (mod == nameModule tc_name) - (initIfaceTcRn (loadWiredInHomeIface tc_name)) - -- Don't look for (non-existent) Float.hi when - -- compiling Float.lhs, which mentions Float of course - -- A bit yukky to call initIfaceTcRn here - } - where - tc_name = tyConName tc - importDecl :: Name -> IfM lcl (MaybeErr Message TyThing) -- Get the TyThing for this Name from an interface file -- It's not a wired-in thing -- the caller caught that @@ -141,10 +129,11 @@ importDecl name do { traceIf nd_doc -- Load the interface, which should populate the PTE - ; mb_iface <- loadInterface nd_doc (nameModule name) ImportBySystem + ; mb_iface <- ASSERT2( isExternalName name, ppr name ) + loadInterface nd_doc (nameModule name) ImportBySystem ; case mb_iface of { Failed err_msg -> return (Failed err_msg) ; - Succeeded iface -> do + Succeeded _ -> do -- Now look it up again; this time we should find it { eps <- getEps @@ -153,11 +142,88 @@ importDecl name Nothing -> return (Failed not_found_msg) }}} where - nd_doc = ptext SLIT("Need decl for") <+> ppr name - not_found_msg = hang (ptext SLIT("Can't find interface-file declaration for") <+> - pprNameSpace (occNameSpace (nameOccName name)) <+> ppr name) - 2 (vcat [ptext SLIT("Probable cause: bug in .hi-boot file, or inconsistent .hi file"), - ptext SLIT("Use -ddump-if-trace to get an idea of which file caused the error")]) + nd_doc = ptext (sLit "Need decl for") <+> ppr name + not_found_msg = hang (ptext (sLit "Can't find interface-file declaration for") <+> + pprNameSpace (occNameSpace (nameOccName name)) <+> (ppr (nameOccName name))) + 2 (vcat [ptext (sLit "Probable cause: bug in .hi-boot file, or inconsistent .hi file"), + ptext (sLit "Use -ddump-if-trace to get an idea of which file caused the error")]) +\end{code} + +%************************************************************************ +%* * + Checks for wired-in things +%* * +%************************************************************************ + +Note [Loading instances for wired-in things] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We need to make sure that we have at least *read* the interface files +for any module with an instance decl or RULE that we might want. + +* If the instance decl is an orphan, we have a whole separate mechanism + (loadOprhanModules) + +* If the instance decl not an orphan, then the act of looking at the + TyCon or Class will force in the defining module for the + TyCon/Class, and hence the instance decl + +* BUT, if the TyCon is a wired-in TyCon, we don't really need its interface; + but we must make sure we read its interface in case it has instances or + rules. That is what LoadIface.loadWiredInHomeInterface does. It's called + from TcIface.{tcImportDecl, checkWiredInTyCon, ifCheckWiredInThing} + +* HOWEVER, only do this for TyCons. There are no wired-in Classes. There + are some wired-in Ids, but we don't want to load their interfaces. For + example, Control.Exception.Base.recSelError is wired in, but that module + is compiled late in the base library, and we don't want to force it to + load before it's been compiled! + +All of this is done by the type checker. The renamer plays no role. +(It used to, but no longer.) + + +\begin{code} +checkWiredInTyCon :: TyCon -> TcM () +-- Ensure that the home module of the TyCon (and hence its instances) +-- are loaded. See Note [Loading instances for wired-in things] +-- It might not be a wired-in tycon (see the calls in TcUnify), +-- in which case this is a no-op. +checkWiredInTyCon tc + | not (isWiredInName tc_name) + = return () + | otherwise + = do { mod <- getModule + ; ASSERT( isExternalName tc_name ) + when (mod /= nameModule tc_name) + (initIfaceTcRn (loadWiredInHomeIface tc_name)) + -- Don't look for (non-existent) Float.hi when + -- compiling Float.lhs, which mentions Float of course + -- A bit yukky to call initIfaceTcRn here + } + where + tc_name = tyConName tc + +ifCheckWiredInThing :: TyThing -> IfL () +-- Even though we are in an interface file, we want to make +-- sure the instances of a wired-in thing are loaded (imagine f :: Double -> Double) +-- Ditto want to ensure that RULES are loaded too +-- See Note [Loading instances for wired-in things] +ifCheckWiredInThing thing + = do { mod <- getIfModule + -- Check whether we are typechecking the interface for this + -- very module. E.g when compiling the base library in --make mode + -- we may typecheck GHC.Base.hi. At that point, GHC.Base is not in + -- the HPT, so without the test we'll demand-load it into the PIT! + -- C.f. the same test in checkWiredInTyCon above + ; let name = getName thing + ; ASSERT2( isExternalName name, ppr name ) + when (needWiredInHomeIface thing && mod /= nameModule name) + (loadWiredInHomeIface name) } + +needWiredInHomeIface :: TyThing -> Bool +-- Only for TyCons; see Note [Loading instances for wired-in things] +needWiredInHomeIface (ATyCon {}) = True +needWiredInHomeIface _ = False \end{code} %************************************************************************ @@ -196,10 +262,11 @@ typecheckIface iface ; let type_env = mkNameEnv names_w_things ; writeMutVar tc_env_var type_env - -- Now do those rules and instances + -- Now do those rules, instances and annotations ; insts <- mapM tcIfaceInst (mi_insts iface) ; fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface) ; rules <- tcIfaceRules ignore_prags (mi_rules iface) + ; anns <- tcIfaceAnnotations (mi_anns iface) -- Vectorisation information ; vect_info <- tcIfaceVectInfo (mi_module iface) type_env @@ -215,9 +282,9 @@ typecheckIface iface , md_insts = insts , md_fam_insts = fam_insts , md_rules = rules + , md_anns = anns , md_vect_info = vect_info , md_exports = exports - , md_modBreaks = emptyModBreaks } } \end{code} @@ -256,7 +323,7 @@ tcHiBootIface hsc_src mod ; case lookupUFM hpt (moduleName mod) of Just info | mi_boot (hm_iface info) -> return (hm_details info) - other -> return emptyModDetails } + _ -> return emptyModDetails } else do -- OK, so we're in one-shot mode. @@ -282,13 +349,13 @@ tcHiBootIface hsc_src mod Succeeded (iface, _path) -> typecheckIface iface }}}} where - need = ptext SLIT("Need the hi-boot interface for") <+> ppr mod - <+> ptext SLIT("to compare against the Real Thing") + need = ptext (sLit "Need the hi-boot interface for") <+> ppr mod + <+> ptext (sLit "to compare against the Real Thing") - moduleLoop = ptext SLIT("Circular imports: module") <+> quotes (ppr mod) - <+> ptext SLIT("depends on itself") + moduleLoop = ptext (sLit "Circular imports: module") <+> quotes (ppr mod) + <+> ptext (sLit "depends on itself") - elaborate err = hang (ptext SLIT("Could not find hi-boot interface for") <+> + elaborate err = hang (ptext (sLit "Could not find hi-boot interface for") <+> quotes (ppr mod) <> colon) 4 err \end{code} @@ -347,63 +414,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, 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 (mkVanillaGlobal name ty info)) } - -tcIfaceDecl ignore_prags - (IfaceData {ifName = occ_name, - ifTyVars = tv_bndrs, - ifCtxt = ctxt, ifGadtSyntax = gadt_syn, - ifCons = rdr_cons, - ifRec = is_rec, - ifGeneric = want_generic, - ifFamInst = mb_family }) - = do { tc_name <- lookupIfaceTop occ_name - ; bindIfaceTyVars tv_bndrs $ \ tyvars -> do - - { tycon <- fixM ( \ tycon -> do + ; return (AnId (mkGlobalId details name ty info)) } + +tc_iface_decl parent _ (IfaceData {ifName = occ_name, + ifTyVars = tv_bndrs, + ifCtxt = ctxt, ifGadtSyntax = gadt_syn, + ifCons = rdr_cons, + ifRec = is_rec, + ifFamInst = mb_family }) + = bindIfaceTyVars_AT tv_bndrs $ \ tyvars -> do + { tc_name <- lookupIfaceTop occ_name + ; tycon <- fixM ( \ tycon -> do { stupid_theta <- tcIfaceCtxt ctxt - ; famInst <- - case mb_family of - Nothing -> return Nothing - Just (fam, tys) -> - do { famTyCon <- tcIfaceTyCon fam - ; insttys <- mapM tcIfaceType tys - ; return $ Just (famTyCon, insttys) - } ; cons <- tcIfaceDataCons tc_name tycon tyvars rdr_cons - ; buildAlgTyCon tc_name tyvars stupid_theta - cons is_rec want_generic gadt_syn famInst + ; 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 ignore_prags - (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs, - ifOpenSyn = isOpen, ifSynRhs = rdr_rhs_ty, - ifFamInst = mb_family}) - = bindIfaceTyVars tv_bndrs $ \ tyvars -> do - { tc_name <- lookupIfaceTop occ_name - ; rhs_tyki <- tcIfaceType rdr_rhs_ty - ; let rhs = if isOpen then OpenSynTyCon rhs_tyki Nothing - else SynonymTyCon rhs_tyki - ; famInst <- case mb_family of - Nothing -> return Nothing - Just (fam, tys) -> - do { famTyCon <- tcIfaceTyCon fam - ; insttys <- mapM tcIfaceType tys - ; return $ Just (famTyCon, insttys) - } - ; tycon <- buildSynTyCon tc_name tyvars rhs famInst - ; return $ ATyCon tycon + ; traceIf (text "tcIfaceDecl4" <+> ppr tycon) + ; return (ATyCon tycon) } + +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 + ; rhs_kind <- tcIfaceType kind -- Note [Synonym kind loop] + ; 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 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, @@ -413,11 +474,11 @@ tcIfaceDecl ignore_prags = bindIfaceTyVars tv_bndrs $ \ tyvars -> do { cls_name <- lookupIfaceTop occ_name ; ctxt <- tcIfaceCtxt rdr_ctxt - ; sigs <- mappM tc_sig rdr_sigs - ; fds <- mappM tc_fd rdr_fds - ; ats' <- mappM (tcIfaceDecl ignore_prags) rdr_ats - ; let ats = zipWith setTyThingPoss ats' (map ifTyVars rdr_ats) - ; cls <- buildClass cls_name tyvars ctxt fds ats sigs tc_isrec + ; sigs <- mapM tc_sig rdr_sigs + ; fds <- mapM tc_fd rdr_fds + ; 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) @@ -428,35 +489,29 @@ tcIfaceDecl ignore_prags -- it mentions unless it's necessray to do so ; return (op_name, dm, op_ty) } - mk_doc op_name op_ty = ptext SLIT("Class op") <+> sep [ppr op_name, ppr op_ty] + mk_doc op_name op_ty = ptext (sLit "Class op") <+> sep [ppr op_name, ppr op_ty] - tc_fd (tvs1, tvs2) = do { tvs1' <- mappM tcIfaceTyVar tvs1 - ; tvs2' <- mappM tcIfaceTyVar tvs2 + tc_fd (tvs1, tvs2) = do { tvs1' <- mapM tcIfaceTyVar tvs1 + ; tvs2' <- mapM tcIfaceTyVar tvs2 ; return (tvs1', tvs2') } - -- For each AT argument compute the position of the corresponding class - -- parameter in the class head. This will later serve as a permutation - -- vector when checking the validity of instance declarations. - setTyThingPoss (ATyCon tycon) atTyVars = - let classTyVars = map fst tv_bndrs - poss = catMaybes - . map ((`elemIndex` classTyVars) . fst) - $ atTyVars - -- There will be no Nothing, as we already passed renaming - in - ATyCon (setTyConArgPoss tycon poss) - setTyThingPoss _ _ = panic "TcIface.setTyThingPoss" - -tcIfaceDecl ignore_prags (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)) } -tcIfaceDataCons tycon_name tycon tc_tyvars if_cons +tcFamInst :: Maybe (IfaceTyCon, [IfaceType]) -> IfL (Maybe (TyCon, [Type])) +tcFamInst Nothing = return Nothing +tcFamInst (Just (fam, tys)) = do { famTyCon <- tcIfaceTyCon fam + ; insttys <- mapM tcIfaceType tys + ; return $ Just (famTyCon, insttys) } + +tcIfaceDataCons :: Name -> TyCon -> [TyVar] -> IfaceConDecls -> IfL AlgTyConRhs +tcIfaceDataCons tycon_name tycon _ if_cons = case if_cons of IfAbstractTyCon -> return mkAbstractTyConRhs - IfOpenDataTyCon -> return mkOpenDataTyConRhs - IfDataTyCon cons -> do { data_cons <- mappM tc_con_decl cons + 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 ; mkNewTyConRhs tycon_name tycon data_con } @@ -482,17 +537,22 @@ tcIfaceDataCons tycon_name tycon tc_tyvars if_cons -- Read the argument types, but lazily to avoid faulting in -- the component types unless they are really needed - ; arg_tys <- forkM (mk_doc name) (mappM tcIfaceType args) - ; lbl_names <- mappM lookupIfaceTop field_lbls + ; arg_tys <- forkM (mk_doc name) (mapM tcIfaceType args) + ; lbl_names <- mapM lookupIfaceTop field_lbls + + -- Remember, tycon is the representation tycon + ; let orig_res_ty = mkFamilyTyConApp tycon + (substTyVars (mkTopTvSubst eq_spec) univ_tyvars) ; buildDataCon name is_infix {- Not infix -} stricts lbl_names univ_tyvars ex_tyvars eq_spec theta - arg_tys tycon + arg_tys orig_res_ty tycon } - mk_doc con_name = ptext SLIT("Constructor") <+> ppr con_name + mk_doc con_name = ptext (sLit "Constructor") <+> ppr con_name +tcIfaceEqSpec :: [(OccName, IfaceType)] -> IfL [(TyVar, Type)] tcIfaceEqSpec spec = mapM do_item spec where @@ -501,6 +561,23 @@ tcIfaceEqSpec spec ; return (tv,ty) } \end{code} +Note [Synonym kind loop] +~~~~~~~~~~~~~~~~~~~~~~~~ +Notice that we eagerly grab the *kind* from the interface file, but +build a forkM thunk for the *rhs* (and family stuff). To see why, +consider this (Trac #2412) + +M.hs: module M where { import X; data T = MkT S } +X.hs: module X where { import {-# SOURCE #-} M; type S = T } +M.hs-boot: module M where { data T } + +When kind-checking M.hs we need S's kind. But we do not want to +find S's kind from (typeKind S-rhs), because we don't want to look at +S-rhs yet! Since S is imported from X.hi, S gets just one chance to +be defined, and we must not do that until we've finished with M.T. + +Solution: record S's kind in the interface file; now we can safely +look at it. %************************************************************************ %* * @@ -511,9 +588,8 @@ tcIfaceEqSpec spec \begin{code} tcIfaceInst :: IfaceInst -> IfL Instance tcIfaceInst (IfaceInst { ifDFun = dfun_occ, ifOFlag = oflag, - ifInstCls = cls, ifInstTys = mb_tcs, - ifInstOrph = orph }) - = do { dfun <- forkM (ptext SLIT("Dict fun") <+> ppr dfun_occ) $ + ifInstCls = cls, ifInstTys = mb_tcs }) + = do { dfun <- forkM (ptext (sLit "Dict fun") <+> ppr dfun_occ) $ tcIfaceExtId dfun_occ ; let mb_tcs' = map (fmap ifaceTyConName) mb_tcs ; return (mkImportedInstance cls mb_tcs' dfun oflag) } @@ -521,12 +597,12 @@ tcIfaceInst (IfaceInst { ifDFun = dfun_occ, ifOFlag = oflag, tcIfaceFamInst :: IfaceFamInst -> IfL FamInst tcIfaceFamInst (IfaceFamInst { ifFamInstTyCon = tycon, ifFamInstFam = fam, ifFamInstTys = mb_tcs }) --- = do { tycon' <- forkM (ptext SLIT("Inst tycon") <+> ppr tycon) $ --- ^^^this line doesn't work, but vvv this does => CPP in Haskell = evil! - = do { tycon' <- forkM (text ("Inst tycon") <+> ppr tycon) $ - tcIfaceTyCon tycon - ; let mb_tcs' = map (fmap ifaceTyConName) mb_tcs - ; return (mkImportedFamInst fam mb_tcs' tycon') } +-- { tycon' <- forkM (ptext (sLit "Inst tycon") <+> ppr tycon) $ +-- the above line doesn't work, but this below does => CPP in Haskell = evil! + = do tycon' <- forkM (text ("Inst tycon") <+> ppr tycon) $ + tcIfaceTyCon tycon + let mb_tcs' = map (fmap ifaceTyConName) mb_tcs + return (mkImportedFamInst fam mb_tcs' tycon') \end{code} @@ -551,20 +627,20 @@ tcIfaceRules ignore_prags if_rules tcIfaceRule :: IfaceRule -> IfL CoreRule tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs, ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs, - ifRuleOrph = orph }) + 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) $ + forkM (ptext (sLit "Rule") <+> ftext name) $ bindIfaceBndrs bndrs $ \ bndrs' -> - do { args' <- mappM tcIfaceExpr args + do { args' <- mapM tcIfaceExpr args ; rhs' <- tcIfaceExpr rhs ; return (bndrs', args', rhs') } ; let mb_tcs = map ifTopFreeName args - ; lcl <- getLclEnv - ; returnM (Rule { ru_name = name, ru_fn = fn, ru_act = act, + ; 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 @@ -578,9 +654,37 @@ tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bnd -- to write them out in coreRuleToIfaceRule ifTopFreeName :: IfaceExpr -> Maybe Name ifTopFreeName (IfaceType (IfaceTyConApp tc _ )) = Just (ifaceTyConName tc) - ifTopFreeName (IfaceApp f a) = ifTopFreeName f + ifTopFreeName (IfaceApp f _) = ifTopFreeName f ifTopFreeName (IfaceExt n) = Just n - ifTopFreeName other = Nothing + ifTopFreeName _ = Nothing +\end{code} + + +%************************************************************************ +%* * + Annotations +%* * +%************************************************************************ + +\begin{code} +tcIfaceAnnotations :: [IfaceAnnotation] -> IfL [Annotation] +tcIfaceAnnotations = mapM tcIfaceAnnotation + +tcIfaceAnnotation :: IfaceAnnotation -> IfL Annotation +tcIfaceAnnotation (IfaceAnnotation target serialized) = do + target' <- tcIfaceAnnTarget target + return $ Annotation { + ann_target = target', + ann_value = serialized + } + +tcIfaceAnnTarget :: IfaceAnnTarget -> IfL (AnnTarget Name) +tcIfaceAnnTarget (NamedTarget occ) = do + name <- lookupIfaceTop occ + return $ NamedTarget name +tcIfaceAnnTarget (ModuleTarget mod) = do + return $ ModuleTarget mod + \end{code} @@ -599,12 +703,13 @@ tcIfaceVectInfo mod typeEnv (IfaceVectInfo }) = do { vVars <- mapM vectVarMapping vars ; tyConRes1 <- mapM vectTyConMapping tycons - ; tyConRes2 <- mapM vectTyConReuseMapping tycons - ; let (vTyCons, vDataCons, vIsos) = unzip3 (tyConRes1 ++ tyConRes2) + ; 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 } } @@ -618,25 +723,31 @@ tcIfaceVectInfo mod typeEnv (IfaceVectInfo } vectTyConMapping name = do { vName <- lookupOrig mod (mkVectTyConOcc (nameOccName name)) + ; paName <- lookupOrig mod (mkPADFunOcc (nameOccName name)) ; isoName <- lookupOrig mod (mkVectIsoOcc (nameOccName name)) ; let { tycon = lookupTyCon name ; vTycon = lookupTyCon vName + ; paTycon = lookupVar paName ; isoTycon = lookupVar isoName } ; vDataCons <- mapM vectDataConMapping (tyConDataCons tycon) ; return ((name, (tycon, vTycon)), -- (T, T_v) vDataCons, -- list of (Ci, Ci_v) + (vName, (vTycon, paTycon)), -- (T_v, paT) (name, (tycon, isoTycon))) -- (T, isoT) } vectTyConReuseMapping name - = do { isoName <- lookupOrig mod (mkVectIsoOcc (nameOccName name)) + = do { paName <- lookupOrig mod (mkPADFunOcc (nameOccName name)) + ; isoName <- lookupOrig mod (mkVectIsoOcc (nameOccName name)) ; let { tycon = lookupTyCon name + ; paTycon = lookupVar paName ; isoTycon = lookupVar isoName ; vDataCons = [ (dataConName dc, (dc, dc)) | dc <- tyConDataCons tycon] } ; return ((name, (tycon, tycon)), -- (T, T) vDataCons, -- list of (Ci, Ci) + (name, (tycon, paTycon)), -- (T, paT) (name, (tycon, isoTycon))) -- (T, isoT) } vectDataConMapping datacon @@ -679,19 +790,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 = mappM 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} @@ -704,54 +852,51 @@ tcIfaceCtxt sts = mappM tcIfacePredType sts \begin{code} tcIfaceExpr :: IfaceExpr -> IfL CoreExpr tcIfaceExpr (IfaceType ty) - = tcIfaceType ty `thenM` \ ty' -> - returnM (Type ty') + = Type <$> tcIfaceType ty + +tcIfaceExpr (IfaceCo co) + = Coercion <$> tcIfaceCo co + +tcIfaceExpr (IfaceCast expr co) + = Cast <$> tcIfaceExpr expr <*> tcIfaceCo co tcIfaceExpr (IfaceLcl name) - = tcIfaceLclId name `thenM` \ id -> - returnM (Var id) + = Var <$> tcIfaceLclId name tcIfaceExpr (IfaceTick modName tickNo) - = tcIfaceTick modName tickNo `thenM` \ id -> - returnM (Var id) + = Var <$> tcIfaceTick modName tickNo tcIfaceExpr (IfaceExt gbl) - = tcIfaceExtId gbl `thenM` \ id -> - returnM (Var id) + = Var <$> tcIfaceExtId gbl tcIfaceExpr (IfaceLit lit) - = returnM (Lit lit) - -tcIfaceExpr (IfaceFCall cc ty) - = tcIfaceType ty `thenM` \ ty' -> - newUnique `thenM` \ u -> - returnM (Var (mkFCallId u cc ty')) - -tcIfaceExpr (IfaceTuple boxity args) - = mappM tcIfaceExpr args `thenM` \ args' -> - let - -- Put the missing type arguments back in - con_args = map (Type . exprType) args' ++ args' - in - returnM (mkApps (Var con_id) con_args) + = return (Lit lit) + +tcIfaceExpr (IfaceFCall cc ty) = do + ty' <- tcIfaceType ty + u <- newUnique + return (Var (mkFCallId u cc ty')) + +tcIfaceExpr (IfaceTuple boxity args) = do + args' <- mapM tcIfaceExpr args + -- Put the missing type arguments back in + let con_args = map (Type . exprType) args' ++ args' + return (mkApps (Var con_id) con_args) where arity = length args con_id = dataConWorkId (tupleCon boxity arity) tcIfaceExpr (IfaceLam bndr body) - = bindIfaceBndr bndr $ \ bndr' -> - tcIfaceExpr body `thenM` \ body' -> - returnM (Lam bndr' body') + = bindIfaceBndr bndr $ \bndr' -> + Lam bndr' <$> tcIfaceExpr body tcIfaceExpr (IfaceApp fun arg) - = tcIfaceExpr fun `thenM` \ fun' -> - tcIfaceExpr arg `thenM` \ arg' -> - returnM (App fun' arg') + = App <$> tcIfaceExpr fun <*> tcIfaceExpr arg -tcIfaceExpr (IfaceCase scrut case_bndr ty alts) - = tcIfaceExpr scrut `thenM` \ scrut' -> - newIfaceName (mkVarOccFS case_bndr) `thenM` \ case_bndr_name -> +tcIfaceExpr (IfaceCase scrut case_bndr alts) = do + scrut' <- tcIfaceExpr scrut + case_bndr_name <- newIfaceName (mkVarOccFS case_bndr) let scrut_ty = exprType scrut' case_bndr' = mkLocalId case_bndr_name scrut_ty @@ -761,75 +906,84 @@ tcIfaceExpr (IfaceCase scrut case_bndr ty alts) -- NB: not tcSplitTyConApp; we are looking at Core here -- look through non-rec newtypes to find the tycon that -- corresponds to the datacon in this case alternative - in - extendIfaceIdEnv [case_bndr'] $ - mappM (tcIfaceAlt tc_app) alts `thenM` \ alts' -> - tcIfaceType ty `thenM` \ ty' -> - returnM (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 + extendIfaceIdEnv [case_bndr'] $ do + alts' <- mapM (tcIfaceAlt scrut' tc_app) alts + return (Case scrut' case_bndr' (coreAltsType alts') alts') -tcIfaceExpr (IfaceCast expr co) = do - expr' <- tcIfaceExpr expr - co' <- tcIfaceType co - returnM (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 (IfaceNote note expr) - = tcIfaceExpr expr `thenM` \ expr' -> +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 -> returnM (Note InlineMe expr') - IfaceSCC cc -> returnM (Note (SCC cc) expr') - IfaceCoreNote n -> returnM (Note (CoreNote n) expr') + IfaceSCC cc -> return (Note (SCC cc) expr') + IfaceCoreNote n -> return (Note (CoreNote n) expr') ------------------------- -tcIfaceAlt _ (IfaceDefault, names, rhs) - = ASSERT( null names ) - tcIfaceExpr rhs `thenM` \ rhs' -> - returnM (DEFAULT, [], rhs') +tcIfaceAlt :: CoreExpr -> (TyCon, [Type]) + -> (IfaceConAlt, [FastString], IfaceExpr) + -> IfL (AltCon, [TyVar], CoreExpr) +tcIfaceAlt _ _ (IfaceDefault, names, rhs) + = ASSERT( null names ) do + rhs' <- tcIfaceExpr rhs + return (DEFAULT, [], rhs') -tcIfaceAlt _ (IfaceLitAlt lit, names, rhs) - = ASSERT( null names ) - tcIfaceExpr rhs `thenM` \ rhs' -> - returnM (LitAlt lit, [], rhs') +tcIfaceAlt _ _ (IfaceLitAlt lit, names, rhs) + = ASSERT( null names ) do + rhs' <- tcIfaceExpr rhs + return (LitAlt lit, [], rhs') -- A case alternative is made quite a bit more complicated -- by the fact that we omit type annotations because we can -- work them out. True enough, but its not that easy! -tcIfaceAlt (tycon, inst_tys) (IfaceDataAlt data_occ, arg_strs, rhs) +tcIfaceAlt scrut (tycon, inst_tys) (IfaceDataAlt data_occ, arg_strs, rhs) = do { con <- tcIfaceDataCon data_occ - ; ASSERT2( con `elem` tyConDataCons tycon, - ppr con $$ ppr tycon $$ ppr (tyConDataCons tycon) ) - tcIfaceDataAlt con inst_tys arg_strs rhs } + ; when (debugIsOn && not (con `elem` tyConDataCons tycon)) + (failIfM (ppr scrut $$ ppr con $$ ppr tycon $$ ppr (tyConDataCons tycon))) + ; tcIfaceDataAlt con inst_tys arg_strs rhs } -tcIfaceAlt (tycon, inst_tys) (IfaceTupleAlt boxity, arg_occs, rhs) - = ASSERT( isTupleTyCon tycon ) +tcIfaceAlt _ (tycon, inst_tys) (IfaceTupleAlt _boxity, arg_occs, rhs) + = ASSERT2( isTupleTyCon tycon, ppr tycon ) do { let [data_con] = tyConDataCons tycon ; tcIfaceDataAlt data_con inst_tys arg_occs rhs } +tcIfaceDataAlt :: DataCon -> [Type] -> [FastString] -> IfaceExpr + -> IfL (AltCon, [TyVar], CoreExpr) 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} @@ -847,9 +1001,9 @@ do_one (IfaceNonRec bndr rhs) thing_inside ; return (NonRec bndr' rhs' : core_binds) }} do_one (IfaceRec pairs) thing_inside - = do { bndrs' <- mappM newExtCoreBndr bndrs + = do { bndrs' <- mapM newExtCoreBndr bndrs ; extendIfaceIdEnv bndrs' $ do - { rhss' <- mappM tcIfaceExpr rhss + { rhss' <- mapM tcIfaceExpr rhss ; core_binds <- thing_inside ; return (Rec (bndrs' `zip` rhss') : core_binds) }} where @@ -864,6 +1018,17 @@ do_one (IfaceRec pairs) thing_inside %************************************************************************ \begin{code} +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 }) } + tcIdInfo :: Bool -> Name -> Type -> IfaceIdInfo -> IfL IdInfo tcIdInfo ignore_prags name ty info | ignore_prags = return vanillaIdInfo @@ -875,52 +1040,87 @@ tcIdInfo ignore_prags name ty info -- we start; default assumption is that it has CAFs init_info = vanillaIdInfo - tcPrag info HsNoCafRefs = returnM (info `setCafInfo` NoCafRefs) - tcPrag info (HsArity arity) = returnM (info `setArityInfo` arity) - tcPrag info (HsStrictness str) = returnM (info `setAllStrictnessInfo` Just str) + 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 `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) = returnM (info `setInlinePragInfo` inline_prag) - tcPrag info (HsUnfold expr) - = tcPragExpr name expr `thenM` \ maybe_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' - in - returnM (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 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)) + } - ; returnM (case mb_wkr_id of - Nothing -> info - Just wkr_id -> add_wkr_info us wkr_id info) } +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 -> 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 @@ -929,28 +1129,35 @@ an unfolding that isn't going to be looked at. \begin{code} tcPragExpr :: Name -> IfaceExpr -> IfL (Maybe CoreExpr) tcPragExpr name expr - = forkM_maybe doc $ - tcIfaceExpr expr `thenM` \ core_expr' -> - - -- Check for type consistency in the unfolding - ifOptM Opt_DoCoreLinting ( - get_in_scope_ids `thenM` \ in_scope -> - case lintUnfolding noSrcLoc in_scope core_expr' of - Nothing -> returnM () - Just fail_msg -> pprPanic "Iface Lint failure" (hang doc 2 fail_msg) - ) `thenM_` - - returnM core_expr' + = forkM_maybe doc $ do + core_expr' <- tcIfaceExpr expr + + -- Check for type consistency in the unfolding + ifDOptM Opt_DoCoreLinting $ do + in_scope <- get_in_scope + case lintUnfolding noSrcLoc in_scope core_expr' of + Nothing -> return () + 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} @@ -966,26 +1173,26 @@ tcIfaceGlobal :: Name -> IfL TyThing tcIfaceGlobal name | Just thing <- wiredInNameTyThing_maybe name -- Wired-in things include TyCons, DataCons, and Ids - = do { ifCheckWiredInThing name; return thing } + = do { ifCheckWiredInThing thing; return thing } | otherwise - = do { (eps,hpt) <- getEpsAndHpt - ; dflags <- getDOpts - ; case lookupType dflags hpt (eps_PTE eps) name of { - Just thing -> return thing ; - Nothing -> do - - { env <- getGblEnv - ; case if_rec_types env of { + = do { env <- getGblEnv + ; case if_rec_types env of { -- Note [Tying the knot] Just (mod, get_type_env) | nameIsLocalOrFrom mod name -> do -- It's defined in the module being compiled { type_env <- setLclEnv () get_type_env -- yuk ; case lookupNameEnv type_env name of Just thing -> return thing - Nothing -> pprPanic "tcIfaceGlobal (local): not found:" + Nothing -> pprPanic "tcIfaceGlobal (local): not found:" (ppr name $$ ppr type_env) } - ; other -> do + ; _ -> do + + { hsc_env <- getTopEnv + ; mb_thing <- liftIO (lookupTypeHscEnv hsc_env name) + ; case mb_thing of { + Just thing -> return thing ; + Nothing -> do { mb_thing <- importDecl name -- It's imported; go get it ; case mb_thing of @@ -993,20 +1200,21 @@ tcIfaceGlobal name Succeeded thing -> return thing }}}}} -ifCheckWiredInThing :: Name -> IfL () --- Even though we are in an interface file, we want to make --- sure the instances of a wired-in thing are loaded (imagine f :: Double -> Double) --- Ditto want to ensure that RULES are loaded too --- See Note [Loading instances] in LoadIface -ifCheckWiredInThing name - = do { mod <- getIfModule - -- Check whether we are typechecking the interface for this - -- very module. E.g when compiling the base library in --make mode - -- we may typecheck GHC.Base.hi. At that point, GHC.Base is not in - -- the HPT, so without the test we'll demand-load it into the PIT! - -- C.f. the same test in checkWiredInTyCon above - ; unless (mod == nameModule name) - (loadWiredInHomeIface name) } +-- Note [Tying the knot] +-- ~~~~~~~~~~~~~~~~~~~~~ +-- The if_rec_types field is used in two situations: +-- +-- a) Compiling M.hs, which indiretly imports Foo.hi, which mentions M.T +-- Then we look up M.T in M's type environment, which is splatted into if_rec_types +-- after we've built M's type envt. +-- +-- b) In ghc --make, during the upsweep, we encounter M.hs, whose interface M.hi +-- is up to date. So we call typecheckIface on M.hi. This splats M.T into +-- if_rec_types so that the (lazily typechecked) decls see all the other decls +-- +-- In case (b) it's important to do the if_rec_types check *before* looking in the HPT +-- Because if M.hs also has M.hs-boot, M.T will *already be* in the HPT, but in its +-- emasculated form (e.g. lacking data constructors). tcIfaceTyCon :: IfaceTyCon -> IfL TyCon tcIfaceTyCon IfaceIntTc = tcWiredInTyCon intTyCon @@ -1015,16 +1223,16 @@ 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 -#ifdef DEBUG - check_tc tc = case toIfaceTyCon tc of - IfaceTc _ -> tc - other -> pprTrace "check_tc" (ppr tc) tc -#else - check_tc tc = tc -#endif + check_tc tc + | debugIsOn = case toIfaceTyCon tc of + IfaceTc _ -> tc + _ -> pprTrace "check_tc" (ppr tc) tc + | otherwise = tc -- we should be okay just returning Kind constructors without extra loading tcIfaceTyCon IfaceLiftedTypeKindTc = return liftedTypeKindTyCon tcIfaceTyCon IfaceOpenTypeKindTc = return openTypeKindTyCon @@ -1036,24 +1244,28 @@ tcIfaceTyCon IfaceUbxTupleKindTc = return ubxTupleKindTyCon -- sure the instances and RULES of this tycon are loaded -- Imagine: f :: Double -> Double tcWiredInTyCon :: TyCon -> IfL TyCon -tcWiredInTyCon tc = do { ifCheckWiredInThing (tyConName tc) +tcWiredInTyCon tc = do { ifCheckWiredInThing (ATyCon tc) ; return tc } 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 ADataCon dc -> return dc - other -> pprPanic "tcIfaceExtDC" (ppr name$$ ppr thing) } + _ -> pprPanic "tcIfaceExtDC" (ppr name$$ ppr thing) } tcIfaceExtId :: Name -> IfL Id tcIfaceExtId name = do { thing <- tcIfaceGlobal name ; case thing of AnId id -> return id - other -> pprPanic "tcIfaceExtId" (ppr name$$ ppr thing) } + _ -> pprPanic "tcIfaceExtId" (ppr name$$ ppr thing) } \end{code} %************************************************************************ @@ -1080,24 +1292,8 @@ bindIfaceBndrs (b:bs) thing_inside thing_inside (b':bs') ----------------------- -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 +newExtCoreBndr (IfLetBndr var ty _) -- Ignoring IdInfo for now = do { mod <- getIfModule ; name <- newGlobalBinder mod (mkVarOccFS var) noSrcSpan ; ty' <- tcIfaceType ty @@ -1106,14 +1302,14 @@ newExtCoreBndr (IfLetBndr var ty _) -- Ignoring IdInfo for now ----------------------- bindIfaceTyVar :: IfaceTvBndr -> (TyVar -> IfL a) -> IfL a bindIfaceTyVar (occ,kind) thing_inside - = do { name <- newIfaceName (mkTyVarOcc occ) + = do { name <- newIfaceName (mkTyVarOccFS occ) ; tyvar <- mk_iface_tyvar name kind ; extendIfaceTyVarEnv [tyvar] (thing_inside tyvar) } bindIfaceTyVars :: [IfaceTvBndr] -> ([TyVar] -> IfL a) -> IfL a bindIfaceTyVars bndrs thing_inside - = do { names <- newIfaceNames (map mkTyVarOcc occs) - ; tyvars <- TcRnMonad.zipWithM mk_iface_tyvar names kinds + = do { names <- newIfaceNames (map mkTyVarOccFS occs) + ; tyvars <- zipWithM mk_iface_tyvar names kinds ; extendIfaceTyVarEnv tyvars (thing_inside tyvars) } where (occs,kinds) = unzip bndrs @@ -1125,5 +1321,20 @@ mk_iface_tyvar name ifKind return (Var.mkCoVar name kind) else return (Var.mkTyVar name kind) } -\end{code} + +bindIfaceTyVars_AT :: [IfaceTvBndr] -> ([TyVar] -> IfL a) -> IfL a +-- Used for type variable in nested associated data/type declarations +-- where some of the type variables are already in scope +-- class C a where { data T a b } +-- Here 'a' is in scope when we look at the 'data T' +bindIfaceTyVars_AT [] thing_inside + = thing_inside [] +bindIfaceTyVars_AT (b@(tv_occ,_) : bs) thing_inside + = bindIfaceTyVars_AT bs $ \ bs' -> + do { mb_tv <- lookupIfaceTyVar tv_occ + ; case mb_tv of + Just b' -> thing_inside (b':bs') + Nothing -> bindIfaceTyVar b $ \ b' -> + thing_inside (b':bs') } +\end{code}