X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=compiler%2Fiface%2FTcIface.lhs;h=bae0405988cfaa12cd4ea36fc50735f8107e71d6;hb=686d87447e2186e2aa55e1a925f0a3a8e94872f5;hp=ac458d57b4e90a8cb6769dabb5865a3f5eff3300;hpb=84f4c1dfb0c39c5b48a8b960fc82ab10aeb10c84;p=ghc-hetmet.git diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index ac458d5..bae0405 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -1,74 +1,59 @@ % +% (c) The University of Glasgow 2006 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -\section[TcIfaceSig]{Type checking of type signatures in interface files} + +Type checking of type signatures in interface files \begin{code} module TcIface ( tcImportDecl, checkWiredInTyCon, tcHiBootIface, typecheckIface, - tcIfaceDecl, tcIfaceInst, tcIfaceRules, tcIfaceGlobal, - tcExtCoreBindings + tcIfaceDecl, tcIfaceInst, tcIfaceFamInst, tcIfaceRules, + tcIfaceVectInfo, tcIfaceGlobal, tcExtCoreBindings ) where #include "HsVersions.h" import IfaceSyn -import LoadIface ( loadInterface, loadWiredInHomeIface, findAndReadIface, loadDecls ) -import IfaceEnv ( lookupIfaceTop, lookupIfaceExt, newGlobalBinder, - extendIfaceIdEnv, extendIfaceTyVarEnv, newIPName, - tcIfaceTyVar, tcIfaceLclId, lookupIfaceTc, - newIfaceName, newIfaceNames, ifaceExportNames ) -import BuildTyCl ( buildSynTyCon, buildAlgTyCon, buildDataCon, - buildClass, - mkAbstractTyConRhs, mkOpenDataTyConRhs, - mkOpenNewTyConRhs, mkDataTyConRhs, mkNewTyConRhs ) +import LoadIface +import IfaceEnv +import BuildTyCl import TcRnMonad -import Type ( liftedTypeKind, splitTyConApp, mkTyConApp, - liftedTypeKindTyCon, unliftedTypeKindTyCon, - openTypeKindTyCon, argTypeKindTyCon, - ubxTupleKindTyCon, ThetaType ) -import TypeRep ( Type(..), PredType(..) ) -import TyCon ( TyCon, tyConName, SynTyConRhs(..), setTyConArgPoss ) -import HscTypes ( ExternalPackageState(..), - TyThing(..), tyThingClass, tyThingTyCon, - ModIface(..), ModDetails(..), HomeModInfo(..), - emptyModDetails, lookupTypeEnv, lookupType, - typeEnvIds, mkDetailsFamInstCache ) -import InstEnv ( Instance(..), mkImportedInstance ) +import Type +import TypeRep +import HscTypes +import InstEnv +import FamInstEnv import CoreSyn -import CoreUtils ( exprType, dataConRepFSInstPat ) +import CoreUtils import CoreUnfold -import CoreLint ( lintUnfolding ) -import WorkWrap ( mkWrapper ) -import Id ( Id, mkVanillaGlobal, mkLocalId ) -import MkId ( mkFCallId ) -import IdInfo ( IdInfo, CafInfo(..), WorkerInfo(..), - setUnfoldingInfoLazily, setAllStrictnessInfo, setWorkerInfo, - setArityInfo, setInlinePragInfo, setCafInfo, - vanillaIdInfo, newStrictnessInfo ) -import Class ( Class ) -import TyCon ( tyConDataCons, isTupleTyCon, mkForeignTyCon ) -import DataCon ( DataCon, dataConWorkId ) -import TysWiredIn ( tupleCon, tupleTyCon, listTyCon, intTyCon, boolTyCon, charTyCon, parrTyCon ) -import Var ( TyVar, mkTyVar ) -import Name ( Name, nameModule, nameIsLocalOrFrom, isWiredInName, - nameOccName, wiredInNameTyThing_maybe ) +import CoreLint +import WorkWrap +import Id +import MkId +import IdInfo +import Class +import TyCon +import DataCon +import TysWiredIn +import Var ( TyVar ) +import qualified Var +import VarEnv +import Name import NameEnv -import OccName ( OccName, mkVarOccFS, mkTyVarOcc, occNameSpace, - pprNameSpace, occNameFS ) -import Module ( Module, moduleName ) -import UniqFM ( lookupUFM ) -import UniqSupply ( initUs_, uniqsFromSupply ) +import OccName +import Module +import UniqFM +import UniqSupply import Outputable -import ErrUtils ( Message ) -import Maybes ( MaybeErr(..) ) -import SrcLoc ( noSrcLoc ) -import Util ( zipWithEqual ) -import DynFlags ( DynFlag(..), isOneShot ) -import Control.Monad ( unless ) - -import List ( elemIndex) -import Maybe ( catMaybes ) +import ErrUtils +import Maybes +import SrcLoc +import DynFlags +import Control.Monad + +import Data.List +import Data.Maybe \end{code} This module takes @@ -210,8 +195,13 @@ typecheckIface iface ; writeMutVar tc_env_var type_env -- Now do those rules and instances - ; dfuns <- mapM tcIfaceInst (mi_insts iface) - ; rules <- tcIfaceRules ignore_prags (mi_rules iface) + ; insts <- mapM tcIfaceInst (mi_insts iface) + ; fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface) + ; rules <- tcIfaceRules ignore_prags (mi_rules iface) + + -- Vectorisation information + ; vect_info <- tcIfaceVectInfo (mi_module iface) type_env + (mi_vect_info iface) -- Exports ; exports <- ifaceExportNames (mi_exports iface) @@ -220,10 +210,12 @@ typecheckIface iface ; traceIf (vcat [text "Finished typechecking interface for" <+> ppr (mi_module iface), text "Type envt:" <+> ppr type_env]) ; return $ ModDetails { md_types = type_env - , md_insts = dfuns - , md_fam_insts = mkDetailsFamInstCache type_env + , md_insts = insts + , md_fam_insts = fam_insts , md_rules = rules - , md_exports = exports + , md_vect_info = vect_info + , md_exports = exports + , md_modBreaks = emptyModBreaks } } \end{code} @@ -236,11 +228,14 @@ typecheckIface iface %************************************************************************ \begin{code} -tcHiBootIface :: Module -> TcRn ModDetails +tcHiBootIface :: HscSource -> Module -> TcRn ModDetails -- Load the hi-boot iface for the module being compiled, -- if it indeed exists in the transitive closure of imports -- Return the ModDetails, empty if no hi-boot iface -tcHiBootIface mod +tcHiBootIface hsc_src mod + | isHsBoot hsc_src -- Already compiling a hs-boot file + = return emptyModDetails + | otherwise = do { traceIf (text "loadHiBootInterface" <+> ppr mod) ; mode <- getGhcMode @@ -373,9 +368,7 @@ tcIfaceDecl ignore_prags ; famInst <- case mb_family of Nothing -> return Nothing - Just (IfaceFamInst { ifFamInstTyCon = fam - , ifFamInstTys = tys - }) -> + Just (fam, tys) -> do { famTyCon <- tcIfaceTyCon fam ; insttys <- mapM tcIfaceType tys ; return $ Just (famTyCon, insttys) @@ -390,13 +383,22 @@ tcIfaceDecl ignore_prags tcIfaceDecl ignore_prags (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs, - ifOpenSyn = isOpen, ifSynRhs = rdr_rhs_ty}) + 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 + ; let rhs = if isOpen then OpenSynTyCon rhs_tyki Nothing else SynonymTyCon rhs_tyki - ; return (ATyCon (buildSynTyCon tc_name tyvars rhs)) + ; 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 } tcIfaceDecl ignore_prags @@ -420,8 +422,8 @@ tcIfaceDecl ignore_prags = do { op_name <- lookupIfaceTop occ ; op_ty <- forkM (mk_doc op_name rdr_ty) (tcIfaceType rdr_ty) -- Must be done lazily for just the same reason as the - -- context of a data decl: the type sig might mention the - -- class being defined + -- type of a data con; to avoid sucking in types that + -- 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] @@ -452,7 +454,6 @@ tcIfaceDataCons tycon_name tycon tc_tyvars if_cons = case if_cons of IfAbstractTyCon -> return mkAbstractTyConRhs IfOpenDataTyCon -> return mkOpenDataTyConRhs - IfOpenNewTyCon -> return mkOpenNewTyConRhs IfDataTyCon cons -> do { data_cons <- mappM tc_con_decl cons ; return (mkDataTyConRhs data_cons) } IfNewTyCon con -> do { data_con <- tc_con_decl con @@ -463,8 +464,8 @@ tcIfaceDataCons tycon_name tycon tc_tyvars if_cons ifConOcc = occ, ifConCtxt = ctxt, ifConEqSpec = spec, ifConArgTys = args, ifConFields = field_lbls, ifConStricts = stricts}) - = bindIfaceTyVars univ_tvs $ \ univ_tyvars -> do - bindIfaceTyVars ex_tvs $ \ ex_tyvars -> do + = bindIfaceTyVars univ_tvs $ \ univ_tyvars -> do + bindIfaceTyVars ex_tvs $ \ ex_tyvars -> do { name <- lookupIfaceTop occ ; eq_spec <- tcIfaceEqSpec spec ; theta <- tcIfaceCtxt ctxt -- Laziness seems not worth the bother here @@ -496,7 +497,7 @@ tcIfaceEqSpec spec do_item (occ, if_ty) = do { tv <- tcIfaceTyVar (occNameFS occ) ; ty <- tcIfaceType if_ty ; return (tv,ty) } -\end{code} +\end{code} %************************************************************************ @@ -511,13 +512,19 @@ tcIfaceInst (IfaceInst { ifDFun = dfun_occ, ifOFlag = oflag, ifInstCls = cls, ifInstTys = mb_tcs, ifInstOrph = orph }) = do { dfun <- forkM (ptext SLIT("Dict fun") <+> ppr dfun_occ) $ - tcIfaceExtId (LocalTop dfun_occ) - ; cls' <- lookupIfaceExt cls - ; mb_tcs' <- mapM do_tc mb_tcs - ; return (mkImportedInstance cls' mb_tcs' orph dfun oflag) } - where - do_tc Nothing = return Nothing - do_tc (Just tc) = do { tc' <- lookupIfaceTc tc; return (Just tc') } + tcIfaceExtId dfun_occ + ; let mb_tcs' = map (fmap ifaceTyConName) mb_tcs + ; return (mkImportedInstance cls mb_tcs' dfun 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') } \end{code} @@ -543,20 +550,22 @@ tcIfaceRule :: IfaceRule -> IfL CoreRule tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs, ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs, ifRuleOrph = orph }) - = do { fn' <- lookupIfaceExt fn - ; ~(bndrs', args', rhs') <- + = do { ~(bndrs', args', rhs') <- -- Typecheck the payload lazily, in the hope it'll never be looked at forkM (ptext SLIT("Rule") <+> ftext name) $ bindIfaceBndrs bndrs $ \ bndrs' -> do { args' <- mappM tcIfaceExpr args ; rhs' <- tcIfaceExpr rhs ; return (bndrs', args', rhs') } - ; mb_tcs <- mapM ifTopFreeName args - ; returnM (Rule { ru_name = name, ru_fn = fn', ru_act = act, + ; let mb_tcs = map ifTopFreeName args + ; lcl <- getLclEnv + ; returnM (Rule { ru_name = name, ru_fn = fn, ru_act = act, ru_bndrs = bndrs', ru_args = args', - ru_rhs = rhs', ru_orph = orph, + ru_rhs = rhs', ru_rough = mb_tcs, - ru_local = isLocalIfaceExtName fn }) } + 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 where -- This function *must* mirror exactly what Rules.topFreeName does -- We could have stored the ru_rough field in the iface file @@ -565,19 +574,98 @@ tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bnd -- type syononyms at the top of a type arg. Since -- we can't tell at this point, we are careful not -- to write them out in coreRuleToIfaceRule - ifTopFreeName :: IfaceExpr -> IfL (Maybe Name) - ifTopFreeName (IfaceType (IfaceTyConApp tc _ )) - = do { n <- lookupIfaceTc tc - ; return (Just n) } - ifTopFreeName (IfaceApp f a) = ifTopFreeName f - ifTopFreeName (IfaceExt ext) = do { n <- lookupIfaceExt ext - ; return (Just n) } - ifTopFreeName other = return Nothing + ifTopFreeName :: IfaceExpr -> Maybe Name + ifTopFreeName (IfaceType (IfaceTyConApp tc _ )) = Just (ifaceTyConName tc) + ifTopFreeName (IfaceApp f a) = ifTopFreeName f + ifTopFreeName (IfaceExt n) = Just n + ifTopFreeName other = Nothing \end{code} %************************************************************************ %* * + Vectorisation information +%* * +%************************************************************************ + +\begin{code} +tcIfaceVectInfo :: Module -> TypeEnv -> IfaceVectInfo -> IfL VectInfo +tcIfaceVectInfo mod typeEnv (IfaceVectInfo + { ifaceVectInfoCCVar = vars + , ifaceVectInfoCCTyCon = tycons + , ifaceVectInfoCCTyConReuse = tyconsReuse + }) + = do { ccVars <- mapM ccVarMapping vars + ; tyConRes1 <- mapM ccTyConMapping tycons + ; tyConRes2 <- mapM ccTyConReuseMapping tycons + ; let (ccTyCons, ccDataCons, ccIsos) = unzip3 (tyConRes1 ++ tyConRes2) + ; return $ VectInfo + { vectInfoCCVar = mkVarEnv ccVars + , vectInfoCCTyCon = mkNameEnv ccTyCons + , vectInfoCCDataCon = mkNameEnv (concat ccDataCons) + , vectInfoCCIso = mkNameEnv ccIsos + } + } + where + ccVarMapping name + = do { ccName <- lookupOrig mod (mkCloOcc (nameOccName name)) + ; let { var = lookupVar name + ; ccVar = lookupVar ccName + } + ; return (var, (var, ccVar)) + } + ccTyConMapping name + = do { ccName <- lookupOrig mod (mkCloTyConOcc (nameOccName name)) + ; isoName <- lookupOrig mod (mkCloIsoOcc (nameOccName name)) + ; let { tycon = lookupTyCon name + ; ccTycon = lookupTyCon ccName + ; isoTycon = lookupVar isoName + } + ; ccDataCons <- mapM ccDataConMapping (tyConDataCons tycon) + ; return ((name, (tycon, ccTycon)), -- (T, T_CC) + ccDataCons, -- list of (Ci, Ci_CC) + (name, (tycon, isoTycon))) -- (T, isoT) + } + ccTyConReuseMapping name + = do { isoName <- lookupOrig mod (mkCloIsoOcc (nameOccName name)) + ; let { tycon = lookupTyCon name + ; isoTycon = lookupVar isoName + ; ccDataCons = [ (dataConName dc, (dc, dc)) + | dc <- tyConDataCons tycon] + } + ; return ((name, (tycon, tycon)), -- (T, T) + ccDataCons, -- list of (Ci, Ci) + (name, (tycon, isoTycon))) -- (T, isoT) + } + ccDataConMapping datacon + = do { let name = dataConName datacon + ; ccName <- lookupOrig mod (mkCloDataConOcc (nameOccName name)) + ; let ccDataCon = lookupDataCon ccName + ; return (name, (datacon, ccDataCon)) + } + -- + lookupVar name = case lookupTypeEnv typeEnv name of + Just (AnId var) -> var + Just _ -> + panic "TcIface.tcIfaceVectInfo: not an id" + Nothing -> + panic "TcIface.tcIfaceVectInfo: unknown name" + lookupTyCon name = case lookupTypeEnv typeEnv name of + Just (ATyCon tc) -> tc + Just _ -> + panic "TcIface.tcIfaceVectInfo: not a tycon" + Nothing -> + panic "TcIface.tcIfaceVectInfo: unknown name" + lookupDataCon name = case lookupTypeEnv typeEnv name of + Just (ADataCon dc) -> dc + Just _ -> + panic "TcIface.tcIfaceVectInfo: not a datacon" + Nothing -> + panic "TcIface.tcIfaceVectInfo: unknown name" +\end{code} + +%************************************************************************ +%* * Types %* * %************************************************************************ @@ -674,16 +762,17 @@ tcIfaceExpr (IfaceCase scrut case_bndr ty alts) returnM (Case scrut' case_bndr' ty' alts') tcIfaceExpr (IfaceLet (IfaceNonRec bndr rhs) body) - = tcIfaceExpr rhs `thenM` \ rhs' -> - bindIfaceId bndr $ \ bndr' -> - tcIfaceExpr body `thenM` \ body' -> - returnM (Let (NonRec 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) - = bindIfaceIds bndrs $ \ bndrs' -> - mappM tcIfaceExpr rhss `thenM` \ rhss' -> - tcIfaceExpr body `thenM` \ body' -> - returnM (Let (Rec (bndrs' `zip` rhss')) 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 @@ -714,8 +803,7 @@ tcIfaceAlt _ (IfaceLitAlt lit, names, rhs) -- 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) - = do { let tycon_mod = nameModule (tyConName tycon) - ; con <- tcIfaceDataCon (ExtPkg tycon_mod data_occ) + = do { con <- tcIfaceDataCon data_occ ; ASSERT2( con `elem` tyConDataCons tycon, ppr con $$ ppr tycon $$ ppr (tyConDataCons tycon) ) tcIfaceDataAlt con inst_tys arg_strs rhs } @@ -920,12 +1008,11 @@ tcIfaceTyCon IfaceCharTc = tcWiredInTyCon charTyCon tcIfaceTyCon IfaceListTc = tcWiredInTyCon listTyCon tcIfaceTyCon IfacePArrTc = tcWiredInTyCon parrTyCon tcIfaceTyCon (IfaceTupTc bx ar) = tcWiredInTyCon (tupleTyCon bx ar) -tcIfaceTyCon (IfaceTc ext_nm) = do { name <- lookupIfaceExt ext_nm - ; thing <- tcIfaceGlobal name +tcIfaceTyCon (IfaceTc name) = do { thing <- tcIfaceGlobal name ; return (check_tc (tyThingTyCon thing)) } where #ifdef DEBUG - check_tc tc = case toIfaceTyCon (error "urk") tc of + check_tc tc = case toIfaceTyCon tc of IfaceTc _ -> tc other -> pprTrace "check_tc" (ppr tc) tc #else @@ -945,24 +1032,21 @@ tcWiredInTyCon :: TyCon -> IfL TyCon tcWiredInTyCon tc = do { ifCheckWiredInThing (tyConName tc) ; return tc } -tcIfaceClass :: IfaceExtName -> IfL Class -tcIfaceClass rdr_name = do { name <- lookupIfaceExt rdr_name - ; thing <- tcIfaceGlobal name - ; return (tyThingClass thing) } +tcIfaceClass :: Name -> IfL Class +tcIfaceClass name = do { thing <- tcIfaceGlobal name + ; return (tyThingClass thing) } -tcIfaceDataCon :: IfaceExtName -> IfL DataCon -tcIfaceDataCon gbl = do { name <- lookupIfaceExt gbl - ; thing <- tcIfaceGlobal name - ; case thing of +tcIfaceDataCon :: Name -> IfL DataCon +tcIfaceDataCon name = do { thing <- tcIfaceGlobal name + ; case thing of ADataCon dc -> return dc - other -> pprPanic "tcIfaceExtDC" (ppr gbl $$ ppr name$$ ppr thing) } + other -> pprPanic "tcIfaceExtDC" (ppr name$$ ppr thing) } -tcIfaceExtId :: IfaceExtName -> IfL Id -tcIfaceExtId gbl = do { name <- lookupIfaceExt gbl - ; thing <- tcIfaceGlobal name - ; case thing of +tcIfaceExtId :: Name -> IfL Id +tcIfaceExtId name = do { thing <- tcIfaceGlobal name + ; case thing of AnId id -> return id - other -> pprPanic "tcIfaceExtId" (ppr gbl $$ ppr name$$ ppr thing) } + other -> pprPanic "tcIfaceExtId" (ppr name$$ ppr thing) } \end{code} %************************************************************************ @@ -973,8 +1057,11 @@ tcIfaceExtId gbl = do { name <- lookupIfaceExt gbl \begin{code} bindIfaceBndr :: IfaceBndr -> (CoreBndr -> IfL a) -> IfL a -bindIfaceBndr (IfaceIdBndr bndr) thing_inside - = bindIfaceId bndr thing_inside +bindIfaceBndr (IfaceIdBndr (fs, ty)) thing_inside + = do { name <- newIfaceName (mkVarOccFS fs) + ; ty' <- tcIfaceType ty + ; let id = mkLocalId name ty' + ; extendIfaceIdEnv [id] (thing_inside id) } bindIfaceBndr (IfaceTvBndr bndr) thing_inside = bindIfaceTyVar bndr thing_inside @@ -986,28 +1073,26 @@ bindIfaceBndrs (b:bs) thing_inside thing_inside (b':bs') ----------------------- -bindIfaceId :: IfaceIdBndr -> (Id -> IfL a) -> IfL a -bindIfaceId (occ, ty) thing_inside - = do { name <- newIfaceName (mkVarOccFS occ) +tcIfaceLetBndr (IfLetBndr fs ty info) + = do { name <- newIfaceName (mkVarOccFS fs) ; ty' <- tcIfaceType ty - ; let { id = mkLocalId name ty' } - ; extendIfaceIdEnv [id] (thing_inside id) } - -bindIfaceIds :: [IfaceIdBndr] -> ([Id] -> IfL a) -> IfL a -bindIfaceIds bndrs thing_inside - = do { names <- newIfaceNames (map mkVarOccFS occs) - ; tys' <- mappM tcIfaceType tys - ; let { ids = zipWithEqual "tcCoreValBndr" mkLocalId names tys' } - ; extendIfaceIdEnv ids (thing_inside ids) } + ; case info of + NoInfo -> return (mkLocalId name ty') + HasInfo i -> return (mkLocalIdWithInfo name ty' (tc_info i)) } where - (occs,tys) = unzip bndrs - + -- 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 :: IfaceIdBndr -> IfL Id -newExtCoreBndr (var, ty) +newExtCoreBndr :: IfaceLetBndr -> IfL Id +newExtCoreBndr (IfLetBndr var ty _) -- Ignoring IdInfo for now = do { mod <- getIfModule - ; name <- newGlobalBinder mod (mkVarOccFS var) Nothing noSrcLoc + ; name <- newGlobalBinder mod (mkVarOccFS var) noSrcSpan ; ty' <- tcIfaceType ty ; return (mkLocalId name ty') } @@ -1021,14 +1106,17 @@ bindIfaceTyVar (occ,kind) thing_inside bindIfaceTyVars :: [IfaceTvBndr] -> ([TyVar] -> IfL a) -> IfL a bindIfaceTyVars bndrs thing_inside = do { names <- newIfaceNames (map mkTyVarOcc occs) - ; tyvars <- zipWithM mk_iface_tyvar names kinds + ; tyvars <- TcRnMonad.zipWithM mk_iface_tyvar names kinds ; extendIfaceTyVarEnv tyvars (thing_inside tyvars) } where (occs,kinds) = unzip bndrs mk_iface_tyvar :: Name -> IfaceKind -> IfL TyVar -mk_iface_tyvar name ifKind = do { kind <- tcIfaceType ifKind - ; return (mkTyVar name kind) - } +mk_iface_tyvar name ifKind + = do { kind <- tcIfaceType ifKind + ; if isCoercionKind kind then + return (Var.mkCoVar name kind) + else + return (Var.mkTyVar name kind) } \end{code}