X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fiface%2FTcIface.lhs;h=e2a71cedf12961452445016ee1085663a41b6f2a;hb=931a117d6236076788c560fb2e08c538be95bd45;hp=5062fd912408dafe8d41aa74e2749ec15d9bbe9e;hpb=f908524d82242e634347857726651be08f3e9f5d;p=ghc-hetmet.git diff --git a/ghc/compiler/iface/TcIface.lhs b/ghc/compiler/iface/TcIface.lhs index 5062fd9..e2a71ce 100644 --- a/ghc/compiler/iface/TcIface.lhs +++ b/ghc/compiler/iface/TcIface.lhs @@ -17,22 +17,21 @@ import LoadIface ( loadInterface, loadWiredInHomeIface, loadDecls, findAndReadIface ) import IfaceEnv ( lookupIfaceTop, lookupIfaceExt, newGlobalBinder, extendIfaceIdEnv, extendIfaceTyVarEnv, newIPName, - tcIfaceTyVar, tcIfaceLclId, lookupIfaceTc, + tcIfaceTyVar, tcIfaceLclId, lookupIfaceTc, refineIfaceIdEnv, newIfaceName, newIfaceNames, ifaceExportNames ) 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(..), emptyModDetails, lookupTypeEnv, lookupType, typeEnvIds ) import InstEnv ( Instance(..), mkImportedInstance ) +import Unify ( coreRefineTys ) import CoreSyn import CoreUtils ( exprType ) import CoreUnfold @@ -46,7 +45,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, @@ -114,7 +113,7 @@ tcImportDecl name = 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 @@ -237,10 +236,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. @@ -526,22 +534,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') } @@ -673,14 +671,22 @@ 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 ) zipWith mkLocalId id_names arg_tys + Just refine = coreRefineTys con tyvars (mkTyConApp tycon inst_tys) + ; rhs' <- extendIfaceTyVarEnv tyvars $ extendIfaceIdEnv arg_ids $ + refineIfaceIdEnv refine $ + -- You might think that we don't need to refine the envt here, + -- but we do: \(x::a) -> case y of + -- MkT -> case x of { True -> ... } + -- In the "case x" we need to know x's type, because we use that + -- to find which module to look for "True" in. Sigh. tcIfaceExpr rhs ; return (DataAlt con, tyvars ++ arg_ids, rhs') }} @@ -691,7 +697,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