X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fiface%2FTcIface.lhs;h=21d2fb3121132a8537863c75d4573c2c487345e0;hb=ac704fcac946590eef0ec91ae19f3b47d779a75f;hp=fa227e675662a80dcb0c9f8681db2e6360962ac3;hpb=2a8cdc3aee5997374273e27365f92c161aca8453;p=ghc-hetmet.git diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index fa227e6..21d2fb3 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -1,7 +1,9 @@ % +% (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 ( @@ -13,63 +15,45 @@ module TcIface ( #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 ) -import InstEnv ( Instance(..), mkImportedInstance ) -import FamInstEnv ( FamInst(..), mkImportedFamInst ) +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 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 Util +import DynFlags +import Control.Monad + +import Data.List +import Data.Maybe \end{code} This module takes @@ -511,10 +495,9 @@ 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 tc_rough mb_tcs - ; return (mkImportedInstance cls' mb_tcs' orph dfun oflag) } + tcIfaceExtId dfun_occ + ; let mb_tcs' = map (fmap ifaceTyConName) mb_tcs + ; return (mkImportedInstance cls mb_tcs' orph dfun oflag) } tcIfaceFamInst :: IfaceFamInst -> IfL FamInst tcIfaceFamInst (IfaceFamInst { ifFamInstTyCon = tycon, @@ -523,12 +506,8 @@ tcIfaceFamInst (IfaceFamInst { ifFamInstTyCon = tycon, -- ^^^this line doesn't work, but vvv this does => CPP in Haskell = evil! = do { tycon' <- forkM (text ("Inst tycon") <+> ppr tycon) $ tcIfaceTyCon tycon - ; fam' <- lookupIfaceExt fam - ; mb_tcs' <- mapM tc_rough mb_tcs - ; return (mkImportedFamInst fam' mb_tcs' tycon') } - -tc_rough Nothing = return Nothing -tc_rough (Just tc) = do { tc' <- lookupIfaceTc tc; return (Just tc') } + ; let mb_tcs' = map (fmap ifaceTyConName) mb_tcs + ; return (mkImportedFamInst fam mb_tcs' tycon') } \end{code} @@ -554,20 +533,21 @@ 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 + ; let this_module = if_mod lcl + ; returnM (Rule { ru_name = name, ru_fn = fn, ru_act = act, ru_bndrs = bndrs', ru_args = args', ru_rhs = rhs', ru_orph = orph, ru_rough = mb_tcs, - ru_local = isLocalIfaceExtName fn }) } + ru_local = nameModule fn == this_module }) } where -- This function *must* mirror exactly what Rules.topFreeName does -- We could have stored the ru_rough field in the iface file @@ -576,14 +556,11 @@ 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} @@ -725,8 +702,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 } @@ -931,12 +907,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 @@ -956,24 +931,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} %************************************************************************ @@ -1018,7 +990,7 @@ bindIfaceIds bndrs thing_inside newExtCoreBndr :: IfaceIdBndr -> IfL Id newExtCoreBndr (var, ty) = do { mod <- getIfModule - ; name <- newGlobalBinder mod (mkVarOccFS var) Nothing noSrcLoc + ; name <- newGlobalBinder mod (mkVarOccFS var) noSrcLoc ; ty' <- tcIfaceType ty ; return (mkLocalId name ty') } @@ -1032,14 +1004,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}