From 33d4a6bdb9a9b267464459aa049a25f4542305f1 Mon Sep 17 00:00:00 2001 From: simonpj Date: Tue, 24 Oct 2000 15:55:36 +0000 Subject: [PATCH] [project @ 2000-10-24 15:55:35 by simonpj] More renamer --- ghc/compiler/hsSyn/HsCore.lhs | 23 +-- ghc/compiler/hsSyn/HsDecls.lhs | 26 ++- ghc/compiler/main/HscStats.lhs | 2 +- ghc/compiler/main/HscTypes.lhs | 7 +- ghc/compiler/main/MkIface.lhs | 42 ++-- ghc/compiler/prelude/TysWiredIn.lhs | 3 - ghc/compiler/rename/ParseIface.y | 42 ++-- ghc/compiler/rename/Rename.lhs | 180 ++++++++++++++--- ghc/compiler/rename/RnHiFiles.lhs | 127 ++++-------- ghc/compiler/rename/RnHsSyn.lhs | 1 - ghc/compiler/rename/RnIfaces.lhs | 78 ++++---- ghc/compiler/rename/RnMonad.lhs | 2 +- ghc/compiler/rename/RnNames.lhs | 43 ++-- ghc/compiler/rename/RnSource.lhs | 347 ++++++++++++++++----------------- ghc/compiler/typecheck/TcIfaceSig.lhs | 4 +- ghc/compiler/typecheck/TcModule.lhs | 26 ++- ghc/compiler/typecheck/TcMonad.lhs | 5 +- 17 files changed, 534 insertions(+), 424 deletions(-) diff --git a/ghc/compiler/hsSyn/HsCore.lhs b/ghc/compiler/hsSyn/HsCore.lhs index 0a4f8a9..8a02b6d 100644 --- a/ghc/compiler/hsSyn/HsCore.lhs +++ b/ghc/compiler/hsSyn/HsCore.lhs @@ -14,8 +14,7 @@ We could either use this, or parameterise @GenCoreExpr@ on @Types@ and module HsCore ( UfExpr(..), UfAlt, UfBinder(..), UfNote(..), UfBinding(..), UfConAlt(..), - HsIdInfo(..), - IfaceSig(..), ifaceSigName, + HsIdInfo(..), pprHsIdInfo, eq_ufExpr, eq_ufBinders, pprUfExpr, @@ -317,26 +316,6 @@ eq_ufConAlt env _ _ = False %************************************************************************ %* * -\subsection{Signatures in interface files} -%* * -%************************************************************************ - -\begin{code} -data IfaceSig name = IfaceSig name (HsType name) [HsIdInfo name] SrcLoc - -instance Ord name => Eq (IfaceSig name) where - (==) (IfaceSig n1 t1 i1 _) (IfaceSig n2 t2 i2 _) = n1==n2 && t1==t2 && i1==i2 - -instance (Outputable name) => Outputable (IfaceSig name) where - ppr (IfaceSig var ty info _) = hsep [ppr var, dcolon, ppr ty, pprHsIdInfo info] - -ifaceSigName :: IfaceSig name -> name -ifaceSigName (IfaceSig name _ _ _) = name -\end{code} - - -%************************************************************************ -%* * \subsection{Rules in interface files} %* * %************************************************************************ diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs index 66fde2f..c49a3c5 100644 --- a/ghc/compiler/hsSyn/HsDecls.lhs +++ b/ghc/compiler/hsSyn/HsDecls.lhs @@ -13,7 +13,6 @@ module HsDecls ( ExtName(..), isDynamicExtName, extNameStatic, ConDecl(..), ConDetails(..), BangType(..), getBangType, - IfaceSig(..), DeprecDecl(..), DeprecTxt, hsDeclName, instDeclName, tyClDeclName, tyClDeclNames, isClassDecl, isSynDecl, isDataDecl, countTyClDecls, toHsRule, @@ -28,7 +27,7 @@ import HsBinds ( HsBinds, MonoBinds, Sig(..), FixitySig(..) ) import HsExpr ( HsExpr ) import HsTypes import PprCore ( pprCoreRule ) -import HsCore ( UfExpr(UfVar), UfBinder, IfaceSig(..), ifaceSigName, +import HsCore ( UfExpr(UfVar), UfBinder, HsIdInfo, pprHsIdInfo, eq_ufBinders, eq_ufExpr, pprUfExpr, toUfExpr, toUfBndr ) import CoreSyn ( CoreRule(..) ) @@ -58,7 +57,6 @@ data HsDecl name pat | DefD (DefaultDecl name) | ValD (HsBinds name pat) | ForD (ForeignDecl name) - | SigD (IfaceSig name) | FixD (FixitySig name) | DeprecD (DeprecDecl name) | RuleD (RuleDecl name pat) @@ -84,7 +82,6 @@ hsDeclName :: (Outputable name, Outputable pat) #endif hsDeclName (TyClD decl) = tyClDeclName decl hsDeclName (InstD decl) = instDeclName decl -hsDeclName (SigD decl) = ifaceSigName decl hsDeclName (ForD (ForeignDecl name _ _ _ _ _)) = name hsDeclName (FixD (FixitySig name _ _)) = name -- Others don't make sense @@ -103,7 +100,6 @@ instance (Outputable name, Outputable pat) => Outputable (HsDecl name pat) where ppr (TyClD dcl) = ppr dcl - ppr (SigD sig) = ppr sig ppr (ValD binds) = ppr binds ppr (DefD def) = ppr def ppr (InstD inst) = ppr inst @@ -117,7 +113,6 @@ instance (Outputable name, Outputable pat) instance Ord name => Eq (HsDecl name pat) where -- Used only when comparing interfaces, -- at which time only signature and type/class decls - (SigD s1) == (SigD s2) = s1 == s2 (TyClD d1) == (TyClD d2) = d1 == d2 _ == _ = False \end{code} @@ -173,7 +168,12 @@ Plan of attack: \begin{code} data TyClDecl name pat - = TyData NewOrData + = IfaceSig name -- It may seem odd to classify an interface-file signature + (HsType name) -- as a 'TyClDecl', but it's very convenient. These three + [HsIdInfo name] -- are the kind that appear in interface files. + SrcLoc + + | TyData NewOrData (HsContext name) -- context name -- type constructor [HsTyVarBndr name] -- type variables @@ -202,6 +202,7 @@ data TyClDecl name pat SrcLoc tyClDeclName :: TyClDecl name pat -> name +tyClDeclName (IfaceSig name _ _ _) = name tyClDeclName (TyData _ _ name _ _ _ _ _ _ _) = name tyClDeclName (TySynonym name _ _ _) = name tyClDeclName (ClassDecl _ name _ _ _ _ _ _) = name @@ -222,6 +223,7 @@ tyClDeclNames (ClassDecl _ name _ _ sigs _ _ loc) tyClDeclNames (TyData _ _ name _ cons _ _ loc _ _) = (name,loc) : conDeclsNames cons +tyClDeclNames (IfaceSig _ _ _ _) = [] type ClassDeclSysNames name = [name] -- [tycon, datacon wrapper, datacon worker, @@ -252,6 +254,9 @@ isClassDecl other = False \begin{code} instance Ord name => Eq (TyClDecl name pat) where -- Used only when building interface files + (==) (IfaceSig n1 t1 i1 _) + (IfaceSig n2 t2 i2 _) = n1==n2 && t1==t2 && i1==i2 + (==) (TyData nd1 cxt1 n1 tvs1 cons1 _ _ _ _ _) (TyData nd2 cxt2 n2 tvs2 cons2 _ _ _ _ _) = n1 == n2 && @@ -294,19 +299,22 @@ eq_cls_sig env (ClassOpSig n1 dm1 ty1 _) (ClassOpSig n2 dm2 ty2 _) \end{code} \begin{code} -countTyClDecls :: [TyClDecl name pat] -> (Int, Int, Int, Int) +countTyClDecls :: [TyClDecl name pat] -> (Int, Int, Int, Int, Int) -- class, data, newtype, synonym decls countTyClDecls decls = (length [() | ClassDecl _ _ _ _ _ _ _ _ <- decls], length [() | TyData DataType _ _ _ _ _ _ _ _ _ <- decls], length [() | TyData NewType _ _ _ _ _ _ _ _ _ <- decls], - length [() | TySynonym _ _ _ _ <- decls]) + length [() | TySynonym _ _ _ _ <- decls], + length [() | IfaceSig _ _ _ _ <- decls]) \end{code} \begin{code} instance (Outputable name, Outputable pat) => Outputable (TyClDecl name pat) where + ppr (IfaceSig var ty info _) = hsep [ppr var, dcolon, ppr ty, pprHsIdInfo info] + ppr (TySynonym tycon tyvars mono_ty src_loc) = hang (ptext SLIT("type") <+> pp_decl_head [] tycon tyvars <+> equals) 4 (ppr mono_ty) diff --git a/ghc/compiler/main/HscStats.lhs b/ghc/compiler/main/HscStats.lhs index bb75ae1..12c261d 100644 --- a/ghc/compiler/main/HscStats.lhs +++ b/ghc/compiler/main/HscStats.lhs @@ -67,7 +67,7 @@ ppSourceStats short (HsModule name version exports imports decls _ src_loc) -- in class decls. ToDo tycl_decls = [d | TyClD d <- decls] - (class_ds, data_ds, newt_ds, type_ds) = countTyClDecls tycl_decls + (class_ds, data_ds, newt_ds, type_ds, _) = countTyClDecls tycl_decls inst_decls = [d | InstD d <- decls] inst_ds = length inst_decls diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs index 5c8c685..f2e10d9 100644 --- a/ghc/compiler/main/HscTypes.lhs +++ b/ghc/compiler/main/HscTypes.lhs @@ -60,8 +60,8 @@ import TyCon ( TyCon ) import BasicTypes ( Version, initialVersion, Fixity ) import HsSyn ( DeprecTxt ) -import RdrHsSyn ( RdrNameHsDecl ) -import RnHsSyn ( RenamedTyClDecl, RenamedIfaceSig, RenamedRuleDecl, RenamedInstDecl ) +import RdrHsSyn ( RdrNameHsDecl, RdrNameTyClDecl ) +import RnHsSyn ( RenamedTyClDecl, RenamedRuleDecl, RenamedInstDecl ) import CoreSyn ( CoreRule ) import Type ( Type ) @@ -138,7 +138,6 @@ data ModIface } data IfaceDecls = IfaceDecls { dcl_tycl :: [RenamedTyClDecl], -- Sorted - dcl_sigs :: [RenamedIfaceSig], -- Sorted dcl_rules :: [RenamedRuleDecl], -- Sorted dcl_insts :: [RenamedInstDecl] } -- Unsorted @@ -451,7 +450,7 @@ including the constructors of a type decl etc. The Bool is True just for the 'main' Name. \begin{code} -type DeclsMap = NameEnv (AvailInfo, Bool, (Module, RdrNameHsDecl)) +type DeclsMap = NameEnv (AvailInfo, Bool, (Module, RdrNameTyClDecl)) type IfaceInsts = Bag GatedDecl type IfaceRules = Bag GatedDecl diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index 5b6373a..d08264f 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -67,14 +67,15 @@ import List ( partition ) %************************************************************************ \begin{code} +completeModDetails :: ModDetails + -> [CoreBind] -> [Id] -- Final bindings, plus the top-level Ids from the + -- code generator; they have authoritative arity info + -> [ProtoCoreRule] -- Tidy orphan rules + -> ModDetails + completeIface :: Maybe ModIface -- The old interface, if we have it -> ModIface -- The new one, minus the decls and versions - -> ModDetails -- The ModDetails for this module - -> [CoreBind] -> [Id] -- Final bindings, plus the top-level Ids from the - -- code generator; they have authoritative arity info - -> [ProtoCoreRule] -- Tidy orphan rules - -> Maybe (ModIface, SDoc) -- The new one, complete with decls and versions -- The SDoc is a debug document giving differences -- Nothing => no change @@ -94,9 +95,8 @@ completeIface maybe_old_iface new_iface mod_details declsFromDetails :: ModDetails -> [CoreBind] -> [Id] -> [ProtoCoreRule] -> IfaceDecls declsFromDetails details tidy_binds final_ids tidy_orphan_rules - = IfaceDecls { dcl_tycl = ty_cls_dcls, + = IfaceDecls { dcl_tycl = ty_cls_dcls ++ bagToList val_dcls, dcl_insts = inst_dcls, - dcl_sigs = bagToList val_dcls, dcl_rules = rule_dcls } where dfun_ids = md_insts details @@ -326,7 +326,7 @@ ifaceId :: (Id -> IdInfo) -- This function "knows" the extra info added -> Bool -- True <=> recursive, so don't print unfolding -> Id -> CoreExpr -- The Id's right hand side - -> (RenamedIfaceSig, IdSet) -- The emitted stuff, plus any *extra* needed Ids + -> (RenamedTyClDecl, IdSet) -- The emitted stuff, plus any *extra* needed Ids ifaceId get_idinfo is_rec id rhs = (IfaceSig (getName id) (toHsType id_type) hs_idinfo noSrcLoc, new_needed_ids) @@ -484,7 +484,7 @@ addVersionInfo (Just old_iface@(ModIface { mi_version = old_version, vers_rules = bumpVersion no_rule_change (vers_rules old_version), vers_decls = sig_vers `plusNameEnv` tc_vers } - no_output_change = no_sig_change && no_tc_change && no_rule_change && no_export_change + no_output_change = no_tc_change && no_rule_change && no_export_change no_usage_change = mi_usages old_iface == mi_usages new_iface no_export_change = mi_exports old_iface == mi_exports new_iface -- Kept sorted @@ -494,30 +494,24 @@ addVersionInfo (Just old_iface@(ModIface { mi_version = old_version, -- Set the flag if anything changes. -- Assumes that the decls are sorted by hsDeclName. old_vers_decls = vers_decls old_version - (no_sig_change, pp_sig_diffs, sig_vers) = diffDecls ifaceSigName eq_sig old_vers_decls - (dcl_sigs old_decls) (dcl_sigs new_decls) - (no_tc_change, pp_tc_diffs, tc_vers) = diffDecls tyClDeclName eq_tc old_vers_decls - (dcl_tycl old_decls) (dcl_tycl new_decls) + (no_tc_change, pp_tc_diffs, tc_vers) = diffDecls old_vers_decls (dcl_tycl old_decls) (dcl_tycl new_decls) - -- When seeing if two decls are the same, - -- remember to check whether any relevant fixity has changed - eq_sig i1 i2 = i1 == i2 && same_fixity (ifaceSigName i1) - eq_tc d1 d2 = d1 == d2 && all (same_fixity . fst) (tyClDeclNames d1) - same_fixity n = lookupNameEnv old_fixities n == lookupNameEnv new_fixities n -diffDecls :: (Outputable decl) - => (decl->Name) - -> (decl->decl->Bool) -- True if no change - -> NameEnv Version -- Old version map - -> [decl] -> [decl] -- Old and new decls +diffDecls :: NameEnv Version -- Old version map + -> [RenamedTyClDecl] -> [RenamedTyClDecl] -- Old and new decls -> (Bool, -- True <=> no change SDoc, -- Record of differences NameEnv Version) -- New version -diffDecls get_name eq old_vers old new +diffDecls old_vers old new = diff True empty emptyNameEnv old new where + -- When seeing if two decls are the same, + -- remember to check whether any relevant fixity has changed + eq_tc d1 d2 = d1 == d2 && all (same_fixity . fst) (tyClDeclNames d1) + same_fixity n = lookupNameEnv old_fixities n == lookupNameEnv new_fixities n + diff ok_so_far pp new_vers [] [] = (ok_so_far, pp, new_vers) diff ok_so_far pp new_vers old [] = (False, pp, new_vers) diff ok_so_far pp new_vers [] (nd:nds) = diff False (pp $$ only_new nd) new_vers [] nds diff --git a/ghc/compiler/prelude/TysWiredIn.lhs b/ghc/compiler/prelude/TysWiredIn.lhs index c28bb3f..9699b61 100644 --- a/ghc/compiler/prelude/TysWiredIn.lhs +++ b/ghc/compiler/prelude/TysWiredIn.lhs @@ -256,7 +256,6 @@ mk_tc_gen_info mod tc_uniq tc_name tycon name1 = mkWiredInName mod occ_name1 fn1_key name2 = mkWiredInName mod occ_name2 fn2_key gen_info = mkTyConGenInfo tycon name1 name2 - Just (EP id1 id2) = gen_info unitTyCon = tupleTyCon Boxed 0 unitDataConId = dataConId (head (tyConDataCons unitTyCon)) @@ -576,8 +575,6 @@ data (,) a b = (,,) a b mkListTy :: Type -> Type mkListTy ty = mkTyConApp listTyCon [ty] -alphaListTy = mkSigmaTy alpha_tyvar [] (mkTyConApp listTyCon alpha_ty) - listTyCon = pcRecDataTyCon listTyConName alpha_tyvar [(True,False)] [nilDataCon, consDataCon] diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y index a51631f..0aff924 100644 --- a/ghc/compiler/rename/ParseIface.y +++ b/ghc/compiler/rename/ParseIface.y @@ -61,7 +61,7 @@ import OccName ( mkSysOccFS, ) import Module ( ModuleName, PackageName, mkSysModuleNameFS, mkModule ) import SrcLoc ( SrcLoc ) -import CmdLineOpts ( opt_InPackage ) +import CmdLineOpts ( opt_InPackage, opt_IgnoreIfacePragmas ) import Outputable import List ( insert ) import Class ( DefMeth (..) ) @@ -355,31 +355,47 @@ inst_decl : src_loc 'instance' type '=' var_name ';' -------------------------------------------------------------------------- -decls_part :: { [(Version, RdrNameHsDecl)] } +decls_part :: { [(Version, RdrNameTyClDecl)] } decls_part : {- empty -} { [] } | opt_version decl ';' decls_part { ($1,$2):$4 } -decl :: { RdrNameHsDecl } +decl :: { RdrNameTyClDecl } decl : src_loc var_name '::' type maybe_idinfo - { SigD (IfaceSig $2 $4 ($5 $2) $1) } + { IfaceSig $2 $4 ($5 $2) $1 } | src_loc 'type' tc_name tv_bndrs '=' type - { TyClD (TySynonym $3 $4 $6 $1) } + { TySynonym $3 $4 $6 $1 } | src_loc 'data' opt_decl_context tc_name tv_bndrs constrs - { TyClD (mkTyData DataType $3 $4 $5 $6 (length $6) Nothing $1) } + { mkTyData DataType $3 $4 $5 $6 (length $6) Nothing $1 } | src_loc 'newtype' opt_decl_context tc_name tv_bndrs newtype_constr - { TyClD (mkTyData NewType $3 $4 $5 $6 1 Nothing $1) } + { mkTyData NewType $3 $4 $5 $6 1 Nothing $1 } | src_loc 'class' opt_decl_context tc_name tv_bndrs fds csigs - { TyClD (mkClassDecl $3 $4 $5 $6 $7 EmptyMonoBinds $1) } + { mkClassDecl $3 $4 $5 $6 $7 EmptyMonoBinds $1 } maybe_idinfo :: { RdrName -> [HsIdInfo RdrName] } maybe_idinfo : {- empty -} { \_ -> [] } - | pragma { \x -> case $1 of - POk _ (PIdInfo id_info) -> id_info - PFailed err -> - pprPanic "IdInfo parse failed" - (vcat [ppr x, err]) + | pragma { \x -> if opt_IgnoreIfacePragmas then [] + else case $1 of + POk _ (PIdInfo id_info) -> id_info + PFailed err -> pprPanic "IdInfo parse failed" + (vcat [ppr x, err]) } + {- + If a signature decl is being loaded, and opt_IgnoreIfacePragmas is on, + we toss away unfolding information. + + Also, if the signature is loaded from a module we're importing from source, + we do the same. This is to avoid situations when compiling a pair of mutually + recursive modules, peering at unfolding info in the interface file of the other, + e.g., you compile A, it looks at B's interface file and may as a result change + its interface file. Hence, B is recompiled, maybe changing its interface file, + which will the unfolding info used in A to become invalid. Simple way out is to + just ignore unfolding info. + + [Jan 99: I junked the second test above. If we're importing from an hi-boot + file there isn't going to *be* any pragma info. The above comment + dates from a time where we picked up a .hi file first if it existed.] + -} pragma :: { ParseResult IfaceStuff } pragma : src_loc PRAGMA { parseIface $2 PState{ bol = 0#, atbol = 1#, diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index 9b95413..690b377 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -9,25 +9,28 @@ module Rename ( renameModule ) where #include "HsVersions.h" import HsSyn -import RdrHsSyn ( RdrNameHsModule, RdrNameHsDecl, RdrNameDeprecation ) -import RnHsSyn ( RenamedHsDecl, +import RdrHsSyn ( RdrNameHsModule, RdrNameHsDecl, RdrNameDeprecation, + RdrNameTyClDecl, RdrNameRuleDecl, RdrNameInstDecl + ) +import RnHsSyn ( RenamedHsDecl, RenamedTyClDecl, RenamedRuleDecl, RenamedInstDecl, extractHsTyNames, extractHsCtxtTyNames ) import CmdLineOpts ( DynFlags, DynFlag(..) ) import RnMonad import RnNames ( getGlobalNames ) -import RnSource ( rnSourceDecls, rnDecl ) +import RnSource ( rnSourceDecls, rnDecl, rnTyClDecl, rnRuleDecl, rnInstDecl ) import RnIfaces ( getImportedInstDecls, importDecl, mkImportInfo, getInterfaceExports, getImportedRules, getSlurped, - ImportDeclResult(..) + ImportDeclResult(..), + RecompileRequired, recompileRequired ) -import RnHiFiles ( removeContext ) +import RnHiFiles ( findAndReadIface, removeContext, loadExports, loadFixDecls, loadDeprecs ) import RnEnv ( availName, availsToNameSet, emptyAvailEnv, unitAvailEnv, availEnvElts, plusAvailEnv, sortAvails, warnUnusedImports, warnUnusedLocalBinds, warnUnusedModules, - lookupOrigNames, lookupGlobalRn, + lookupOrigNames, lookupGlobalRn, newGlobalName, FreeVars, plusFVs, plusFV, unitFV, emptyFVs, isEmptyFVs, addOneFV ) import Module ( Module, ModuleName, WhereFrom(..), @@ -60,7 +63,8 @@ import Maybes ( maybeToBool, catMaybes ) import Outputable import IO ( openFile, IOMode(..) ) import HscTypes ( Finder, PersistentCompilerState, HomeIfaceTable, HomeSymbolTable, - ModIface(..), TyThing(..), + ModIface(..), TyThing(..), WhatsImported(..), + VersionInfo(..), ImportVersion, IfaceDecls(..), GlobalRdrEnv, AvailEnv, Avails, GenAvailInfo(..), AvailInfo, Provenance(..), ImportReason(..), initialVersionInfo, Deprecations(..), lookupDeprec @@ -70,12 +74,19 @@ import List ( partition, nub ) +%********************************************************* +%* * +\subsection{The main function: rename} +%* * +%********************************************************* + \begin{code} renameModule :: DynFlags -> Finder -> HomeIfaceTable -> HomeSymbolTable -> PersistentCompilerState -> Module -> RdrNameHsModule -> IO (PersistentCompilerState, Maybe (ModIface, [RenamedHsDecl])) + -- Nothing => some error occurred in the renamer renameModule dflags finder hit hst old_pcs this_module rdr_module = -- Initialise the renamer monad @@ -86,9 +97,9 @@ renameModule dflags finder hit hst old_pcs this_module rdr_module -- Dump any debugging output dump_action ; - -- Return results + -- Return results. No harm in updating the PCS if errors_found then - return (old_pcs, Nothing) + return (new_pcs, Nothing) else return (new_pcs, maybe_rn_stuff) } @@ -332,8 +343,8 @@ slurpSourceRefs source_binders source_fvs WiredIn -> returnRn (decls, fvs, gates `plusFV` getWiredInGates wanted_name) Deferred -> returnRn (decls, fvs, gates `addOneFV` wanted_name) -- It's a type constructor - HereItIs decl -> rnIfaceDecl decl `thenRn` \ (new_decl, fvs1) -> - returnRn (new_decl : decls, + HereItIs decl -> rnIfaceTyClDecl decl `thenRn` \ (new_decl, fvs1) -> + returnRn (TyClD new_decl : decls, fvs1 `plusFV` fvs, gates `plusFV` getGates source_fvs new_decl) @@ -379,8 +390,8 @@ slurpDecl decls fvs wanted_name = importDecl wanted_name `thenRn` \ import_result -> case import_result of -- Found a declaration... rename it - HereItIs decl -> rnIfaceDecl decl `thenRn` \ (new_decl, fvs1) -> - returnRn (new_decl:decls, fvs1 `plusFV` fvs) + HereItIs decl -> rnIfaceTyClDecl decl `thenRn` \ (new_decl, fvs1) -> + returnRn (TyClD new_decl:decls, fvs1 `plusFV` fvs) -- No declaration... (wired in thing, or deferred, or already slurped) other -> returnRn (decls, fvs) @@ -394,7 +405,8 @@ rnIfaceDecls decls fvs [] = returnRn (decls, fvs) rnIfaceDecls decls fvs (d:ds) = rnIfaceDecl d `thenRn` \ (new_decl, fvs1) -> rnIfaceDecls (new_decl:decls) (fvs1 `plusFV` fvs) ds -rnIfaceDecl (mod, decl) = initIfaceRnMS mod (rnDecl decl) +rnIfaceDecl (mod, decl) = initIfaceRnMS mod (rnDecl decl) +rnIfaceTyClDecl (mod, decl) = initIfaceRnMS mod (rnTyClDecl decl) \end{code} @@ -466,10 +478,10 @@ decls for (say) @Eq Wibble@, when they can't possibly be useful. vars of the source program, and extracts from the decl the gate names. \begin{code} -getGates source_fvs (SigD (IfaceSig _ ty _ _)) +getGates source_fvs (IfaceSig _ ty _ _) = extractHsTyNames ty -getGates source_fvs (TyClD (ClassDecl ctxt cls tvs _ sigs _ _ _ )) +getGates source_fvs (ClassDecl ctxt cls tvs _ sigs _ _ _ ) = (delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) sigs) (hsTyVarNames tvs) `addOneToNameSet` cls) @@ -489,12 +501,12 @@ getGates source_fvs (TyClD (ClassDecl ctxt cls tvs _ sigs _ _ _ )) | otherwise = emptyFVs -getGates source_fvs (TyClD (TySynonym tycon tvs ty _)) +getGates source_fvs (TySynonym tycon tvs ty _) = delListFromNameSet (extractHsTyNames ty) (hsTyVarNames tvs) -- A type synonym type constructor isn't a "gate" for instance decls -getGates source_fvs (TyClD (TyData _ ctxt tycon tvs cons _ _ _ _ _)) +getGates source_fvs (TyData _ ctxt tycon tvs cons _ _ _ _ _) = delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) cons) (hsTyVarNames tvs) `addOneToNameSet` tycon @@ -522,8 +534,6 @@ getGates source_fvs (TyClD (TyData _ ctxt tycon tvs cons _ _ _ _ _)) | otherwise = emptyFVs get_bang bty = extractHsTyNames (getBangType bty) - -getGates source_fvs other_decl = emptyFVs \end{code} @getWiredInGates@ is just like @getGates@, but it sees a wired-in @Name@ @@ -630,6 +640,129 @@ rnDeprecs gbl_env Nothing decls \end{code} +%************************************************************************ +%* * +\subsection{Grabbing the old interface file and checking versions} +%* * +%************************************************************************ + +\begin{code} +checkOldIface :: DynFlags -> Finder + -> HomeIfaceTable -> HomeSymbolTable + -> PersistentCompilerState + -> Module + -> Bool -- Source unchanged + -> Maybe ModIface -- Old interface from compilation manager, if any + -> IO (PersistentCompilerState, Bool, (RecompileRequired, Maybe ModIface)) + -- True <=> errors happened + +checkOldIface dflags finder hit hst pcs mod source_unchanged maybe_iface + = initRn dflags finder hit hst pcs mod $ + + -- Load the old interface file, if we havn't already got it + loadOldIface mod maybe_iface `thenRn` \ maybe_iface -> + + -- Check versions + recompileRequired mod source_unchanged maybe_iface `thenRn` \ recompile -> + + returnRn (recompile, maybe_iface) +\end{code} + + +\begin{code} +loadOldIface :: Module -> Maybe ModIface -> RnMG (Maybe ModIface) +loadOldIface mod (Just iface) + = returnRn (Just iface) + +loadOldIface mod Nothing + = -- LOAD THE OLD INTERFACE FILE + findAndReadIface doc_str (moduleName mod) False {- Not hi-boot -} `thenRn` \ read_result -> + case read_result of { + Left err -> -- Old interface file not found, or garbled, so we'd better bail out + traceRn (vcat [ptext SLIT("No old interface file:"), err]) `thenRn_` + returnRn Nothing ; + + Right (_, iface) -> + + -- RENAME IT + initIfaceRnMS mod ( + loadHomeDecls (pi_decls iface) `thenRn` \ decls -> + loadHomeRules (pi_rules iface) `thenRn` \ rules -> + loadHomeInsts (pi_insts iface) `thenRn` \ insts -> + returnRn (decls, rules, insts) + ) `thenRn` \ ((decls_vers, new_decls), (rule_vers, new_rules), new_insts) -> + + mapRn loadHomeUsage (pi_usages iface) `thenRn` \ usages -> + loadExports (pi_exports iface) `thenRn` \ (export_vers, avails) -> + loadFixDecls mod (pi_fixity iface) `thenRn` \ fix_env -> + loadDeprecs mod (pi_deprecs iface) `thenRn` \ deprec_env -> + let + version = VersionInfo { vers_module = pi_vers iface, + vers_exports = export_vers, + vers_rules = rule_vers, + vers_decls = decls_vers } + + decls = IfaceDecls { dcl_tycl = new_decls, + dcl_rules = new_rules, + dcl_insts = new_insts } + + mod_iface = ModIface { mi_module = mod, mi_version = version, + mi_exports = avails, mi_orphan = pi_orphan iface, + mi_fixities = fix_env, mi_deprecs = deprec_env, + mi_usages = usages, + mi_decls = decls, + mi_globals = panic "No mi_globals in old interface" + } + in + returnRn (Just mod_iface) + } + + + where + doc_str = ptext SLIT("need usage info from") <+> ppr mod +\end{code} + +\begin{code} +loadHomeDecls :: [(Version, RdrNameTyClDecl)] + -> RnMS (NameEnv Version, [RenamedTyClDecl]) +loadHomeDecls decls = foldlRn loadHomeDecl (emptyNameEnv, []) decls + +loadHomeDecl :: (NameEnv Version, [RenamedTyClDecl]) + -> (Version, RdrNameTyClDecl) + -> RnMS (NameEnv Version, [RenamedTyClDecl]) +loadHomeDecl (version_map, decls) (version, decl) + = rnTyClDecl decl `thenRn` \ (decl', _) -> + returnRn (extendNameEnv version_map (tyClDeclName decl') version, decl':decls) + +------------------ +loadHomeRules :: (Version, [RdrNameRuleDecl]) + -> RnMS (Version, [RenamedRuleDecl]) +loadHomeRules (version, rules) + = mapAndUnzipRn rnRuleDecl rules `thenRn` \ (rules', _) -> + returnRn (version, rules') + +------------------ +loadHomeInsts :: [RdrNameInstDecl] + -> RnMS [RenamedInstDecl] +loadHomeInsts insts = mapAndUnzipRn rnInstDecl insts `thenRn` \ (insts', _) -> + returnRn insts' + +------------------ +loadHomeUsage :: ImportVersion OccName + -> RnMG (ImportVersion Name) +loadHomeUsage (mod_name, orphans, is_boot, whats_imported) + = rn_imps whats_imported `thenRn` \ whats_imported' -> + returnRn (mod_name, orphans, is_boot, whats_imported') + where + rn_imps NothingAtAll = returnRn NothingAtAll + rn_imps (Everything v) = returnRn (Everything v) + rn_imps (Specifically mv ev items rv) = mapRn rn_imp items `thenRn` \ items' -> + returnRn (Specifically mv ev items' rv) + rn_imp (occ,vers) = newGlobalName mod_name occ `thenRn` \ name -> + returnRn (name,vers) +\end{code} + + %********************************************************* %* * \subsection{Unused names} @@ -839,7 +972,7 @@ getRnStats imported_decls not (isLocallyDefined (availName avail)) ] - (cd_rd, dd_rd, nd_rd, sd_rd, vd_rd, _) = count_decls decls_read + (cd_rd, dd_rd, nd_rd, sd_rd, vd_rd) = countTyClDecls decls_read (cd_sp, dd_sp, nd_sp, sd_sp, vd_sp, id_sp) = count_decls imported_decls unslurped_insts = iInsts ifaces @@ -863,7 +996,7 @@ getRnStats imported_decls text "cls dcls slurp" <+> fsep (map (ppr . tyClDeclName) [d | TyClD d <- imported_decls, isClassDecl d]), text "cls dcls read" <+> fsep (map (ppr . tyClDeclName) - [d | TyClD d <- decls_read, isClassDecl d])] + [d | d <- decls_read, isClassDecl d])] in returnRn (hcat [text "Renamer stats: ", stats]) @@ -876,9 +1009,8 @@ count_decls decls inst_decls) where tycl_decls = [d | TyClD d <- decls] - (class_decls, data_decls, newtype_decls, syn_decls) = countTyClDecls tycl_decls + (class_decls, data_decls, newtype_decls, syn_decls, val_decls) = countTyClDecls tycl_decls - val_decls = length [() | SigD _ <- decls] inst_decls = length [() | InstD _ <- decls] \end{code} diff --git a/ghc/compiler/rename/RnHiFiles.lhs b/ghc/compiler/rename/RnHiFiles.lhs index 96b6ebc..54c3092 100644 --- a/ghc/compiler/rename/RnHiFiles.lhs +++ b/ghc/compiler/rename/RnHiFiles.lhs @@ -7,8 +7,9 @@ module RnHiFiles ( findAndReadIface, loadInterface, loadHomeInterface, tryLoadInterface, loadOrphanModules, + loadExports, loadFixDecls, loadDeprecs, - getDeclBinders, getDeclSysBinders, + getTyClDeclBinders, removeContext -- removeContext probably belongs somewhere else ) where @@ -16,16 +17,15 @@ module RnHiFiles ( import CmdLineOpts ( opt_IgnoreIfacePragmas ) import HscTypes -import HsSyn ( HsDecl(..), TyClDecl(..), InstDecl(..), IfaceSig(..), +import HsSyn ( HsDecl(..), TyClDecl(..), InstDecl(..), HsType(..), ConDecl(..), - ForeignDecl(..), ForKind(..), isDynamicExtName, FixitySig(..), RuleDecl(..), tyClDeclNames ) -import BasicTypes ( Version ) -import RdrHsSyn ( RdrNameHsDecl, RdrNameInstDecl, RdrNameRuleDecl, +import RdrHsSyn ( RdrNameTyClDecl, RdrNameInstDecl, RdrNameRuleDecl, extractHsTyRdrNames ) +import BasicTypes ( Version ) import RnEnv import RnMonad import ParseIface ( parseIface, IfaceStuff(..) ) @@ -33,7 +33,7 @@ import ParseIface ( parseIface, IfaceStuff(..) ) import Name ( Name {-instance NamedThing-}, nameOccName, nameModule, NamedThing(..), - mkNameEnv, elemNameEnv, extendNameEnv + mkNameEnv, extendNameEnv ) import Module ( Module, moduleName, isModuleInThisPackage, @@ -162,10 +162,10 @@ tryLoadInterface doc_str mod_name from loadDecls mod (iDecls ifaces) (pi_decls iface) `thenRn` \ (decls_vers, new_decls) -> loadRules mod (iRules ifaces) (pi_rules iface) `thenRn` \ (rule_vers, new_rules) -> - loadFixDecls mod_name (pi_fixity iface) `thenRn` \ fix_env -> - loadDeprecs mod (pi_deprecs iface) `thenRn` \ deprec_env -> foldlRn (loadInstDecl mod) (iInsts ifaces) (pi_insts iface) `thenRn` \ new_insts -> loadExports (pi_exports iface) `thenRn` \ (export_vers, avails) -> + loadFixDecls mod (pi_fixity iface) `thenRn` \ fix_env -> + loadDeprecs mod (pi_deprecs iface) `thenRn` \ deprec_env -> let version = VersionInfo { vers_module = pi_vers iface, vers_exports = export_vers, @@ -284,40 +284,26 @@ loadExport this_mod (mod, entities) loadDecls :: Module -> DeclsMap - -> [(Version, RdrNameHsDecl)] + -> [(Version, RdrNameTyClDecl)] -> RnM d (NameEnv Version, DeclsMap) loadDecls mod decls_map decls = foldlRn (loadDecl mod) (emptyNameEnv, decls_map) decls loadDecl :: Module -> (NameEnv Version, DeclsMap) - -> (Version, RdrNameHsDecl) + -> (Version, RdrNameTyClDecl) -> RnM d (NameEnv Version, DeclsMap) loadDecl mod (version_map, decls_map) (version, decl) - = getDeclBinders new_name decl `thenRn` \ maybe_avail -> - case maybe_avail of { - Nothing -> returnRn (version_map, decls_map); -- No bindings - Just avail -> - - getDeclSysBinders new_name decl `thenRn` \ sys_bndrs -> + = getIfaceDeclBinders new_name decl `thenRn` \ full_avail -> let - full_avail = addSysAvails avail sys_bndrs - -- Add the sys-binders to avail. When we import the decl, - -- it's full_avail that will get added to the 'already-slurped' set (iSlurp) - -- If we miss out sys-binders, we'll read the decl multiple times! - - main_name = availName avail - new_decls_map = foldl add_decl decls_map - [ (name, (full_avail, name==main_name, (mod, decl'))) - | name <- availNames full_avail] - add_decl decls_map (name, stuff) - = WARN( name `elemNameEnv` decls_map, ppr name ) - extendNameEnv decls_map name stuff + main_name = availName full_avail + new_decls_map = extendNameEnvList decls_map stuff + stuff = [ (name, (full_avail, name==main_name, (mod, decl))) + | name <- availNames full_avail] new_version_map = extendNameEnv version_map main_name version in returnRn (new_version_map, new_decls_map) - } where -- newTopBinder puts into the cache the binder with the -- module information set correctly. When the decl is later renamed, @@ -327,34 +313,16 @@ loadDecl mod (version_map, decls_map) (version, decl) -- the occurrences, so that doesn't matter new_name rdr_name loc = newTopBinder mod rdr_name loc - {- - If a signature decl is being loaded, and optIgnoreIfacePragmas is on, - we toss away unfolding information. - - Also, if the signature is loaded from a module we're importing from source, - we do the same. This is to avoid situations when compiling a pair of mutually - recursive modules, peering at unfolding info in the interface file of the other, - e.g., you compile A, it looks at B's interface file and may as a result change - its interface file. Hence, B is recompiled, maybe changing its interface file, - which will the unfolding info used in A to become invalid. Simple way out is to - just ignore unfolding info. - - [Jan 99: I junked the second test above. If we're importing from an hi-boot - file there isn't going to *be* any pragma info. Maybe the above comment - dates from a time where we picked up a .hi file first if it existed?] - -} - decl' = case decl of - SigD (IfaceSig name tp ls loc) | opt_IgnoreIfacePragmas - -> SigD (IfaceSig name tp [] loc) - other -> decl ----------------------------------------------------- -- Loading fixity decls ----------------------------------------------------- -loadFixDecls mod_name decls +loadFixDecls mod decls = mapRn (loadFixDecl mod_name) decls `thenRn` \ to_add -> returnRn (mkNameEnv to_add) + where + mod_name = moduleName mod loadFixDecl mod_name sig@(FixitySig rdr_name fixity loc) = newGlobalName mod_name (rdrNameOcc rdr_name) `thenRn` \ name -> @@ -429,7 +397,7 @@ loadRule mod decl@(IfaceRule _ _ var _ _ src_loc) loadDeprecs :: Module -> IfaceDeprecs -> RnM d Deprecations loadDeprecs m Nothing = returnRn NoDeprecs -loadDeprecs m (Just (Left txt)) = returnRn (DeprecAll txt) +loadDeprecs m (Just (Left txt)) = returnRn (DeprecAll txt) loadDeprecs m (Just (Right prs)) = setModuleRn m $ foldlRn loadDeprec emptyNameEnv prs `thenRn` \ env -> returnRn (DeprecSome env) @@ -454,39 +422,28 @@ It doesn't deal with source-code specific things: @ValD@, @DefD@. They are handled by the sourc-code specific stuff in @RnNames@. \begin{code} -getDeclBinders :: (RdrName -> SrcLoc -> RnM d Name) -- New-name function - -> RdrNameHsDecl - -> RnM d (Maybe AvailInfo) +getIfaceDeclBinders, getTyClDeclBinders + :: (RdrName -> SrcLoc -> RnM d Name) -- New-name function + -> RdrNameTyClDecl + -> RnM d AvailInfo + +getIfaceDeclBinders new_name tycl_decl + = getTyClDeclBinders new_name tycl_decl `thenRn` \ avail -> + getSysTyClDeclBinders new_name tycl_decl `thenRn` \ extras -> + returnRn (addSysAvails avail extras) + -- Add the sys-binders to avail. When we import the decl, + -- it's full_avail that will get added to the 'already-slurped' set (iSlurp) + -- If we miss out sys-binders, we'll read the decl multiple times! -getDeclBinders new_name (TyClD tycl_decl) +getTyClDeclBinders new_name (IfaceSig var ty prags src_loc) + = new_name var src_loc `thenRn` \ var_name -> + returnRn (Avail var_name) + +getTyClDeclBinders new_name tycl_decl = mapRn do_one (tyClDeclNames tycl_decl) `thenRn` \ (main_name:sub_names) -> - returnRn (Just (AvailTC main_name (main_name : sub_names))) + returnRn (AvailTC main_name (main_name : sub_names)) where do_one (name,loc) = new_name name loc - -getDeclBinders new_name (SigD (IfaceSig var ty prags src_loc)) - = new_name var src_loc `thenRn` \ var_name -> - returnRn (Just (Avail var_name)) - - -- foreign declarations -getDeclBinders new_name (ForD (ForeignDecl nm kind _ dyn _ loc)) - | binds_haskell_name kind dyn - = new_name nm loc `thenRn` \ name -> - returnRn (Just (Avail name)) - - | otherwise -- a foreign export - = lookupOrigName nm `thenRn_` - returnRn Nothing - -getDeclBinders new_name (FixD _) = returnRn Nothing -getDeclBinders new_name (DeprecD _) = returnRn Nothing -getDeclBinders new_name (DefD _) = returnRn Nothing -getDeclBinders new_name (InstD _) = returnRn Nothing -getDeclBinders new_name (RuleD _) = returnRn Nothing - -binds_haskell_name (FoImport _) _ = True -binds_haskell_name FoLabel _ = True -binds_haskell_name FoExport ext_nm = isDynamicExtName ext_nm \end{code} @getDeclSysBinders@ gets the implicit binders introduced by a decl. @@ -499,17 +456,18 @@ and the dict fun of an instance decl, because both of these have bindings of their own elsewhere. \begin{code} -getDeclSysBinders new_name (TyClD (ClassDecl _ cname _ _ sigs _ names src_loc)) +getSysTyClDeclBinders new_name (ClassDecl _ cname _ _ sigs _ names src_loc) = sequenceRn [new_name n src_loc | n <- names] -getDeclSysBinders new_name (TyClD (TyData _ _ _ _ cons _ _ _ _ _)) +getSysTyClDeclBinders new_name (TyData _ _ _ _ cons _ _ _ _ _) = sequenceRn [new_name wkr_name src_loc | ConDecl _ wkr_name _ _ _ src_loc <- cons] -getDeclSysBinders new_name other_decl +getSysTyClDeclBinders new_name other_decl = returnRn [] \end{code} + %********************************************************* %* * \subsection{Reading an interface file} @@ -526,9 +484,6 @@ findAndReadIface :: SDoc -> ModuleName findAndReadIface doc_str mod_name hi_boot_file = traceRn trace_msg `thenRn_` - -- we keep two maps for interface files, - -- one for 'normal' ones, the other for .hi-boot files, - -- hence the need to signal which kind we're interested. getFinderRn `thenRn` \ finder -> ioToRnM (finder mod_name) `thenRn` \ maybe_found -> diff --git a/ghc/compiler/rename/RnHsSyn.lhs b/ghc/compiler/rename/RnHsSyn.lhs index 7ef1cc3..9642f05 100644 --- a/ghc/compiler/rename/RnHsSyn.lhs +++ b/ghc/compiler/rename/RnHsSyn.lhs @@ -44,7 +44,6 @@ type RenamedStmt = Stmt Name RenamedPat type RenamedFixitySig = FixitySig Name type RenamedDeprecation = DeprecDecl Name type RenamedHsOverLit = HsOverLit Name -type RenamedIfaceSig = IfaceSig Name \end{code} %************************************************************************ diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs index 591c92e..128ee1d 100644 --- a/ghc/compiler/rename/RnIfaces.lhs +++ b/ghc/compiler/rename/RnIfaces.lhs @@ -12,7 +12,7 @@ module RnIfaces importDecl, ImportDeclResult(..), recordLocalSlurps, mkImportInfo, getSlurped, - recompileRequired + RecompileRequired, outOfDate, upToDate, recompileRequired ) where @@ -23,8 +23,10 @@ import HscTypes import HsSyn ( HsDecl(..), InstDecl(..), HsType(..) ) import HsImpExp ( ImportDecl(..) ) import BasicTypes ( Version, defaultFixity ) -import RdrHsSyn ( RdrNameHsDecl, RdrNameInstDecl ) -import RnHiFiles ( tryLoadInterface, loadHomeInterface, loadInterface, loadOrphanModules ) +import RdrHsSyn ( RdrNameHsDecl, RdrNameTyClDecl, RdrNameInstDecl ) +import RnHiFiles ( tryLoadInterface, loadHomeInterface, loadInterface, + loadOrphanModules + ) import RnEnv import RnMonad import Name ( Name {-instance NamedThing-}, nameOccName, @@ -83,6 +85,39 @@ getInterfaceExports mod_name from %* * %********************************************************* +This has to be in RnIfaces (or RnHiFiles) because it calls loadHomeInterface + +\begin{code} +lookupFixityRn :: Name -> RnMS Fixity +lookupFixityRn name + | isLocallyDefined name + = getFixityEnv `thenRn` \ local_fix_env -> + returnRn (lookupLocalFixity local_fix_env name) + + | otherwise -- Imported + -- For imported names, we have to get their fixities by doing a loadHomeInterface, + -- and consulting the Ifaces that comes back from that, because the interface + -- file for the Name might not have been loaded yet. Why not? Suppose you import module A, + -- which exports a function 'f', which is defined in module B. Then B isn't loaded + -- right away (after all, it's possible that nothing from B will be used). + -- When we come across a use of 'f', we need to know its fixity, and it's then, + -- and only then, that we load B.hi. That is what's happening here. + = getHomeIfaceTableRn `thenRn` \ hit -> + loadHomeInterface doc name `thenRn` \ ifaces -> + case lookupTable hit (iPIT ifaces) name of + Just iface -> returnRn (lookupNameEnv (mi_fixities iface) name `orElse` defaultFixity) + Nothing -> returnRn defaultFixity + where + doc = ptext SLIT("Checking fixity for") <+> ppr name +\end{code} + + +%********************************************************* +%* * +\subsection{Instance declarations are handled specially} +%* * +%********************************************************* + \begin{code} getImportedInstDecls :: NameSet -> RnMG [(Module,RdrNameHsDecl)] getImportedInstDecls gates @@ -148,28 +183,6 @@ selectGated gates decl_bag select (reqd, decl) (yes, no) | isEmptyNameSet (reqd `minusNameSet` gates) = (decl:yes, no) | otherwise = (yes, (reqd,decl) `consBag` no) - -lookupFixityRn :: Name -> RnMS Fixity -lookupFixityRn name - | isLocallyDefined name - = getFixityEnv `thenRn` \ local_fix_env -> - returnRn (lookupLocalFixity local_fix_env name) - - | otherwise -- Imported - -- For imported names, we have to get their fixities by doing a loadHomeInterface, - -- and consulting the Ifaces that comes back from that, because the interface - -- file for the Name might not have been loaded yet. Why not? Suppose you import module A, - -- which exports a function 'f', which is defined in module B. Then B isn't loaded - -- right away (after all, it's possible that nothing from B will be used). - -- When we come across a use of 'f', we need to know its fixity, and it's then, - -- and only then, that we load B.hi. That is what's happening here. - = getHomeIfaceTableRn `thenRn` \ hit -> - loadHomeInterface doc name `thenRn` \ ifaces -> - case lookupTable hit (iPIT ifaces) name of - Just iface -> returnRn (lookupNameEnv (mi_fixities iface) name `orElse` defaultFixity) - Nothing -> returnRn defaultFixity - where - doc = ptext SLIT("Checking fixity for") <+> ppr name \end{code} @@ -369,7 +382,7 @@ data ImportDeclResult = AlreadySlurped | WiredIn | Deferred - | HereItIs (Module, RdrNameHsDecl) + | HereItIs (Module, RdrNameTyClDecl) importDecl name = -- Check if it was loaded before beginning this module @@ -507,17 +520,12 @@ type RecompileRequired = Bool upToDate = False -- Recompile not required outOfDate = True -- Recompile required -recompileRequired :: DynFlags -> Finder - -> HomeIfaceTable -> HomeSymbolTable - -> PersistentCompilerState - -> Module +recompileRequired :: Module -> Bool -- Source unchanged -> Maybe ModIface -- Old interface, if any - -> IO (PersistentCompilerState, Bool, RecompileRequired) - -- True <=> errors happened -recompileRequired dflags finder hit hst pcs mod source_unchanged maybe_iface - = initRn dflags finder hit hst pcs mod $ - traceRn (text "Considering whether compilation is required for" <+> ppr mod <> colon) `thenRn_` + -> RnMG RecompileRequired +recompileRequired mod source_unchanged maybe_iface + = traceRn (text "Considering whether compilation is required for" <+> ppr mod <> colon) `thenRn_` -- CHECK WHETHER THE SOURCE HAS CHANGED if not source_unchanged then diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs index fd2e8b9..19e22d6 100644 --- a/ghc/compiler/rename/RnMonad.lhs +++ b/ghc/compiler/rename/RnMonad.lhs @@ -207,7 +207,7 @@ data ParsedIface pi_orphan :: WhetherHasOrphans, -- Whether this module has orphans pi_usages :: [ImportVersion OccName], -- Usages pi_exports :: (Version, [ExportItem]), -- Exports - pi_decls :: [(Version, RdrNameHsDecl)], -- Local definitions + pi_decls :: [(Version, RdrNameTyClDecl)], -- Local definitions pi_fixity :: [RdrNameFixitySig], -- Local fixity declarations, pi_insts :: [RdrNameInstDecl], -- Local instance declarations pi_rules :: (Version, [RdrNameRuleDecl]), -- Rules, with their version diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index 1b02331..a33df88 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -13,13 +13,14 @@ module RnNames ( import CmdLineOpts ( DynFlag(..), opt_NoImplicitPrelude ) import HsSyn ( HsModule(..), HsDecl(..), IE(..), ieName, ImportDecl(..), + ForeignDecl(..), ForKind(..), isDynamicExtName, collectTopBinders ) import RdrHsSyn ( RdrNameIE, RdrNameImportDecl, RdrNameHsModule, RdrNameHsDecl ) import RnIfaces ( getInterfaceExports, recordLocalSlurps ) -import RnHiFiles ( getDeclBinders ) +import RnHiFiles ( getTyClDeclBinders ) import RnEnv import RnMonad @@ -36,6 +37,7 @@ import HscTypes ( Provenance(..), ImportReason(..), GlobalRdrEnv, import RdrName ( RdrName, rdrNameOcc, setRdrNameOcc, mkRdrQual, mkRdrUnqual, isUnqual ) import OccName ( setOccNameSpace, dataName ) import NameSet ( elemNameSet, emptyNameSet ) +import SrcLoc ( SrcLoc ) import Outputable import Maybes ( maybeToBool, catMaybes, mapMaybe ) import UniqFM ( emptyUFM, listToUFM ) @@ -192,7 +194,7 @@ importsFromImportDecl is_unqual (ImportDecl imp_mod_name from qual_only as_mod i \begin{code} importsFromLocalDecls mod_name rec_exp_fn decls - = mapRn (getLocalDeclBinders mod rec_exp_fn) decls `thenRn` \ avails_s -> + = mapRn (getLocalDeclBinders (newLocalName mod rec_exp_fn)) decls `thenRn` \ avails_s -> let avails = concat avails_s @@ -219,21 +221,40 @@ importsFromLocalDecls mod_name rec_exp_fn decls where mod = mkModuleInThisPackage mod_name -getLocalDeclBinders :: Module - -> (Name -> Bool) -- Is-exported predicate +--------------------------- +getLocalDeclBinders :: (RdrName -> SrcLoc -> RnMG Name) -> RdrNameHsDecl -> RnMG Avails -getLocalDeclBinders mod rec_exp_fn (ValD binds) +getLocalDeclBinders new_name (ValD binds) = mapRn do_one (bagToList (collectTopBinders binds)) where - do_one (rdr_name, loc) = newLocalName mod rec_exp_fn rdr_name loc `thenRn` \ name -> + do_one (rdr_name, loc) = new_name rdr_name loc `thenRn` \ name -> returnRn (Avail name) -getLocalDeclBinders mod rec_exp_fn decl - = getDeclBinders (newLocalName mod rec_exp_fn) decl `thenRn` \ maybe_avail -> - case maybe_avail of - Nothing -> returnRn [] -- Instance decls and suchlike - Just avail -> returnRn [avail] +getLocalDeclBinders new_name (TyClD tycl_decl) + = getTyClDeclBinders new_name tycl_decl `thenRn` \ avail -> + returnRn [avail] +getLocalDeclBinders new_name (ForD (ForeignDecl nm kind _ ext_nm _ loc)) + | binds_haskell_name kind + = new_name nm loc `thenRn` \ name -> + returnRn [Avail name] + + | otherwise -- a foreign export + = lookupOrigName nm `thenRn_` + returnRn [] + where + binds_haskell_name (FoImport _) = True + binds_haskell_name FoLabel = True + binds_haskell_name FoExport = isDynamicExtName ext_nm + +getLocalDeclBinders new_name (FixD _) = returnRn [] +getLocalDeclBinders new_name (DeprecD _) = returnRn [] +getLocalDeclBinders new_name (DefD _) = returnRn [] +getLocalDeclBinders new_name (InstD _) = returnRn [] +getLocalDeclBinders new_name (RuleD _) = returnRn [] + + +--------------------------- newLocalName mod rec_exp_fn rdr_name loc = check_unqual rdr_name loc `thenRn_` newTopBinder mod rdr_name loc `thenRn` \ name -> diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index 86729ae..1557d39 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -4,7 +4,9 @@ \section[RnSource]{Main pass of renamer} \begin{code} -module RnSource ( rnDecl, rnSourceDecls, rnHsType, rnHsSigType ) where +module RnSource ( rnDecl, rnTyClDecl, rnRuleDecl, rnInstDecl, + rnSourceDecls, rnHsType, rnHsSigType + ) where #include "HsVersions.h" @@ -102,20 +104,164 @@ rnDecl :: RdrNameHsDecl -> RnMS (RenamedHsDecl, FreeVars) rnDecl (ValD binds) = rnTopBinds binds `thenRn` \ (new_binds, fvs) -> returnRn (ValD new_binds, fvs) +rnDecl (TyClD tycl_decl) = rnTyClDecl tycl_decl `thenRn` \ (new_decl, fvs) -> + returnRn (TyClD new_decl, fvs) -rnDecl (SigD (IfaceSig name ty id_infos loc)) - = pushSrcLocRn loc $ - lookupTopBndrRn name `thenRn` \ name' -> - rnHsType doc_str ty `thenRn` \ (ty',fvs1) -> - mapFvRn rnIdInfo id_infos `thenRn` \ (id_infos', fvs2) -> - returnRn (SigD (IfaceSig name' ty' id_infos' loc), fvs1 `plusFV` fvs2) +rnDecl (RuleD rule) + = rnRuleDecl rule `thenRn` \ (new_rule, fvs) -> + returnRn (RuleD new_rule, fvs) + +rnDecl (InstD inst) + = rnInstDecl inst `thenRn` \ (new_inst, fvs) -> + returnRn (InstD new_inst, fvs) + +rnDecl (DefD (DefaultDecl tys src_loc)) + = pushSrcLocRn src_loc $ + rnHsTypes doc_str tys `thenRn` \ (tys', fvs) -> + returnRn (DefD (DefaultDecl tys' src_loc), fvs) where - doc_str = text "the interface signature for" <+> quotes (ppr name) + doc_str = text "a `default' declaration" + +rnDecl (ForD (ForeignDecl name imp_exp ty ext_nm cconv src_loc)) + = pushSrcLocRn src_loc $ + lookupOccRn name `thenRn` \ name' -> + let + extra_fvs FoExport + | isDyn = lookupOrigNames [makeStablePtr_RDR, deRefStablePtr_RDR, + bindIO_RDR, returnIO_RDR] + | otherwise = + lookupOrigNames [bindIO_RDR, returnIO_RDR] `thenRn` \ fvs -> + returnRn (addOneFV fvs name') + extra_fvs other = returnRn emptyFVs + in + checkRn (ok_ext_nm ext_nm) (badExtName ext_nm) `thenRn_` + + extra_fvs imp_exp `thenRn` \ fvs1 -> + + rnHsSigType fo_decl_msg ty `thenRn` \ (ty', fvs2) -> + returnRn (ForD (ForeignDecl name' imp_exp ty' ext_nm cconv src_loc), + fvs1 `plusFV` fvs2) + where + fo_decl_msg = ptext SLIT("a foreign declaration") + isDyn = isDynamicExtName ext_nm + + ok_ext_nm Dynamic = True + ok_ext_nm (ExtName nm (Just mb)) = isCLabelString nm && isCLabelString mb + ok_ext_nm (ExtName nm Nothing) = isCLabelString nm +\end{code} + + +%********************************************************* +%* * +\subsection{Instance declarations} +%* * +%********************************************************* + +\begin{code} +rnInstDecl (InstDecl inst_ty mbinds uprags maybe_dfun_rdr_name src_loc) + = pushSrcLocRn src_loc $ + rnHsSigType (text "an instance decl") inst_ty `thenRn` \ (inst_ty', inst_fvs) -> + let + inst_tyvars = case inst_ty' of + HsForAllTy (Just inst_tyvars) _ _ -> inst_tyvars + other -> [] + -- (Slightly strangely) the forall-d tyvars scope over + -- the method bindings too + in + + -- Rename the bindings + -- NB meth_names can be qualified! + checkDupNames meth_doc meth_names `thenRn_` + extendTyVarEnvFVRn (map hsTyVarName inst_tyvars) ( + rnMethodBinds [] mbinds + ) `thenRn` \ (mbinds', meth_fvs) -> + let + binders = collectMonoBinders mbinds' + binder_set = mkNameSet binders + in + -- Rename the prags and signatures. + -- Note that the type variables are not in scope here, + -- so that instance Eq a => Eq (T a) where + -- {-# SPECIALISE instance Eq a => Eq (T [a]) #-} + -- works OK. + -- + -- But the (unqualified) method names are in scope + bindLocalNames binders ( + renameSigs (okInstDclSig binder_set) uprags + ) `thenRn` \ (new_uprags, prag_fvs) -> + + (case maybe_dfun_rdr_name of + Nothing -> returnRn (Nothing, emptyFVs) + + Just dfun_rdr_name -> lookupSysBinder dfun_rdr_name `thenRn` \ dfun_name -> + returnRn (Just dfun_name, unitFV dfun_name) + ) `thenRn` \ (maybe_dfun_name, dfun_fv) -> + + -- The typechecker checks that all the bindings are for the right class. + returnRn (InstDecl inst_ty' mbinds' new_uprags maybe_dfun_name src_loc, + inst_fvs `plusFV` meth_fvs `plusFV` prag_fvs `plusFV` dfun_fv) + where + meth_doc = text "the bindings in an instance declaration" + meth_names = collectLocatedMonoBinders mbinds +\end{code} + +%********************************************************* +%* * +\subsection{Rules} +%* * +%********************************************************* + +\begin{code} +rnRuleDecl (IfaceRule rule_name vars fn args rhs src_loc) + = pushSrcLocRn src_loc $ + lookupOccRn fn `thenRn` \ fn' -> + rnCoreBndrs vars $ \ vars' -> + mapFvRn rnCoreExpr args `thenRn` \ (args', fvs1) -> + rnCoreExpr rhs `thenRn` \ (rhs', fvs2) -> + returnRn (IfaceRule rule_name vars' fn' args' rhs' src_loc, + (fvs1 `plusFV` fvs2) `addOneFV` fn') + +rnRuleDecl (IfaceRuleOut fn rule) + -- This one is used for BuiltInRules + -- The rule itself is already done, but the thing + -- to attach it to is not. + = lookupOccRn fn `thenRn` \ fn' -> + returnRn (IfaceRuleOut fn' rule, unitFV fn') + +rnRuleDecl (HsRule rule_name tvs vars lhs rhs src_loc) + = ASSERT( null tvs ) + pushSrcLocRn src_loc $ + + bindTyVarsFV2Rn doc (map UserTyVar sig_tvs) $ \ sig_tvs' _ -> + bindLocalsFVRn doc (map get_var vars) $ \ ids -> + mapFvRn rn_var (vars `zip` ids) `thenRn` \ (vars', fv_vars) -> + + rnExpr lhs `thenRn` \ (lhs', fv_lhs) -> + rnExpr rhs `thenRn` \ (rhs', fv_rhs) -> + checkRn (validRuleLhs ids lhs') + (badRuleLhsErr rule_name lhs') `thenRn_` + let + bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs)] + in + mapRn (addErrRn . badRuleVar rule_name) bad_vars `thenRn_` + returnRn (HsRule rule_name sig_tvs' vars' lhs' rhs' src_loc, + fv_vars `plusFV` fv_lhs `plusFV` fv_rhs) + where + doc = text "the transformation rule" <+> ptext rule_name + sig_tvs = extractRuleBndrsTyVars vars + + get_var (RuleBndr v) = v + get_var (RuleBndrSig v _) = v + + rn_var (RuleBndr v, id) = returnRn (RuleBndr id, emptyFVs) + rn_var (RuleBndrSig v t, id) = rnHsType doc t `thenRn` \ (t', fvs) -> + returnRn (RuleBndrSig id t', fvs) \end{code} + %********************************************************* %* * -\subsection{Type declarations} +\subsection{Type, class and iface sig declarations} %* * %********************************************************* @@ -133,7 +279,16 @@ and then go over it again to rename the tyvars! However, we can also do some scoping checks at the same time. \begin{code} -rnDecl (TyClD (TyData new_or_data context tycon tyvars condecls nconstrs derivings src_loc gen_name1 gen_name2)) +rnTyClDecl (IfaceSig name ty id_infos loc) + = pushSrcLocRn loc $ + lookupTopBndrRn name `thenRn` \ name' -> + rnHsType doc_str ty `thenRn` \ (ty',fvs1) -> + mapFvRn rnIdInfo id_infos `thenRn` \ (id_infos', fvs2) -> + returnRn (IfaceSig name' ty' id_infos' loc, fvs1 `plusFV` fvs2) + where + doc_str = text "the interface signature for" <+> quotes (ppr name) + +rnTyClDecl (TyData new_or_data context tycon tyvars condecls nconstrs derivings src_loc gen_name1 gen_name2) = pushSrcLocRn src_loc $ lookupTopBndrRn tycon `thenRn` \ tycon' -> bindTyVarsFVRn data_doc tyvars $ \ tyvars' -> @@ -143,20 +298,20 @@ rnDecl (TyClD (TyData new_or_data context tycon tyvars condecls nconstrs derivin lookupSysBinder gen_name1 `thenRn` \ name1' -> lookupSysBinder gen_name2 `thenRn` \ name2' -> rnDerivs derivings `thenRn` \ (derivings', deriv_fvs) -> - returnRn (TyClD (TyData new_or_data context' tycon' tyvars' condecls' nconstrs - derivings' src_loc name1' name2'), + returnRn (TyData new_or_data context' tycon' tyvars' condecls' nconstrs + derivings' src_loc name1' name2', cxt_fvs `plusFV` con_fvs `plusFV` deriv_fvs) where data_doc = text "the data type declaration for" <+> quotes (ppr tycon) con_names = map conDeclName condecls -rnDecl (TyClD (TySynonym name tyvars ty src_loc)) +rnTyClDecl (TySynonym name tyvars ty src_loc) = pushSrcLocRn src_loc $ doptRn Opt_GlasgowExts `thenRn` \ glaExts -> lookupTopBndrRn name `thenRn` \ name' -> bindTyVarsFVRn syn_doc tyvars $ \ tyvars' -> rnHsType syn_doc (unquantify glaExts ty) `thenRn` \ (ty', ty_fvs) -> - returnRn (TyClD (TySynonym name' tyvars' ty' src_loc), ty_fvs) + returnRn (TySynonym name' tyvars' ty' src_loc, ty_fvs) where syn_doc = text "the declaration for type synonym" <+> quotes (ppr name) @@ -165,7 +320,7 @@ rnDecl (TyClD (TySynonym name tyvars ty src_loc)) unquantify glaExts (HsForAllTy Nothing ctxt ty) | glaExts = ty unquantify glaExys ty = ty -rnDecl (TyClD (ClassDecl context cname tyvars fds sigs mbinds names src_loc)) +rnTyClDecl (ClassDecl context cname tyvars fds sigs mbinds names src_loc) = pushSrcLocRn src_loc $ lookupTopBndrRn cname `thenRn` \ cname' -> @@ -227,8 +382,8 @@ rnDecl (TyClD (ClassDecl context cname tyvars fds sigs mbinds names src_loc)) -- The renamer *could* check this for class decls, but can't -- for instance decls. - returnRn (TyClD (ClassDecl context' cname' tyvars' fds' (non_ops' ++ sigs') mbinds' - names' src_loc), + returnRn (ClassDecl context' cname' tyvars' fds' (non_ops' ++ sigs') mbinds' + names' src_loc, sig_fvs `plusFV` fix_fvs `plusFV` @@ -279,164 +434,6 @@ rnDecl (TyClD (ClassDecl context cname tyvars fds sigs mbinds names src_loc)) %********************************************************* %* * -\subsection{Instance declarations} -%* * -%********************************************************* - -\begin{code} -rnDecl (InstD (InstDecl inst_ty mbinds uprags maybe_dfun_rdr_name src_loc)) - = pushSrcLocRn src_loc $ - rnHsSigType (text "an instance decl") inst_ty `thenRn` \ (inst_ty', inst_fvs) -> - let - inst_tyvars = case inst_ty' of - HsForAllTy (Just inst_tyvars) _ _ -> inst_tyvars - other -> [] - -- (Slightly strangely) the forall-d tyvars scope over - -- the method bindings too - in - - -- Rename the bindings - -- NB meth_names can be qualified! - checkDupNames meth_doc meth_names `thenRn_` - extendTyVarEnvFVRn (map hsTyVarName inst_tyvars) ( - rnMethodBinds [] mbinds - ) `thenRn` \ (mbinds', meth_fvs) -> - let - binders = collectMonoBinders mbinds' - binder_set = mkNameSet binders - in - -- Rename the prags and signatures. - -- Note that the type variables are not in scope here, - -- so that instance Eq a => Eq (T a) where - -- {-# SPECIALISE instance Eq a => Eq (T [a]) #-} - -- works OK. - -- - -- But the (unqualified) method names are in scope - bindLocalNames binders ( - renameSigs (okInstDclSig binder_set) uprags - ) `thenRn` \ (new_uprags, prag_fvs) -> - - (case maybe_dfun_rdr_name of - Nothing -> returnRn (Nothing, emptyFVs) - - Just dfun_rdr_name -> lookupSysBinder dfun_rdr_name `thenRn` \ dfun_name -> - returnRn (Just dfun_name, unitFV dfun_name) - ) `thenRn` \ (maybe_dfun_name, dfun_fv) -> - - -- The typechecker checks that all the bindings are for the right class. - returnRn (InstD (InstDecl inst_ty' mbinds' new_uprags maybe_dfun_name src_loc), - inst_fvs `plusFV` meth_fvs `plusFV` prag_fvs `plusFV` dfun_fv) - where - meth_doc = text "the bindings in an instance declaration" - meth_names = collectLocatedMonoBinders mbinds -\end{code} - -%********************************************************* -%* * -\subsection{Default declarations} -%* * -%********************************************************* - -\begin{code} -rnDecl (DefD (DefaultDecl tys src_loc)) - = pushSrcLocRn src_loc $ - rnHsTypes doc_str tys `thenRn` \ (tys', fvs) -> - returnRn (DefD (DefaultDecl tys' src_loc), fvs) - where - doc_str = text "a `default' declaration" -\end{code} - -%********************************************************* -%* * -\subsection{Foreign declarations} -%* * -%********************************************************* - -\begin{code} -rnDecl (ForD (ForeignDecl name imp_exp ty ext_nm cconv src_loc)) - = pushSrcLocRn src_loc $ - lookupOccRn name `thenRn` \ name' -> - let - extra_fvs FoExport - | isDyn = lookupOrigNames [makeStablePtr_RDR, deRefStablePtr_RDR, - bindIO_RDR, returnIO_RDR] - | otherwise = - lookupOrigNames [bindIO_RDR, returnIO_RDR] `thenRn` \ fvs -> - returnRn (addOneFV fvs name') - extra_fvs other = returnRn emptyFVs - in - checkRn (ok_ext_nm ext_nm) (badExtName ext_nm) `thenRn_` - - extra_fvs imp_exp `thenRn` \ fvs1 -> - - rnHsSigType fo_decl_msg ty `thenRn` \ (ty', fvs2) -> - returnRn (ForD (ForeignDecl name' imp_exp ty' ext_nm cconv src_loc), - fvs1 `plusFV` fvs2) - where - fo_decl_msg = ptext SLIT("a foreign declaration") - isDyn = isDynamicExtName ext_nm - - ok_ext_nm Dynamic = True - ok_ext_nm (ExtName nm (Just mb)) = isCLabelString nm && isCLabelString mb - ok_ext_nm (ExtName nm Nothing) = isCLabelString nm -\end{code} - -%********************************************************* -%* * -\subsection{Rules} -%* * -%********************************************************* - -\begin{code} -rnDecl (RuleD (IfaceRule rule_name vars fn args rhs src_loc)) - = pushSrcLocRn src_loc $ - lookupOccRn fn `thenRn` \ fn' -> - rnCoreBndrs vars $ \ vars' -> - mapFvRn rnCoreExpr args `thenRn` \ (args', fvs1) -> - rnCoreExpr rhs `thenRn` \ (rhs', fvs2) -> - returnRn (RuleD (IfaceRule rule_name vars' fn' args' rhs' src_loc), - (fvs1 `plusFV` fvs2) `addOneFV` fn') - -rnDecl (RuleD (IfaceRuleOut fn rule)) - -- This one is used for BuiltInRules - -- The rule itself is already done, but the thing - -- to attach it to is not. - = lookupOccRn fn `thenRn` \ fn' -> - returnRn (RuleD (IfaceRuleOut fn' rule), unitFV fn') - -rnDecl (RuleD (HsRule rule_name tvs vars lhs rhs src_loc)) - = ASSERT( null tvs ) - pushSrcLocRn src_loc $ - - bindTyVarsFV2Rn doc (map UserTyVar sig_tvs) $ \ sig_tvs' _ -> - bindLocalsFVRn doc (map get_var vars) $ \ ids -> - mapFvRn rn_var (vars `zip` ids) `thenRn` \ (vars', fv_vars) -> - - rnExpr lhs `thenRn` \ (lhs', fv_lhs) -> - rnExpr rhs `thenRn` \ (rhs', fv_rhs) -> - checkRn (validRuleLhs ids lhs') - (badRuleLhsErr rule_name lhs') `thenRn_` - let - bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs)] - in - mapRn (addErrRn . badRuleVar rule_name) bad_vars `thenRn_` - returnRn (RuleD (HsRule rule_name sig_tvs' vars' lhs' rhs' src_loc), - fv_vars `plusFV` fv_lhs `plusFV` fv_rhs) - where - doc = text "the transformation rule" <+> ptext rule_name - sig_tvs = extractRuleBndrsTyVars vars - - get_var (RuleBndr v) = v - get_var (RuleBndrSig v _) = v - - rn_var (RuleBndr v, id) = returnRn (RuleBndr id, emptyFVs) - rn_var (RuleBndrSig v t, id) = rnHsType doc t `thenRn` \ (t', fvs) -> - returnRn (RuleBndrSig id t', fvs) -\end{code} - - -%********************************************************* -%* * \subsection{Support code for type/data declarations} %* * %********************************************************* diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs index f03bb4f..247b3b8 100644 --- a/ghc/compiler/typecheck/TcIfaceSig.lhs +++ b/ghc/compiler/typecheck/TcIfaceSig.lhs @@ -8,7 +8,7 @@ module TcIfaceSig ( tcInterfaceSigs, tcVar, tcCoreExpr, tcCoreLamBndrs ) where #include "HsVersions.h" -import HsSyn ( HsDecl(..), IfaceSig(..), HsTupCon(..) ) +import HsSyn ( HsDecl(..), TyClDecl(..), HsTupCon(..) ) import TcMonad import TcMonoType ( tcHsType ) -- NB: all the tyars in interface files are kinded, @@ -58,7 +58,7 @@ tcInterfaceSigs :: TcEnv -- Envt to use when checking unfoldings tcInterfaceSigs unf_env decls = listTc [ do_one name ty id_infos src_loc - | SigD (IfaceSig name ty id_infos src_loc) <- decls] + | TyClD (IfaceSig name ty id_infos src_loc) <- decls] where in_scope_vars = filter isLocallyDefined (tcEnvIds unf_env) diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs index d0e1993..ab16194 100644 --- a/ghc/compiler/typecheck/TcModule.lhs +++ b/ghc/compiler/typecheck/TcModule.lhs @@ -85,23 +85,29 @@ typecheckModule -> HomeSymbolTable -> HomeIfaceTable -> PackageIfaceTable - -> RenamedHsModule - -> IO (Maybe (TcEnv, TcResults)) + -> [RenamedHsDecl] + -> IO (Maybe TcResults) + +typecheckModule dflags this_mod pcs hst hit pit decls + = do env <- initTcEnv global_symbol_table + + (maybe_result, (errs,warns)) <- initTc dflags env tc_module + + let maybe_tc_result :: Maybe TcResults + maybe_tc_result = mapMaybe snd maybe_result -typecheckModule dflags this_mod pcs hst hit pit (HsModule mod_name _ _ _ decls _ src_loc) - = do env <- initTcEnv global_symbol_table - (maybe_result, (errs,warns)) <- initTc dflags env src_loc tc_module printErrorsAndWarnings (errs,warns) - printTcDump dflags maybe_result + printTcDump dflags maybe_tc_result + if isEmptyBag errs then return Nothing else - return maybe_result + return maybe_tc_result where global_symbol_table = pcs_PST pcs `plusModuleEnv` hst - tc_module = fixTc (\ ~(unf_env ,_) - -> tcModule pcs hst get_fixity this_mod decls unf_env) + tc_module :: TcM (TcEnv, TcResults) + tc_module = fixTc (\ ~(unf_env ,_) -> tcModule pcs hst get_fixity this_mod decls unf_env) get_fixity :: Name -> Maybe Fixity get_fixity nm = lookupTable hit pit nm `thenMaybe` \ iface -> @@ -283,7 +289,7 @@ noMainErr \begin{code} printTcDump dflags Nothing = return () -printTcDump dflags (Just (_,results)) +printTcDump dflags (Just results) = do dumpIfSet_dyn dflags Opt_D_dump_types "Type signatures" (dump_sigs results) dumpIfSet_dyn dflags Opt_D_dump_tc diff --git a/ghc/compiler/typecheck/TcMonad.lhs b/ghc/compiler/typecheck/TcMonad.lhs index ade2ce6..2a15234 100644 --- a/ghc/compiler/typecheck/TcMonad.lhs +++ b/ghc/compiler/typecheck/TcMonad.lhs @@ -124,11 +124,10 @@ type TcRef a = IORef a initTc :: DynFlags -> TcEnv - -> SrcLoc -> TcM r -> IO (Maybe r, (Bag ErrMsg, Bag WarnMsg)) -initTc dflags tc_env src_loc do_this +initTc dflags tc_env do_this = do { us <- mkSplitUniqSupply 'a' ; us_var <- newIORef us ; @@ -138,7 +137,7 @@ initTc dflags tc_env src_loc do_this let init_down = TcDown dflags [] us_var dfun_var - src_loc + noSrcLoc [] errs_var ; -- 1.7.10.4