X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fiface%2FTcIface.lhs;h=6726adfaf9e5017790ffd0289519200fa5300f1d;hb=ac10f8408520a30e8437496d320b8b86afda2e8f;hp=f7b9ca0b6c23f5f4fcb71e5d2bb7b78196456252;hpb=dd313897eb9a14bcc7b81f97e4f2292c30039efd;p=ghc-hetmet.git diff --git a/ghc/compiler/iface/TcIface.lhs b/ghc/compiler/iface/TcIface.lhs index f7b9ca0..6726adf 100644 --- a/ghc/compiler/iface/TcIface.lhs +++ b/ghc/compiler/iface/TcIface.lhs @@ -13,7 +13,8 @@ module TcIface ( #include "HsVersions.h" import IfaceSyn -import LoadIface ( loadInterface, loadHomeInterface, loadDecls, findAndReadIface ) +import LoadIface ( loadInterface, loadWiredInHomeIface, + loadDecls, findAndReadIface ) import IfaceEnv ( lookupIfaceTop, lookupIfaceExt, newGlobalBinder, extendIfaceIdEnv, extendIfaceTyVarEnv, newIPName, tcIfaceTyVar, tcIfaceLclId, lookupIfaceTc, @@ -21,12 +22,10 @@ import IfaceEnv ( lookupIfaceTop, lookupIfaceExt, newGlobalBinder, import BuildTyCl ( buildSynTyCon, buildAlgTyCon, buildDataCon, buildClass, mkAbstractTyConRhs, mkDataTyConRhs, mkNewTyConRhs ) import TcRnMonad -import TcType ( hoistForAllTys ) -- TEMPORARY HACK -import Type ( liftedTypeKind, splitTyConApp, mkSynTy, mkTyConApp, - mkTyVarTys, ThetaType, - mkGenTyConApp ) -- Don't remove this... see mkIfTcApp +import Type ( liftedTypeKind, splitTyConApp, mkTyConApp, + mkTyVarTys, ThetaType ) import TypeRep ( Type(..), PredType(..) ) -import TyCon ( TyCon, tyConName, isSynTyCon ) +import TyCon ( TyCon, tyConName ) import HscTypes ( ExternalPackageState(..), TyThing(..), tyThingClass, tyThingTyCon, ModIface(..), ModDetails(..), HomeModInfo(..), @@ -45,7 +44,7 @@ import IdInfo ( IdInfo, CafInfo(..), WorkerInfo(..), vanillaIdInfo, newStrictnessInfo ) import Class ( Class ) import TyCon ( tyConDataCons, isTupleTyCon, mkForeignTyCon ) -import DataCon ( DataCon, dataConWorkId, dataConTyVars, dataConArgTys, isVanillaDataCon ) +import DataCon ( DataCon, dataConWorkId, dataConTyVars, dataConInstArgTys, isVanillaDataCon ) import TysWiredIn ( tupleCon, tupleTyCon, listTyCon, intTyCon, boolTyCon, charTyCon, parrTyCon ) import Var ( TyVar, mkTyVar, tyVarKind ) import Name ( Name, nameModule, nameIsLocalOrFrom, isWiredInName, @@ -110,39 +109,33 @@ tcImportDecl :: Name -> TcM TyThing -- Entry point for *source-code* uses of importDecl tcImportDecl name | Just thing <- wiredInNameTyThing_maybe name - = do { checkWiredInName name; return thing } + = do { initIfaceTcRn (loadWiredInHomeIface name) + ; return thing } | otherwise - = do { traceIf (text "tcLookupGlobal" <+> ppr name) + = do { traceIf (text "tcImportDecl" <+> ppr name) ; mb_thing <- initIfaceTcRn (importDecl name) ; case mb_thing of Succeeded thing -> return thing Failed err -> failWithTc err } checkWiredInTyCon :: TyCon -> TcM () --- Ensure its instances are loaded --- It might not be a wired-in tycon (see the calls in TcUnify) +-- Ensure that the home module of the TyCon (and hence its instances) +-- are loaded. 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 = checkWiredInName tc_name - where - tc_name = tyConName tc - -checkWiredInName :: Name -> TcM () --- We "check" a wired-in name solely to check that its --- interface file is loaded, so that we're sure that we see --- its instance declarations and rules -checkWiredInName name - = ASSERT( isWiredInName name ) - do { mod <- getModule - ; if nameIsLocalOrFrom mod name then + | not (isWiredInName tc_name) + = return () + | otherwise + = do { mod <- getModule + ; if nameIsLocalOrFrom mod tc_name then -- Don't look for (non-existent) Float.hi when -- compiling Float.lhs, which mentions Float of course return () else -- A bit yukky to call initIfaceTcRn here - do { loadHomeInterface doc name; return () } + initIfaceTcRn (loadWiredInHomeIface tc_name) } where - doc = ptext SLIT("Need home interface for wired-in thing") <+> ppr name + tc_name = tyConName tc importDecl :: Name -> IfM lcl (MaybeErr Message TyThing) -- Get the TyThing for this Name from an interface file @@ -242,10 +235,19 @@ tcHiBootIface mod ; if not (isOneShot mode) -- In --make and interactive mode, if this module has an hs-boot file -- we'll have compiled it already, and it'll be in the HPT + -- + -- We check wheher the interface is a *boot* interface. + -- It can happen (when using GHC from Visual Studio) that we + -- compile a module in TypecheckOnly mode, with a stable, + -- fully-populated HPT. In that case the boot interface isn't there + -- (it's been replaced by the mother module) so we can't check it. + -- And that's fine, because if M's ModInfo is in the HPT, then + -- it's been compiled once, and we don't need to check the boot iface then do { hpt <- getHpt ; case lookupModuleEnv hpt mod of - Just info -> return (hm_details info) - Nothing -> return emptyModDetails } + Just info | mi_boot (hm_iface info) + -> return (hm_details info) + other -> return emptyModDetails } else do -- OK, so we're in one-shot mode. @@ -531,22 +533,12 @@ tcIfaceType :: IfaceType -> IfL Type tcIfaceType (IfaceTyVar n) = do { tv <- tcIfaceTyVar n; return (TyVarTy tv) } tcIfaceType (IfaceAppTy t1 t2) = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (AppTy t1' t2') } 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 (mkIfTcApp tc' ts') } +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') } tcIfaceTypes tys = mapM tcIfaceType tys -mkIfTcApp :: TyCon -> [Type] -> Type --- In interface files we retain type synonyms (for brevity and better error --- messages), but type synonyms can expand into non-hoisted types (ones with --- foralls to the right of an arrow), so we must be careful to hoist them here. --- This hack should go away when we get rid of hoisting. --- Then we should go back to mkGenTyConApp or something like it -mkIfTcApp tc tys - | isSynTyCon tc = hoistForAllTys (mkSynTy tc tys) - | otherwise = mkTyConApp tc tys - ----------------------------------------- tcIfacePredType :: IfacePredType -> IfL PredType tcIfacePredType (IfaceClassP cls ts) = do { cls' <- tcIfaceClass cls; ts' <- tcIfaceTypes ts; return (ClassP cls' ts') } @@ -678,7 +670,7 @@ tcIfaceAlt (tycon, inst_tys) (IfaceDataAlt data_occ, arg_occs, rhs) arg_names <- newIfaceNames arg_occs ; let tyvars = [ mkTyVar name (tyVarKind tv) | (name,tv) <- arg_names `zip` dataConTyVars con] - arg_tys = dataConArgTys con (mkTyVarTys tyvars) + arg_tys = dataConInstArgTys con (mkTyVarTys tyvars) id_names = dropList tyvars arg_names arg_ids = ASSERT2( equalLength id_names arg_tys, ppr (con, arg_names, rhs) $$ ppr tyvars $$ ppr arg_tys ) @@ -696,7 +688,7 @@ tcIfaceAlt (tycon, inst_tys) (IfaceTupleAlt boxity, arg_occs, rhs) tcVanillaAlt data_con inst_tys arg_occs rhs = do { arg_names <- newIfaceNames arg_occs - ; let arg_tys = dataConArgTys data_con inst_tys + ; let arg_tys = dataConInstArgTys data_con inst_tys ; let arg_ids = ASSERT2( equalLength arg_names arg_tys, ppr data_con <+> ppr inst_tys <+> ppr arg_occs $$ ppr rhs ) zipWith mkLocalId arg_names arg_tys @@ -834,7 +826,11 @@ tcPragExpr name expr tcIfaceGlobal :: Name -> IfL TyThing tcIfaceGlobal name | Just thing <- wiredInNameTyThing_maybe name - = return thing + -- Wired-in things include TyCons, DataCons, and Ids + = do { loadWiredInHomeIface name; return thing } + -- Even though we are in an interface file, we want to make + -- sure its instances are loaded (imagine f :: Double -> Double) + -- and its RULES are loaded too | otherwise = do { (eps,hpt) <- getEpsAndHpt ; case lookupType hpt (eps_PTE eps) name of { @@ -861,15 +857,30 @@ tcIfaceGlobal name }}}}} tcIfaceTyCon :: IfaceTyCon -> IfL TyCon -tcIfaceTyCon IfaceIntTc = return intTyCon -tcIfaceTyCon IfaceBoolTc = return boolTyCon -tcIfaceTyCon IfaceCharTc = return charTyCon -tcIfaceTyCon IfaceListTc = return listTyCon -tcIfaceTyCon IfacePArrTc = return parrTyCon -tcIfaceTyCon (IfaceTupTc bx ar) = return (tupleTyCon bx ar) -tcIfaceTyCon (IfaceTc ext_nm) = do { name <- lookupIfaceExt ext_nm - ; thing <- tcIfaceGlobal name - ; return (tyThingTyCon thing) } +tcIfaceTyCon IfaceIntTc = tcWiredInTyCon intTyCon +tcIfaceTyCon IfaceBoolTc = tcWiredInTyCon boolTyCon +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 + ; return (check_tc (tyThingTyCon thing)) } + where +#ifdef DEBUG + check_tc tc = case toIfaceTyCon (error "urk") tc of + IfaceTc _ -> tc + other -> pprTrace "check_tc" (ppr tc) tc +#else + check_tc tc = tc +#endif + +-- Even though we are in an interface file, we want to make +-- sure the instances and RULES of this tycon are loaded +-- Imagine: f :: Double -> Double +tcWiredInTyCon :: TyCon -> IfL TyCon +tcWiredInTyCon tc = do { loadWiredInHomeIface (tyConName tc) + ; return tc } tcIfaceClass :: IfaceExtName -> IfL Class tcIfaceClass rdr_name = do { name <- lookupIfaceExt rdr_name