X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fiface%2FTcIface.lhs;h=0b4df3336eacd9df55d4f1639c730bc245127650;hb=e8db8f8ea957807dc6d4f134a147ef60bfd0ee93;hp=caff95f6e90ffaa529f2f060bfe58881fb1a99ec;hpb=39dd1943735841b6cc62c91134189371ba571f38;p=ghc-hetmet.git diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index caff95f..0b4df33 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -51,14 +51,15 @@ import Var ( TyVar, mkTyVar, tyVarKind ) import Name ( Name, nameModule, nameIsLocalOrFrom, isWiredInName, wiredInNameTyThing_maybe, nameParent ) import NameEnv -import OccName ( OccName ) +import OccName ( OccName, mkVarOccFS, mkTyVarOcc ) +import FastString ( FastString ) import Module ( Module, lookupModuleEnv ) import UniqSupply ( initUs_ ) import Outputable import ErrUtils ( Message ) import Maybes ( MaybeErr(..) ) import SrcLoc ( noSrcLoc ) -import Util ( zipWithEqual, dropList, equalLength ) +import Util ( zipWithEqual, equalLength, splitAtList ) import DynFlags ( DynFlag(..), isOneShot ) \end{code} @@ -603,7 +604,7 @@ tcIfaceExpr (IfaceApp fun arg) tcIfaceExpr (IfaceCase scrut case_bndr ty alts) = tcIfaceExpr scrut `thenM` \ scrut' -> - newIfaceName case_bndr `thenM` \ case_bndr_name -> + newIfaceName (mkVarOccFS case_bndr) `thenM` \ case_bndr_name -> let scrut_ty = exprType scrut' case_bndr' = mkLocalId case_bndr_name scrut_ty @@ -639,7 +640,6 @@ tcIfaceExpr (IfaceNote note expr) IfaceCoerce to_ty -> tcIfaceType to_ty `thenM` \ to_ty' -> returnM (Note (Coerce to_ty' (exprType expr')) expr') - IfaceInlineCall -> returnM (Note InlineCall expr') IfaceInlineMe -> returnM (Note InlineMe expr') IfaceSCC cc -> returnM (Note (SCC cc) expr') IfaceCoreNote n -> returnM (Note (CoreNote n) expr') @@ -658,23 +658,24 @@ tcIfaceAlt _ (IfaceLitAlt lit, names, 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_occs, rhs) +tcIfaceAlt (tycon, inst_tys) (IfaceDataAlt data_occ, arg_strs, rhs) = do { let tycon_mod = nameModule (tyConName tycon) ; con <- tcIfaceDataCon (ExtPkg tycon_mod data_occ) ; ASSERT2( con `elem` tyConDataCons tycon, ppr con $$ ppr tycon $$ ppr (tyConDataCons tycon) ) if isVanillaDataCon con then - tcVanillaAlt con inst_tys arg_occs rhs + tcVanillaAlt con inst_tys arg_strs rhs else do { -- General case - arg_names <- newIfaceNames arg_occs + let (tyvar_strs, id_strs) = splitAtList (dataConTyVars con) arg_strs + ; tyvar_names <- mapM (newIfaceName . mkTyVarOcc) tyvar_strs + ; id_names <- mapM (newIfaceName . mkVarOccFS) id_strs ; let tyvars = [ mkTyVar name (tyVarKind tv) - | (name,tv) <- arg_names `zip` dataConTyVars con] + | (name,tv) <- tyvar_names `zip` dataConTyVars con ] 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 ) + ppr (con, tyvar_names++id_names, rhs) $$ ppr tyvars $$ ppr arg_tys ) zipWith mkLocalId id_names arg_tys Just refine = coreRefineTys con tyvars (mkTyConApp tycon inst_tys) @@ -695,11 +696,11 @@ tcIfaceAlt (tycon, inst_tys) (IfaceTupleAlt boxity, arg_occs, rhs) do { let [data_con] = tyConDataCons tycon ; tcVanillaAlt data_con inst_tys arg_occs rhs } -tcVanillaAlt data_con inst_tys arg_occs rhs - = do { arg_names <- newIfaceNames arg_occs +tcVanillaAlt data_con inst_tys arg_strs rhs + = do { arg_names <- newIfaceNames (map mkVarOccFS arg_strs) ; 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 ) + ppr data_con <+> ppr inst_tys <+> ppr arg_strs $$ ppr rhs ) zipWith mkLocalId arg_names arg_tys ; rhs' <- extendIfaceIdEnv arg_ids (tcIfaceExpr rhs) ; returnM (DataAlt data_con, arg_ids, rhs') } @@ -932,16 +933,16 @@ bindIfaceBndrs (b:bs) thing_inside thing_inside (b':bs') ----------------------- -bindIfaceId :: (OccName, IfaceType) -> (Id -> IfL a) -> IfL a +bindIfaceId :: IfaceIdBndr -> (Id -> IfL a) -> IfL a bindIfaceId (occ, ty) thing_inside - = do { name <- newIfaceName occ + = do { name <- newIfaceName (mkVarOccFS occ) ; ty' <- tcIfaceType ty ; let { id = mkLocalId name ty' } ; extendIfaceIdEnv [id] (thing_inside id) } -bindIfaceIds :: [(OccName, IfaceType)] -> ([Id] -> IfL a) -> IfL a +bindIfaceIds :: [IfaceIdBndr] -> ([Id] -> IfL a) -> IfL a bindIfaceIds bndrs thing_inside - = do { names <- newIfaceNames occs + = do { names <- newIfaceNames (map mkVarOccFS occs) ; tys' <- mappM tcIfaceType tys ; let { ids = zipWithEqual "tcCoreValBndr" mkLocalId names tys' } ; extendIfaceIdEnv ids (thing_inside ids) } @@ -950,23 +951,23 @@ bindIfaceIds bndrs thing_inside ----------------------- -newExtCoreBndr :: (OccName, IfaceType) -> IfL Id -newExtCoreBndr (occ, ty) +newExtCoreBndr :: IfaceIdBndr -> IfL Id +newExtCoreBndr (var, ty) = do { mod <- getIfModule - ; name <- newGlobalBinder mod occ Nothing noSrcLoc + ; name <- newGlobalBinder mod (mkVarOccFS var) Nothing noSrcLoc ; ty' <- tcIfaceType ty ; return (mkLocalId name ty') } ----------------------- bindIfaceTyVar :: IfaceTvBndr -> (TyVar -> IfL a) -> IfL a bindIfaceTyVar (occ,kind) thing_inside - = do { name <- newIfaceName occ + = do { name <- newIfaceName (mkTyVarOcc occ) ; let 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 occs + = do { names <- newIfaceNames (map mkTyVarOcc occs) ; let tyvars = zipWith mk_iface_tyvar names kinds ; extendIfaceTyVarEnv tyvars (thing_inside tyvars) } where