From: simonpj Date: Tue, 18 May 1999 14:56:15 +0000 (+0000) Subject: [project @ 1999-05-18 14:56:06 by simonpj] X-Git-Tag: Approximately_9120_patches~6204 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=0d8269cc016f7063365a9d335c6108703d3d1286;p=ghc-hetmet.git [project @ 1999-05-18 14:56:06 by simonpj] msg_rn --- diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y index 49e233e..ade69fd 100644 --- a/ghc/compiler/rename/ParseIface.y +++ b/ghc/compiler/rename/ParseIface.y @@ -5,7 +5,6 @@ module ParseIface ( parseIface, IfaceStuff(..) ) where import HsSyn -- quite a bit of stuff import RdrHsSyn -- oodles of synonyms -import HsDecls ( HsIdInfo(..), HsStrictnessInfo(..) ) import HsTypes ( mkHsForAllTy ) import HsCore import Const ( Literal(..), mkMachInt_safe ) @@ -19,7 +18,7 @@ import IdInfo ( ArityInfo, exactArity, CprInfo(..) ) import Lex import RnMonad ( ImportVersion, LocalVersion, ParsedIface(..), WhatsImported(..), - RdrNamePragma, ExportItem, RdrAvailInfo, GenAvailInfo(..) + RdrNamePragma, ExportItem, RdrAvailInfo, GenAvailInfo(..), WhetherHasOrphans ) import Bag ( emptyBag, unitBag, snocBag ) import FiniteMap ( emptyFM, unitFM, addToFM, plusFM, bagToFM, FiniteMap ) @@ -29,7 +28,7 @@ import OccName ( mkSysOccFS, tcName, varName, dataName, clsName, tvName, EncodedFS ) -import Module ( Module, mkSysModuleFS, IfaceFlavour, hiFile, hiBootFile ) +import Module ( ModuleName, mkSysModuleFS ) import PrelMods ( mkTupNameStr, mkUbxTupNameStr ) import PrelInfo ( mkTupConRdrName, mkUbxTupConRdrName ) import SrcLoc ( SrcLoc ) @@ -76,11 +75,12 @@ import Ratio ( (%) ) '__interface' { ITinterface } -- GHC-extension keywords '__export' { ITexport } - '__instimport' { ITinstimport } + '__depends' { ITdepends } '__forall' { ITforall } '__letrec' { ITletrec } '__coerce' { ITcoerce } - '__inline' { ITinline } + '__inline_call'{ ITinlineCall } + '__inline_me' { ITinlineMe } '__DEFAULT' { ITdefaultbranch } '__bot' { ITbottom } '__integer' { ITinteger_lit } @@ -101,6 +101,7 @@ import Ratio ( (%) ) '__C' { ITnocaf } '__U' { ITunfold $$ } '__S' { ITstrict $$ } + '__R' { ITrules } '__M' { ITcprinfo $$ } '..' { ITdotdot } -- reserved symbols @@ -157,25 +158,26 @@ iface_stuff :: { IfaceStuff } iface_stuff : iface { let (nm, iff) = $1 in PIface nm iff } | type { PType $1 } | id_info { PIdInfo $1 } + | '__R' rules { PRules $2 } -iface :: { (EncodedFS, ParsedIface) } -iface : '__interface' mod_fs INTEGER checkVersion 'where' - import_part - instance_import_part +iface :: { (ModuleName, ParsedIface) } +iface : '__interface' mod_fs INTEGER orphans checkVersion 'where' exports_part + import_part instance_decl_part decls_part + rules_part { ( $2 -- Module name - , ParsedIface - (fromInteger $3) -- Module version - (reverse $6) -- Usages - (reverse $8) -- Exports - (reverse $7) -- Instance import modules - (reverse $10) -- Decls - (reverse $9) -- Local instances - ) - } + , ParsedIface { + pi_mod = fromInteger $3, -- Module version + pi_orphan = $4, + pi_exports = $7, -- Exports + pi_usages = $8, -- Usages + pi_insts = $9, -- Local instances + pi_decls = $10, -- Decls + pi_rules = $11 -- Rules + } ) } -------------------------------------------------------------------------- @@ -184,12 +186,19 @@ import_part : { [] } | import_part import_decl { $2 : $1 } import_decl :: { ImportVersion OccName } -import_decl : 'import' mod_fs opt_bang INTEGER '::' whats_imported ';' - { (mkSysModuleFS $2 $3, fromInteger $4, $6) } +import_decl : 'import' mod_fs INTEGER orphans whats_imported ';' + { (mkSysModuleFS $2, fromInteger $3, $4, $5) } + -- import Foo 3 :: a 1 b 3 c 7 ; means import a,b,c from Foo + -- import Foo 3 ; means import all of Foo + -- import Foo 3 ! :: ...stuff... ; the ! means that Foo contains orphans + +orphans :: { WhetherHasOrphans } +orphans : { False } + | '!' { True } whats_imported :: { WhatsImported OccName } whats_imported : { Everything } - | name_version_pair name_version_pairs { Specifically ($1:$2) } + | '::' name_version_pairs { Specifically $2 } name_version_pairs :: { [LocalVersion OccName] } name_version_pairs : { [] } @@ -199,21 +208,13 @@ name_version_pair :: { LocalVersion OccName } name_version_pair : var_occ INTEGER { ($1, fromInteger $2) } | tc_occ INTEGER { ($1, fromInteger $2) } -instance_import_part :: { [Module] } -instance_import_part : { [] } - | instance_import_part '__instimport' mod_name ';' - { $3 : $1 } -------------------------------------------------------------------------- exports_part :: { [ExportItem] } exports_part : { [] } - | exports_part '__export' opt_bang mod_fs entities ';' - { (mkSysModuleFS $4 $3,$5) : $1 } - -opt_bang :: { IfaceFlavour } -opt_bang : { hiFile } - | '!' { hiBootFile } + | exports_part '__export' + mod_fs entities ';' { (mkSysModuleFS $3, $4) : $1 } entities :: { [RdrAvailInfo] } entities : { [] } @@ -259,11 +260,8 @@ csigs1 : csig { [$1] } | csig ';' csigs1 { $1 : $3 } csig :: { RdrNameSig } -csig : src_loc var_name '::' type { ClassOpSig $2 Nothing $4 $1 } - | src_loc var_name '=' '::' type - { ClassOpSig $2 - (Just (error "Un-filled-in default method")) - $5 $1 } +csig : src_loc var_name '::' type { mkClassOpSig False $2 $4 $1 } + | src_loc var_name '=' '::' type { mkClassOpSig True $2 $5 $1 } -------------------------------------------------------------------------- @@ -276,7 +274,7 @@ inst_decl : src_loc 'instance' type '=' var_name ';' { InstDecl $3 EmptyMonoBinds {- No bindings -} [] {- No user pragmas -} - (Just $5) {- Dfun id -} + $5 {- Dfun id -} $1 } @@ -313,6 +311,26 @@ maybe_idinfo : {- empty -} { \_ -> [] } ----------------------------------------------------------------------------- +rules_part :: { [RdrNameRuleDecl] } +rules_part : {- empty -} { [] } + | src_loc PRAGMA { case parseIface $2 $1 of + Succeeded (PRules rules) -> rules + Failed err -> pprPanic "Rules parse failed" err + } + +rules :: { [RdrNameRuleDecl] } + : {- empty -} { [] } + | rule ';' rules { $1:$3 } + +rule :: { RdrNameRuleDecl } +rule : src_loc STRING rule_forall qvar_name + core_args '=' core_expr { IfaceRuleDecl $4 (UfRuleBody $2 $3 $5 $7) $1 } + +rule_forall :: { [UfBinder RdrName] } +rule_forall : '__forall' '{' core_bndrs '}' { $3 } + +----------------------------------------------------------------------------- + version :: { Version } version : INTEGER { fromInteger $1 } @@ -414,8 +432,8 @@ atypes : { [] } mod_fs :: { EncodedFS } : CONID { $1 } -mod_name :: { Module } - : mod_fs { mkSysModuleFS $1 hiFile } +mod_name :: { ModuleName } + : mod_fs { mkSysModuleFS $1 } --------------------------------------------------- @@ -426,7 +444,7 @@ var_fs :: { EncodedFS } | '!' { SLIT("!") } -qvar_fs :: { (EncodedFS, EncodedFS, IfaceFlavour) } +qvar_fs :: { (EncodedFS, EncodedFS) } : QVARID { $1 } | QVARSYM { $1 } @@ -457,7 +475,7 @@ data_fs :: { EncodedFS } : CONID { $1 } | CONSYM { $1 } -qdata_fs :: { (EncodedFS, EncodedFS, IfaceFlavour) } +qdata_fs :: { (EncodedFS, EncodedFS) } : QCONID { $1 } | QCONSYM { $1 } @@ -539,11 +557,8 @@ id_info_item :: { HsIdInfo RdrName } : '__A' arity_info { HsArity $2 } | '__U' core_expr { HsUnfold $1 (Just $2) } | '__U' { HsUnfold $1 Nothing } - | '__P' spec_tvs - atypes '=' core_expr { HsSpecialise $2 $3 $5 } | '__C' { HsNoCafRefs } - strict_info :: { [HsIdInfo RdrName] } : cpr worker { ($1:$2) } | strict worker { ($1:$2) } @@ -553,17 +568,12 @@ cpr :: { HsIdInfo RdrName } : '__M' { HsCprInfo $1 } strict :: { HsIdInfo RdrName } - : '__S' { HsStrictness (HsStrictnessInfo $1) } + : '__S' { HsStrictness (HsStrictnessInfo $1) } worker :: { [HsIdInfo RdrName] } - : qvar_name '{' qdata_names '}' { [HsWorker $1 $3] } - | qvar_name { [HsWorker $1 []] } + : qvar_name { [HsWorker $1] } | {- nothing -} { [] } -spec_tvs :: { [HsTyVar RdrName] } - : '[' tv_bndrs ']' { $2 } - - arity_info :: { ArityInfo } : INTEGER { exactArity (fromInteger $1) } @@ -581,7 +591,8 @@ core_expr : '\\' core_bndrs '->' core_expr { foldr UfLam $4 $2 } | con_or_primop '{' core_args '}' { UfCon $1 $3 } | '__litlit' STRING atype { UfCon (UfLitLitCon $2 $3) [] } - | '__inline' core_expr { UfNote UfInlineCall $2 } + | '__inline_me' core_expr { UfNote UfInlineMe $2 } + | '__inline_call' core_expr { UfNote UfInlineCall $2 } | '__coerce' atype core_expr { UfNote (UfCoerce $2) $3 } | scc core_expr { UfNote (UfSCC $1) $2 } | fexpr { $1 } @@ -733,6 +744,7 @@ checkVersion :: { () } data IfaceStuff = PIface EncodedFS{-.hi module name-} ParsedIface | PIdInfo [HsIdInfo RdrName] | PType RdrNameHsType + | PRules [RdrNameRuleDecl] mkConDecl name (ex_tvs, ex_ctxt) details loc = ConDecl name ex_tvs ex_ctxt details loc } diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index d9b7e10..5720007 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -10,40 +10,44 @@ module Rename ( renameModule ) where import HsSyn import RdrHsSyn ( RdrNameHsModule ) -import RnHsSyn ( RenamedHsModule, RenamedHsDecl, extractHsTyNames ) +import RnHsSyn ( RenamedHsModule, RenamedHsDecl, extractHsTyNames, extractHsCtxtTyNames ) -import CmdLineOpts ( opt_HiMap, opt_D_show_rn_trace, - opt_D_dump_rn, opt_D_show_rn_stats, +import CmdLineOpts ( opt_HiMap, opt_D_dump_rn_trace, + opt_D_dump_rn, opt_D_dump_rn_stats, opt_WarnUnusedBinds, opt_WarnUnusedImports ) import RnMonad import RnNames ( getGlobalNames ) -import RnSource ( rnIfaceDecl, rnSourceDecls ) -import RnIfaces ( getImportedInstDecls, importDecl, getImportVersions, getSpecialInstModules, - getDeferredDataDecls, - mkSearchPath, getSlurpedNames, getRnStats +import RnSource ( rnSourceDecls, rnDecl ) +import RnIfaces ( getImportedInstDecls, importDecl, getImportVersions, + getImportedRules, loadHomeInterface, getSlurped ) -import RnEnv ( addImplicitOccsRn, availName, availNames, availsToNameSet, - warnUnusedTopNames +import RnEnv ( availName, availNames, availsToNameSet, + warnUnusedTopNames, mapFvRn, + FreeVars, plusFVs, plusFV, unitFV, emptyFVs, isEmptyFVs ) -import Module ( pprModule ) +import Module ( Module, ModuleName, pprModule, mkSearchPath, mkThisModule ) import Name ( Name, isLocallyDefined, NamedThing(..), ImportReason(..), Provenance(..), - nameModule, pprOccName, nameOccName, + pprOccName, nameOccName, getNameProvenance, occNameUserString, + maybeWiredInTyConName, maybeWiredInIdName, isWiredInName ) +import Id ( idType ) +import DataCon ( dataConTyCon, dataConType ) +import TyCon ( TyCon, tyConDataCons, isSynTyCon, getSynTyConDefn ) import RdrName ( RdrName ) import NameSet -import TyCon ( TyCon ) -import PrelMods ( mAIN, pREL_MAIN ) -import TysWiredIn ( unitTyCon, intTyCon, doubleTyCon ) +import PrelMods ( mAIN_Name, pREL_MAIN_Name ) +import TysWiredIn ( unitTyCon, intTyCon, doubleTyCon, boolTyCon ) import PrelInfo ( ioTyCon_NAME, thinAirIdNames ) -import Type ( funTyCon ) +import Type ( namesOfType, funTyCon ) import ErrUtils ( pprBagOfErrors, pprBagOfWarnings, doIfSet, dumpIfSet, ghcExit ) -import Bag ( isEmptyBag ) -import FiniteMap ( fmToList, delListFromFM ) +import BasicTypes ( NewOrData(..) ) +import Bag ( isEmptyBag, bagToList ) +import FiniteMap ( fmToList, delListFromFM, addToFM, sizeFM, eltsFM ) import UniqSupply ( UniqSupply ) import Util ( equivClasses ) import Maybes ( maybeToBool ) @@ -56,10 +60,11 @@ import Outputable renameModule :: UniqSupply -> RdrNameHsModule -> IO (Maybe - ( RenamedHsModule -- Output, after renaming - , InterfaceDetails -- Interface; for interface file generatino + ( Module + , RenamedHsModule -- Output, after renaming + , InterfaceDetails -- Interface; for interface file generation , RnNameSupply -- Final env; for renaming derivings - , [Module] -- Imported modules; for profiling + , [ModuleName] -- Imported modules; for profiling )) renameModule us this_mod@(HsModule mod_name vers exports imports local_decls loc) @@ -81,7 +86,7 @@ renameModule us this_mod@(HsModule mod_name vers exports imports local_decls loc -- Dump output, if any (case maybe_rn_stuff of Nothing -> return () - Just results@(rn_mod, _, _, _) + Just results@(_, rn_mod, _, _, _) -> dumpIfSet opt_D_dump_rn "Renamer:" (ppr rn_mod) ) >> @@ -103,17 +108,22 @@ rename this_mod@(HsModule mod_name vers exports imports local_decls loc) returnRn Nothing else let - Just (export_env, rn_env, global_avail_env) = maybe_stuff + Just (export_env, gbl_env, fixity_env, global_avail_env) = maybe_stuff in -- RENAME THE SOURCE - initRnMS rn_env SourceMode ( - addImplicits mod_name `thenRn_` + initRnMS gbl_env fixity_env SourceMode ( rnSourceDecls local_decls - ) `thenRn` \ (rn_local_decls, fvs) -> + ) `thenRn` \ (rn_local_decls, source_fvs) -> -- SLURP IN ALL THE NEEDED DECLARATIONS - slurpDecls rn_local_decls `thenRn` \ rn_all_decls -> + let + real_source_fvs = implicitFVs mod_name `plusFV` source_fvs + -- It's important to do the "plus" this way round, so that + -- when compiling the prelude, locally-defined (), Bool, etc + -- override the implicit ones. + in + slurpImpDecls real_source_fvs `thenRn` \ rn_imp_decls -> -- EXIT IF ERRORS FOUND checkErrsRn `thenRn` \ no_errs_so_far -> @@ -124,157 +134,308 @@ rename this_mod@(HsModule mod_name vers exports imports local_decls loc) else -- GENERATE THE VERSION/USAGE INFO - getImportVersions mod_name exports `thenRn` \ import_versions -> + getImportVersions mod_name exports `thenRn` \ my_usages -> getNameSupplyRn `thenRn` \ name_supply -> -- REPORT UNUSED NAMES - reportUnusedNames rn_env global_avail_env + reportUnusedNames gbl_env global_avail_env export_env - fvs `thenRn_` + source_fvs `thenRn_` - -- GENERATE THE SPECIAL-INSTANCE MODULE LIST - -- The "special instance" modules are those modules that contain instance - -- declarations that contain no type constructor or class that was declared - -- in that module. - getSpecialInstModules `thenRn` \ imported_special_inst_mods -> - let - special_inst_decls = [d | InstD d@(InstDecl inst_ty _ _ _ _) <- rn_local_decls, - all (not.isLocallyDefined) (nameSetToList (extractHsTyNames inst_ty)) - ] - special_inst_mods | null special_inst_decls = imported_special_inst_mods - | otherwise = mod_name : imported_special_inst_mods - in - - -- RETURN THE RENAMED MODULE let - import_mods = [mod | ImportDecl mod _ _ _ _ <- imports] - + has_orphans = any isOrphanDecl rn_local_decls + direct_import_mods = [mod | ImportDecl mod _ _ _ _ _ <- imports] + rn_all_decls = rn_imp_decls ++ rn_local_decls renamed_module = HsModule mod_name vers trashed_exports trashed_imports rn_all_decls loc in - rnStats rn_all_decls `thenRn_` - returnRn (Just (renamed_module, - (import_versions, export_env, special_inst_mods), - name_supply, - import_mods)) + rnStats rn_imp_decls `thenRn_` + returnRn (Just (mkThisModule mod_name, + renamed_module, + (has_orphans, my_usages, export_env), + name_supply, + direct_import_mods)) where trashed_exports = {-trace "rnSource:trashed_exports"-} Nothing trashed_imports = {-trace "rnSource:trashed_imports"-} [] \end{code} -@addImplicits@ forces the renamer to slurp in some things which aren't +@implicitFVs@ forces the renamer to slurp in some things which aren't mentioned explicitly, but which might be needed by the type checker. \begin{code} -addImplicits mod_name - = addImplicitOccsRn (implicit_main ++ default_tys ++ thinAirIdNames) +implicitFVs mod_name + = implicit_main `plusFV` + mkNameSet default_tys `plusFV` + mkNameSet thinAirIdNames where -- Add occurrences for Int, Double, and (), because they -- are the types to which ambigious type variables may be defaulted by -- the type checker; so they won't always appear explicitly. -- [The () one is a GHC extension for defaulting CCall results.] -- ALSO: funTyCon, since it occurs implicitly everywhere! - -- (we don't want to be bothered with addImplicitOcc at every - -- function application) + -- (we don't want to be bothered with making funTyCon a + -- free var at every function application!) default_tys = [getName intTyCon, getName doubleTyCon, - getName unitTyCon, getName funTyCon] + getName unitTyCon, getName funTyCon, getName boolTyCon] -- Add occurrences for IO or PrimIO - implicit_main | mod_name == mAIN - || mod_name == pREL_MAIN = [ioTyCon_NAME] - | otherwise = [] + implicit_main | mod_name == mAIN_Name + || mod_name == pREL_MAIN_Name = unitFV ioTyCon_NAME + | otherwise = emptyFVs +\end{code} + +\begin{code} +isOrphanDecl (InstD (InstDecl inst_ty _ _ _ _)) + = not (foldNameSet ((||) . isLocallyDefined) False (extractHsTyNames inst_ty)) +isOrphanDecl (RuleD (RuleDecl _ _ _ lhs _ _)) + = check lhs + where + check (HsVar v) = not (isLocallyDefined v) + check (HsApp f a) = check f && check a + check other = True +isOrphanDecl other = False \end{code} +%********************************************************* +%* * +\subsection{Slurping declarations} +%* * +%********************************************************* + \begin{code} -slurpDecls decls - = -- First of all, get all the compulsory decls - slurp_compulsories decls `thenRn` \ decls1 -> +------------------------------------------------------- +slurpImpDecls source_fvs + = traceRn (text "slurpImp" <+> fsep (map ppr (nameSetToList source_fvs))) `thenRn_` + -- The current slurped-set records all local things + getSlurped `thenRn` \ local_binders -> + + slurpSourceRefs source_fvs `thenRn` \ (decls1, needed1, wired_in) -> + let + inst_gates1 = foldr (plusFV . getWiredInGates) source_fvs wired_in + inst_gates2 = foldr (plusFV . getGates source_fvs) inst_gates1 decls1 + in + -- Do this first slurpDecls before the getImportedInstDecls, + -- so that the home modules of all the inst_gates will be sure to be loaded + slurpDecls decls1 needed1 `thenRn` \ (decls2, needed2) -> + mapRn_ (load_home local_binders) wired_in `thenRn_` + + -- Now we can get the instance decls + getImportedInstDecls inst_gates2 `thenRn` \ inst_decls -> + rnIfaceDecls decls2 needed2 inst_decls `thenRn` \ (decls3, needed3) -> + closeDecls decls3 needed3 + where + load_home local_binders name + | name `elemNameSet` local_binders = returnRn () + -- When compiling the prelude, a wired-in thing may + -- be defined in this module, in which case we don't + -- want to load its home module! + -- Using 'isLocallyDefined' doesn't work because some of + -- the free variables returned are simply 'listTyCon_Name', + -- with a system provenance. We could look them up every time + -- but that seems a waste. + | otherwise = loadHomeInterface doc name `thenRn_` + returnRn () + where + doc = ptext SLIT("need home module for wired in thing") <+> ppr name + +------------------------------------------------------- +slurpSourceRefs :: FreeVars -- Variables referenced in source + -> RnMG ([RenamedHsDecl], + FreeVars, -- Un-satisfied needs + [Name]) -- Those variables referenced in the source + -- that turned out to be wired in things + +slurpSourceRefs source_fvs + = go [] emptyFVs [] (nameSetToList source_fvs) + where + go decls fvs wired [] + = returnRn (decls, fvs, wired) + go decls fvs wired (wanted_name:refs) + | isWiredInName wanted_name + = go decls fvs (wanted_name:wired) refs + | otherwise + = importDecl wanted_name `thenRn` \ maybe_decl -> + case maybe_decl of + -- No declaration... (already slurped, or local) + Nothing -> go decls fvs wired refs + Just decl -> rnIfaceDecl decl `thenRn` \ (new_decl, fvs1) -> + go (new_decl : decls) (fvs1 `plusFV` fvs) wired + (extraGates new_decl ++ refs) + +-- Hack alert. If we suck in a class +-- class Ord a => Baz a where ... +-- then Eq is also a 'gate'. Why? Because Eq is a superclass of Ord, +-- and hence may be needed during context reduction even though +-- Eq is never mentioned explicitly. So we snaffle out the super-classes +-- right now, so that slurpSourceRefs will heave them in +-- +-- Similarly the RHS of type synonyms +extraGates (TyClD (ClassDecl ctxt _ tvs _ _ _ _ _ _ _)) + = nameSetToList (delListFromNameSet (extractHsCtxtTyNames ctxt) (map getTyVarName tvs)) +extraGates (TyClD (TySynonym _ tvs ty _)) + = nameSetToList (delListFromNameSet (extractHsTyNames ty) (map getTyVarName tvs)) +extraGates other = [] + +------------------------------------------------------- +-- closeDecls keeps going until the free-var set is empty +closeDecls decls needed + | not (isEmptyFVs needed) + = slurpDecls decls needed `thenRn` \ (decls1, needed1) -> + closeDecls decls1 needed1 + + | otherwise + = getImportedRules `thenRn` \ rule_decls -> + case rule_decls of + [] -> returnRn decls -- No new rules, so we are done + other -> rnIfaceDecls decls emptyFVs rule_decls `thenRn` \ (decls1, needed1) -> + closeDecls decls1 needed1 + + +------------------------------------------------------- +rnIfaceDecls :: [RenamedHsDecl] -> FreeVars + -> [(Module, RdrNameHsDecl)] + -> RnM d ([RenamedHsDecl], FreeVars) +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) + + +------------------------------------------------------- +-- Augment decls with any decls needed by needed. +-- Return also free vars of the new decls (only) +slurpDecls decls needed + = go decls emptyFVs (nameSetToList needed) + where + go decls fvs [] = returnRn (decls, fvs) + go decls fvs (ref:refs) = slurpDecl decls fvs ref `thenRn` \ (decls1, fvs1) -> + go decls1 fvs1 refs + +------------------------------------------------------- +slurpDecl decls fvs wanted_name + = importDecl wanted_name `thenRn` \ maybe_decl -> + case maybe_decl of + -- No declaration... (wired in thing) + Nothing -> returnRn (decls, fvs) + + -- Found a declaration... rename it + Just decl -> rnIfaceDecl decl `thenRn` \ (new_decl, fvs1) -> + returnRn (new_decl:decls, fvs1 `plusFV` fvs) +\end{code} + + +%********************************************************* +%* * +\subsection{Extracting the 'gates'} +%* * +%********************************************************* + +When we import a declaration like + + data T = T1 Wibble | T2 Wobble - -- Next get the optional ones - closeDecls optional_mode decls1 `thenRn` \ decls2 -> +we don't want to treat Wibble and Wobble as gates *unless* T1, T2 +respectively are mentioned by the user program. If only T is mentioned +we want only T to be a gate; that way we don't suck in useless instance +decls for (say) Eq Wibble, when they can't possibly be useful. - -- Finally get those deferred data type declarations - getDeferredDataDecls `thenRn` \ data_decls -> - mapRn (rn_data_decl compulsory_mode) data_decls `thenRn` \ rn_data_decls -> +@getGates@ takes a newly imported (and renamed) decl, and the free +vars of the source program, and extracts from the decl the gate names. - -- Done - returnRn (rn_data_decls ++ decls2) +\begin{code} +getGates source_fvs (SigD (IfaceSig _ ty _ _)) + = extractHsTyNames ty +getGates source_fvs (TyClD (ClassDecl ctxt cls tvs sigs _ _ _ _ _ _)) + = delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) sigs) + (map getTyVarName tvs) + `addOneToNameSet` cls + where + get (ClassOpSig n _ ty _) + | n `elemNameSet` source_fvs = extractHsTyNames ty + | otherwise = emptyFVs + +getGates source_fvs (TyClD (TySynonym tycon tvs ty _)) + = delListFromNameSet (extractHsTyNames ty) + (map getTyVarName tvs) + `addOneToNameSet` tycon + +getGates source_fvs (TyClD (TyData _ ctxt tycon tvs cons _ _ _)) + = delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) cons) + (map getTyVarName tvs) + `addOneToNameSet` tycon where - compulsory_mode = InterfaceMode Compulsory - optional_mode = InterfaceMode Optional - - -- The "slurp_compulsories" function is a loop that alternates - -- between slurping compulsory decls and slurping the instance - -- decls thus made relavant. - -- We *must* loop again here. Why? Two reasons: - -- (a) an instance decl will give rise to an unresolved dfun, whose - -- decl we must slurp to get its version number; that's the version - -- number for the whole instance decl. (And its unfolding might mention new - -- unresolved names.) - -- (b) an instance decl might give rise to a new unresolved class, - -- whose decl we must slurp, which might let in some new instance decls, - -- and so on. Example: instance Foo a => Baz [a] where ... - slurp_compulsories decls - = closeDecls compulsory_mode decls `thenRn` \ decls1 -> + get (ConDecl n tvs ctxt details _) + | n `elemNameSet` source_fvs + -- If the constructor is method, get fvs from all its fields + = delListFromNameSet (get_details details `plusFV` + extractHsCtxtTyNames ctxt) + (map getTyVarName tvs) + get (ConDecl n tvs ctxt (RecCon fields) _) + -- Even if the constructor isn't mentioned, the fields + -- might be, as selectors. They can't mention existentially + -- bound tyvars (typechecker checks for that) so no need for + -- the deleteListFromNameSet part + = foldr (plusFV . get_field) emptyFVs fields - -- Instance decls still pending? - getImportedInstDecls `thenRn` \ inst_decls -> - if null inst_decls then - -- No, none - returnRn decls1 - else - -- Yes, there are some, so rename them and loop - traceRn (sep [ptext SLIT("Slurped"), int (length inst_decls), ptext SLIT("instance decls")]) - `thenRn_` - mapRn (rn_inst_decl compulsory_mode) inst_decls `thenRn` \ new_inst_decls -> - slurp_compulsories (new_inst_decls ++ decls1) + get other_con = emptyFVs + + get_details (VanillaCon tys) = plusFVs (map get_bang tys) + get_details (InfixCon t1 t2) = get_bang t1 `plusFV` get_bang t2 + get_details (RecCon fields) = plusFVs [get_bang t | (_, t) <- fields] + get_details (NewCon t _) = extractHsTyNames t + + get_field (fs,t) | any (`elemNameSet` source_fvs) fs = get_bang t + | otherwise = emptyFVs + + get_bang (Banged t) = extractHsTyNames t + get_bang (Unbanged t) = extractHsTyNames t + get_bang (Unpacked t) = extractHsTyNames t + +getGates source_fvs other_decl = emptyFVs \end{code} +getWiredInGates is just like getGates, but it sees a wired-in Name +rather than a declaration. + \begin{code} -closeDecls :: RnMode - -> [RenamedHsDecl] -- Declarations got so far - -> RnMG [RenamedHsDecl] -- input + extra decls slurped - -- The monad includes a list of possibly-unresolved Names - -- This list is empty when closeDecls returns - -closeDecls mode decls - = popOccurrenceName mode `thenRn` \ maybe_unresolved -> - case maybe_unresolved of - - -- No more unresolved names - Nothing -> returnRn decls - - -- An unresolved name - Just name_w_loc - -> -- Slurp its declaration, if any --- traceRn (sep [ptext SLIT("Considering"), ppr name_w_loc]) `thenRn_` - importDecl name_w_loc mode `thenRn` \ maybe_decl -> - case maybe_decl of - - -- No declaration... (wired in thing or optional) - Nothing -> closeDecls mode decls - - -- Found a declaration... rename it - Just decl -> rn_iface_decl mod_name mode decl `thenRn` \ new_decl -> - closeDecls mode (new_decl : decls) - where - mod_name = nameModule (fst name_w_loc) - -rn_iface_decl mod_name mode decl - = setModuleRn mod_name $ - initRnMS emptyRnEnv mode (rnIfaceDecl decl) - -rn_inst_decl mode (mod_name,decl) = rn_iface_decl mod_name mode (InstD decl) -rn_data_decl mode (mod_name,ty_decl) = rn_iface_decl mod_name mode (TyClD ty_decl) +getWiredInGates name | is_tycon = get_wired_tycon the_tycon + | otherwise = get_wired_id the_id + where + maybe_wired_in_tycon = maybeWiredInTyConName name + is_tycon = maybeToBool maybe_wired_in_tycon + maybe_wired_in_id = maybeWiredInIdName name + Just the_tycon = maybe_wired_in_tycon + Just the_id = maybe_wired_in_id + +get_wired_id id = namesOfType (idType id) + +get_wired_tycon tycon + | isSynTyCon tycon + = namesOfType ty `minusNameSet` mkNameSet (map getName tyvars) + + | otherwise -- data or newtype + = foldr (unionNameSets . namesOfType . dataConType) emptyNameSet data_cons + where + (tyvars,ty) = getSynTyConDefn tycon + data_cons = tyConDataCons tycon \end{code} + +%********************************************************* +%* * +\subsection{Unused names} +%* * +%********************************************************* + \begin{code} -reportUnusedNames (RnEnv gbl_env _) avail_env (ExportEnv export_avails _) mentioned_names +reportUnusedNames gbl_env avail_env (ExportEnv export_avails _) mentioned_names | not (opt_WarnUnusedBinds || opt_WarnUnusedImports) = returnRn () @@ -317,14 +478,80 @@ reportableUnusedName name startsWithUnderscore other = False -- with an underscore rnStats :: [RenamedHsDecl] -> RnMG () -rnStats all_decls - | opt_D_show_rn_trace || - opt_D_show_rn_stats || +rnStats imp_decls + | opt_D_dump_rn_trace || + opt_D_dump_rn_stats || opt_D_dump_rn - = getRnStats all_decls `thenRn` \ msg -> - ioToRnMG (printErrs msg) `thenRn_` + = getRnStats imp_decls `thenRn` \ msg -> + ioToRnM (printErrs msg) `thenRn_` returnRn () | otherwise = returnRn () \end{code} + + +%********************************************************* +%* * +\subsection{Statistics} +%* * +%********************************************************* + +\begin{code} +getRnStats :: [RenamedHsDecl] -> RnMG SDoc +getRnStats imported_decls + = getIfacesRn `thenRn` \ ifaces -> + let + n_mods = length [() | (_, _, Just _) <- eltsFM (iImpModInfo ifaces)] + + decls_read = [decl | (_, avail, True, (_,decl)) <- nameEnvElts (iDecls ifaces), + -- Data, newtype, and class decls are in the decls_fm + -- under multiple names; the tycon/class, and each + -- constructor/class op too. + -- The 'True' selects just the 'main' decl + not (isLocallyDefined (availName avail)) + ] + + (cd_rd, dd_rd, nd_rd, sd_rd, vd_rd, _) = count_decls decls_read + (cd_sp, dd_sp, nd_sp, sd_sp, vd_sp, id_sp) = count_decls imported_decls + + unslurped_insts = iInsts ifaces + inst_decls_unslurped = length (bagToList unslurped_insts) + inst_decls_read = id_sp + inst_decls_unslurped + + stats = vcat + [int n_mods <+> text "interfaces read", + hsep [ int cd_sp, text "class decls imported, out of", + int cd_rd, text "read"], + hsep [ int dd_sp, text "data decls imported, out of", + int dd_rd, text "read"], + hsep [ int nd_sp, text "newtype decls imported, out of", + int nd_rd, text "read"], + hsep [int sd_sp, text "type synonym decls imported, out of", + int sd_rd, text "read"], + hsep [int vd_sp, text "value signatures imported, out of", + int vd_rd, text "read"], + hsep [int id_sp, text "instance decls imported, out of", + int inst_decls_read, text "read"], + 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])] + in + returnRn (hcat [text "Renamer stats: ", stats]) + +count_decls decls + = (class_decls, + data_decls, + newtype_decls, + syn_decls, + val_decls, + inst_decls) + where + tycl_decls = [d | TyClD d <- decls] + (class_decls, data_decls, newtype_decls, syn_decls) = countTyClDecls tycl_decls + + val_decls = length [() | SigD _ <- decls] + inst_decls = length [() | InstD _ <- decls] +\end{code} + diff --git a/ghc/compiler/rename/RnBinds.hi-boot b/ghc/compiler/rename/RnBinds.hi-boot index 6720886..30dba74 100644 --- a/ghc/compiler/rename/RnBinds.hi-boot +++ b/ghc/compiler/rename/RnBinds.hi-boot @@ -2,4 +2,4 @@ _interface_ RnBinds 1 _exports_ RnBinds rnBinds; _declarations_ -1 rnBinds _:_ _forall_ [a b] => RdrHsSyn.RdrNameHsBinds -> (RnHsSyn.RenamedHsBinds -> RnMonad.RnMS a (b, RnEnv.FreeVars)) -> RnMonad.RnMS a (b, RnEnv.FreeVars) ;; +1 rnBinds _:_ _forall_ [b] => RdrHsSyn.RdrNameHsBinds -> (RnHsSyn.RenamedHsBinds -> RnMonad.RnMS (b, RnEnv.FreeVars)) -> RnMonad.RnMS (b, RnEnv.FreeVars) ;; diff --git a/ghc/compiler/rename/RnBinds.hi-boot-5 b/ghc/compiler/rename/RnBinds.hi-boot-5 index 4bf277f..5a3aa4d 100644 --- a/ghc/compiler/rename/RnBinds.hi-boot-5 +++ b/ghc/compiler/rename/RnBinds.hi-boot-5 @@ -1,3 +1,3 @@ __interface RnBinds 1 0 where __export RnBinds rnBinds; -1 rnBinds :: __forall [_a _b] => RdrHsSyn.RdrNameHsBinds -> (RnHsSyn.RenamedHsBinds -> RnMonad.RnMS _a (_b, RnEnv.FreeVars)) -> RnMonad.RnMS _a (_b, RnEnv.FreeVars) ; +1 rnBinds :: __forall [_b] => RdrHsSyn.RdrNameHsBinds -> (RnHsSyn.RenamedHsBinds -> RnMonad.RnMS (_b, RnEnv.FreeVars)) -> RnMonad.RnMS (_b, RnEnv.FreeVars) ; diff --git a/ghc/compiler/rename/RnBinds.lhs b/ghc/compiler/rename/RnBinds.lhs index 22e583b..b6f6d2c 100644 --- a/ghc/compiler/rename/RnBinds.lhs +++ b/ghc/compiler/rename/RnBinds.lhs @@ -26,10 +26,10 @@ import RdrHsSyn import RnHsSyn import RnMonad import RnExpr ( rnMatch, rnGRHSs, rnPat, checkPrecMatch ) -import RnEnv ( bindLocatedLocalsRn, lookupBndrRn, lookupOccRn, lookupGlobalOccRn, - isUnboundName, warnUnusedLocalBinds, - FreeVars, emptyFVs, plusFV, plusFVs, unitFV, - failUnboundNameErrRn +import RnEnv ( bindLocatedLocalsRn, lookupBndrRn, lookupGlobalOccRn, + warnUnusedLocalBinds, mapFvRn, + FreeVars, emptyFVs, plusFV, plusFVs, unitFV, addOneFV, + unknownNameErr ) import CmdLineOpts ( opt_WarnMissingSigs ) import Digraph ( stronglyConnComp, SCC(..) ) @@ -41,7 +41,7 @@ import Util ( thenCmp, removeDups ) import List ( partition ) import ListSetOps ( minusList ) import Bag ( bagToList ) -import FiniteMap ( emptyFM, addListToFM, lookupFM ) +import FiniteMap ( lookupFM, listToFM ) import Maybe ( isJust ) import Outputable \end{code} @@ -161,7 +161,7 @@ it expects the global environment to contain bindings for the binders contains bindings for the binders of this particular binding. \begin{code} -rnTopBinds :: RdrNameHsBinds -> RnMS s (RenamedHsBinds, FreeVars) +rnTopBinds :: RdrNameHsBinds -> RnMS (RenamedHsBinds, FreeVars) rnTopBinds EmptyBinds = returnRn (EmptyBinds, emptyFVs) rnTopBinds (MonoBind bind sigs _) = rnTopMonoBinds bind sigs @@ -174,23 +174,23 @@ rnTopMonoBinds EmptyMonoBinds sigs rnTopMonoBinds mbinds sigs = mapRn lookupBndrRn binder_rdr_names `thenRn` \ binder_names -> let - binder_set = mkNameSet binder_names - - binder_occ_fm = addListToFM emptyFM (map (\ x -> (nameOccName x,x)) binder_names) - - -- the names appearing in the sigs have to be bound by - -- this group's binders. - lookup_occ_rn_sig rdr_name = - case lookupFM binder_occ_fm (rdrNameOcc rdr_name) of - Nothing -> failUnboundNameErrRn rdr_name - Just x -> returnRn x + binder_set = mkNameSet binder_names + binder_occ_fm = listToFM [(nameOccName x,x) | x <- binder_names] in - renameSigs opt_WarnMissingSigs binder_set lookup_occ_rn_sig sigs - `thenRn` \ (siglist, sig_fvs) -> - rn_mono_binds siglist mbinds `thenRn` \ (final_binds, bind_fvs) -> + renameSigs opt_WarnMissingSigs binder_set + (lookupSigOccRn binder_occ_fm) sigs `thenRn` \ (siglist, sig_fvs) -> + rn_mono_binds siglist mbinds `thenRn` \ (final_binds, bind_fvs) -> returnRn (final_binds, bind_fvs `plusFV` sig_fvs) where binder_rdr_names = map fst (bagToList (collectMonoBinders mbinds)) + +-- the names appearing in the sigs have to be bound by +-- this group's binders. +lookupSigOccRn binder_occ_fm rdr_name + = case lookupFM binder_occ_fm (rdrNameOcc rdr_name) of + Nothing -> failWithRn (mkUnboundName rdr_name) + (unknownNameErr rdr_name) + Just x -> returnRn x \end{code} %************************************************************************ @@ -207,8 +207,8 @@ rnTopMonoBinds mbinds sigs \begin{code} rnBinds :: RdrNameHsBinds - -> (RenamedHsBinds -> RnMS s (result, FreeVars)) - -> RnMS s (result, FreeVars) + -> (RenamedHsBinds -> RnMS (result, FreeVars)) + -> RnMS (result, FreeVars) rnBinds EmptyBinds thing_inside = thing_inside EmptyBinds rnBinds (MonoBind bind sigs _) thing_inside = rnMonoBinds bind sigs thing_inside @@ -217,8 +217,8 @@ rnBinds (MonoBind bind sigs _) thing_inside = rnMonoBinds bind sigs thing_inside rnMonoBinds :: RdrNameMonoBinds -> [RdrNameSig] - -> (RenamedHsBinds -> RnMS s (result, FreeVars)) - -> RnMS s (result, FreeVars) + -> (RenamedHsBinds -> RnMS (result, FreeVars)) + -> RnMS (result, FreeVars) rnMonoBinds EmptyMonoBinds sigs thing_inside = thing_inside EmptyBinds @@ -238,28 +238,22 @@ rnMonoBinds mbinds sigs thing_inside -- Non-empty monobinds isJust (lookupFM binder_occ_fm (rdrNameOcc name)) forLocalBind _ = True - binder_occ_fm = addListToFM emptyFM (map (\ x -> (nameOccName x,x)) new_mbinders) + binder_occ_fm = listToFM [(nameOccName x,x) | x <- new_mbinders] - -- the names appearing in the sigs have to be bound by - -- this group's binders. - lookup_occ_rn_sig rdr_name = - case lookupFM binder_occ_fm (rdrNameOcc rdr_name) of - Nothing -> failUnboundNameErrRn rdr_name - Just x -> returnRn x in - -- -- Report the fixity declarations in this group that -- don't refer to any of the group's binders. -- mapRn_ (unknownSigErr) fixes_not_for_me `thenRn_` - renameSigs False binder_set lookup_occ_rn_sig sigs_for_me - `thenRn` \ (siglist, sig_fvs) -> + renameSigs False binder_set + (lookupSigOccRn binder_occ_fm) sigs_for_me `thenRn` \ (siglist, sig_fvs) -> let fixity_sigs = [(name,sig) | FixSig sig@(FixitySig name _ _) <- siglist ] in -- Install the fixity declarations that do apply here and go. - extendFixityEnv fixity_sigs ( - rn_mono_binds siglist mbinds ) `thenRn` \ (binds, bind_fvs) -> + extendFixityEnv fixity_sigs ( + rn_mono_binds siglist mbinds + ) `thenRn` \ (binds, bind_fvs) -> -- Now do the "thing inside", and deal with the free-variable calculations thing_inside binds `thenRn` \ (result,result_fvs) -> @@ -288,7 +282,7 @@ This is done *either* by pass 3 (for the top-level bindings), *or* by \begin{code} rn_mono_binds :: [RenamedSig] -- Signatures attached to this group -> RdrNameMonoBinds - -> RnMS s (RenamedHsBinds, -- + -> RnMS (RenamedHsBinds, -- FreeVars) -- Free variables rn_mono_binds siglist mbinds @@ -319,7 +313,7 @@ in case any of them \begin{code} flattenMonoBinds :: [RenamedSig] -- Signatures -> RdrNameMonoBinds - -> RnMS s [FlatMonoBindsInfo] + -> RnMS [FlatMonoBindsInfo] flattenMonoBinds sigs EmptyMonoBinds = returnRn [] @@ -336,12 +330,11 @@ flattenMonoBinds sigs (PatMonoBind pat grhss locn) let names_bound_here = mkNameSet (collectPatBinders pat') sigs_for_me = sigsForMe (`elemNameSet` names_bound_here) sigs - sigs_fvs = foldr sig_fv emptyFVs sigs_for_me in rnGRHSs grhss `thenRn` \ (grhss', fvs) -> returnRn [(names_bound_here, - fvs `plusFV` sigs_fvs `plusFV` pat_fvs, + fvs `plusFV` pat_fvs, PatMonoBind pat' grhss' locn, sigs_for_me )] @@ -351,13 +344,12 @@ flattenMonoBinds sigs (FunMonoBind name inf matches locn) lookupBndrRn name `thenRn` \ new_name -> let sigs_for_me = sigsForMe (new_name ==) sigs - sigs_fvs = foldr sig_fv emptyFVs sigs_for_me in - mapAndUnzipRn rnMatch matches `thenRn` \ (new_matches, fv_lists) -> + mapFvRn rnMatch matches `thenRn` \ (new_matches, fvs) -> mapRn_ (checkPrecMatch inf new_name) new_matches `thenRn_` returnRn [(unitNameSet new_name, - plusFVs fv_lists `plusFV` sigs_fvs, + fvs, FunMonoBind new_name inf new_matches locn, sigs_for_me )] @@ -368,7 +360,7 @@ flattenMonoBinds sigs (FunMonoBind name inf matches locn) declaration. like @rnMonoBinds@ but without dependency analysis. \begin{code} -rnMethodBinds :: RdrNameMonoBinds -> RnMS s (RenamedMonoBinds, FreeVars) +rnMethodBinds :: RdrNameMonoBinds -> RnMS (RenamedMonoBinds, FreeVars) rnMethodBinds EmptyMonoBinds = returnRn (EmptyMonoBinds, emptyFVs) @@ -383,13 +375,13 @@ rnMethodBinds (FunMonoBind name inf matches locn) lookupGlobalOccRn name `thenRn` \ sel_name -> -- We use the selector name as the binder - mapAndUnzipRn rnMatch matches `thenRn` \ (new_matches, fvs_s) -> + mapFvRn rnMatch matches `thenRn` \ (new_matches, fvs) -> mapRn_ (checkPrecMatch inf sel_name) new_matches `thenRn_` - returnRn (FunMonoBind sel_name inf new_matches locn, plusFVs fvs_s) + returnRn (FunMonoBind sel_name inf new_matches locn, fvs) rnMethodBinds (PatMonoBind (VarPatIn name) grhss locn) = pushSrcLocRn locn $ - lookupGlobalOccRn name `thenRn` \ sel_name -> + lookupGlobalOccRn name `thenRn` \ sel_name -> rnGRHSs grhss `thenRn` \ (grhss', fvs) -> returnRn (PatMonoBind (VarPatIn sel_name) grhss' locn, fvs) @@ -399,18 +391,6 @@ rnMethodBinds mbind@(PatMonoBind other_pat _ locn) failWithRn (EmptyMonoBinds, emptyFVs) (methodBindErr mbind) \end{code} -\begin{code} --- If a SPECIALIZE pragma is of the "... = blah" form, --- then we'd better make sure "blah" is taken into --- acct in the dependency analysis (or we get an --- unexpected out-of-scope error)! WDP 95/07 - --- This is only necessary for the dependency analysis. The free vars --- of the types in the signatures is gotten from renameSigs - -sig_fv (SpecSig _ _ (Just blah) _) acc = acc `plusFV` unitFV blah -sig_fv _ acc = acc -\end{code} %************************************************************************ %* * @@ -485,13 +465,13 @@ signatures. We'd only need this if we wanted to report unused tyvars. \begin{code} renameSigs :: Bool -- True => warn if (required) type signatures are missing. -> NameSet -- Set of names bound in this group - -> (RdrName -> RnMS s Name) + -> (RdrName -> RnMS Name) -> [RdrNameSig] - -> RnMS s ([RenamedSig], FreeVars) -- List of Sig constructors + -> RnMS ([RenamedSig], FreeVars) -- List of Sig constructors renameSigs sigs_required binders lookup_occ_nm sigs = -- Rename the signatures - mapAndUnzipRn (renameSig lookup_occ_nm) sigs `thenRn` \ (sigs', fvs_s) -> + mapFvRn (renameSig lookup_occ_nm) sigs `thenRn` \ (sigs', fvs) -> -- Check for (a) duplicate signatures -- (b) signatures for things not in this group @@ -506,7 +486,7 @@ renameSigs sigs_required binders lookup_occ_nm sigs mapRn_ dupSigDeclErr dups `thenRn_` mapRn_ unknownSigErr not_this_group `thenRn_` mapRn_ (addWarnRn.missingSigWarn) un_sigd_binders `thenRn_` - returnRn (sigs', plusFVs fvs_s) + returnRn (sigs', fvs) -- bad ones and all: -- we need bindings of *some* sort for every name @@ -523,38 +503,33 @@ renameSig lookup_occ_nm (Sig v ty src_loc) = pushSrcLocRn src_loc $ lookup_occ_nm v `thenRn` \ new_v -> rnHsSigType (quotes (ppr v)) ty `thenRn` \ (new_ty,fvs) -> - returnRn (Sig new_v new_ty src_loc, fvs) + returnRn (Sig new_v new_ty src_loc, fvs `addOneFV` new_v) renameSig _ (SpecInstSig ty src_loc) = pushSrcLocRn src_loc $ rnHsSigType (text "A SPECIALISE instance pragma") ty `thenRn` \ (new_ty, fvs) -> returnRn (SpecInstSig new_ty src_loc, fvs) -renameSig lookup_occ_nm (SpecSig v ty using src_loc) +renameSig lookup_occ_nm (SpecSig v ty src_loc) = pushSrcLocRn src_loc $ lookup_occ_nm v `thenRn` \ new_v -> - rnHsSigType (quotes (ppr v)) ty `thenRn` \ (new_ty,fvs1) -> - rn_using using `thenRn` \ (new_using,fvs2) -> - returnRn (SpecSig new_v new_ty new_using src_loc, fvs1 `plusFV` fvs2) - where - rn_using Nothing = returnRn (Nothing, emptyFVs) - rn_using (Just x) = lookupOccRn x `thenRn` \ new_x -> - returnRn (Just new_x, unitFV new_x) + rnHsSigType (quotes (ppr v)) ty `thenRn` \ (new_ty,fvs) -> + returnRn (SpecSig new_v new_ty src_loc, fvs `addOneFV` new_v) renameSig lookup_occ_nm (InlineSig v src_loc) = pushSrcLocRn src_loc $ lookup_occ_nm v `thenRn` \ new_v -> - returnRn (InlineSig new_v src_loc, emptyFVs) + returnRn (InlineSig new_v src_loc, unitFV new_v) renameSig lookup_occ_nm (FixSig (FixitySig v fix src_loc)) = pushSrcLocRn src_loc $ lookup_occ_nm v `thenRn` \ new_v -> - returnRn (FixSig (FixitySig new_v fix src_loc), emptyFVs) + returnRn (FixSig (FixitySig new_v fix src_loc), unitFV new_v) renameSig lookup_occ_nm (NoInlineSig v src_loc) = pushSrcLocRn src_loc $ lookup_occ_nm v `thenRn` \ new_v -> - returnRn (NoInlineSig new_v src_loc, emptyFVs) + returnRn (NoInlineSig new_v src_loc, unitFV new_v) \end{code} Checking for distinct signatures; oh, so boring @@ -565,9 +540,9 @@ cmp_sig (Sig n1 _ _) (Sig n2 _ _) = n1 `compare` n2 cmp_sig (InlineSig n1 _) (InlineSig n2 _) = n1 `compare` n2 cmp_sig (NoInlineSig n1 _) (NoInlineSig n2 _) = n1 `compare` n2 cmp_sig (SpecInstSig ty1 _) (SpecInstSig ty2 _) = cmpHsType compare ty1 ty2 -cmp_sig (SpecSig n1 ty1 _ _) (SpecSig n2 ty2 _ _) +cmp_sig (SpecSig n1 ty1 _) (SpecSig n2 ty2 _) = -- may have many specialisations for one value; - -- but not ones that are exactly the same... + -- but not ones that are exactly the same... thenCmp (n1 `compare` n2) (cmpHsType compare ty1 ty2) cmp_sig other_1 other_2 -- Tags *must* be different @@ -575,7 +550,7 @@ cmp_sig other_1 other_2 -- Tags *must* be different | otherwise = GT sig_tag (Sig n1 _ _) = (ILIT(1) :: FAST_INT) -sig_tag (SpecSig n1 _ _ _) = ILIT(2) +sig_tag (SpecSig n1 _ _) = ILIT(2) sig_tag (InlineSig n1 _) = ILIT(3) sig_tag (NoInlineSig n1 _) = ILIT(4) sig_tag (SpecInstSig _ _) = ILIT(5) @@ -592,8 +567,7 @@ sig_tag _ = panic# "tag(RnBinds)" \begin{code} dupSigDeclErr (sig:sigs) = pushSrcLocRn loc $ - addErrRn (sep [ptext SLIT("Duplicate"), - ptext what_it_is <> colon, + addErrRn (sep [ptext SLIT("Duplicate") <+> ptext what_it_is <> colon, ppr sig]) where (what_it_is, loc) = sig_doc sig @@ -608,7 +582,7 @@ unknownSigErr sig sig_doc (Sig _ _ loc) = (SLIT("type signature"),loc) sig_doc (ClassOpSig _ _ _ loc) = (SLIT("class-method type signature"), loc) -sig_doc (SpecSig _ _ _ loc) = (SLIT("SPECIALISE pragma"),loc) +sig_doc (SpecSig _ _ loc) = (SLIT("SPECIALISE pragma"),loc) sig_doc (InlineSig _ loc) = (SLIT("INLINE pragma"),loc) sig_doc (NoInlineSig _ loc) = (SLIT("NOINLINE pragma"),loc) sig_doc (SpecInstSig _ loc) = (SLIT("SPECIALISE instance pragma"),loc) diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index 7d0584e..be76422 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -12,14 +12,17 @@ import CmdLineOpts ( opt_WarnNameShadowing, opt_WarnUnusedMatches, opt_WarnUnusedBinds, opt_WarnUnusedImports ) import HsSyn import RdrHsSyn ( RdrNameIE ) -import RdrName ( RdrName, rdrNameModule, rdrNameOcc, isQual, mkRdrUnqual, qualifyRdrName ) +import RnHsSyn ( RenamedHsType ) +import RdrName ( RdrName, rdrNameModule, rdrNameOcc, isQual, isUnqual, + mkRdrUnqual, qualifyRdrName + ) import HsTypes ( getTyVarName, replaceTyVarName ) -import BasicTypes ( Fixity(..), FixityDirection(..) ) + import RnMonad import Name ( Name, Provenance(..), ExportFlag(..), NamedThing(..), ImportReason(..), getSrcLoc, - mkLocalName, mkGlobalName, isSystemName, - nameOccName, nameModule, setNameModule, + mkLocalName, mkImportedLocalName, mkGlobalName, isSystemName, + nameOccName, setNameModule, pprOccName, isLocallyDefined, nameUnique, nameOccName, setNameProvenance, getNameProvenance, pprNameProvenance ) @@ -28,10 +31,12 @@ import OccName ( OccName, mkDFunOcc, occNameFlavour ) -import Module ( moduleIfaceFlavour ) +import TysWiredIn ( tupleTyCon, unboxedTupleTyCon, listTyCon ) +import Type ( funTyCon ) +import Module ( ModuleName, mkThisModule, mkVanillaModule, moduleName ) import TyCon ( TyCon ) import FiniteMap -import Unique ( Unique, Uniquable(..), unboundKey ) +import Unique ( Unique, Uniquable(..) ) import UniqFM ( emptyUFM, listToUFM, plusUFM_C ) import UniqSupply import SrcLoc ( SrcLoc, noSrcLoc ) @@ -50,24 +55,28 @@ import Maybes ( mapMaybe ) %********************************************************* \begin{code} -newImportedGlobalName :: Module -> OccName -> RnM s d Name -newImportedGlobalName mod occ - = -- First check the cache +newImportedBinder :: Module -> RdrName -> RnM d Name +-- Make a new imported binder. It might be in the cache already, +-- but if so it will have a dopey provenance, so replace it. +newImportedBinder mod rdr_name + = ASSERT2( isUnqual rdr_name, ppr rdr_name ) + + -- First check the cache getNameSupplyRn `thenRn` \ (us, inst_ns, cache) -> let - key = (mod,occ) + occ = rdrNameOcc rdr_name + key = (moduleName mod, occ) in case lookupFM cache key of -- A hit in the cache! - -- Make sure that the module in the name has the same IfaceFlavour as - -- the module we are looking for; if not, make it so - -- so that it has the right HiFlag component. - -- (This is necessary for known-key things. + -- Overwrite the thing in the cache with a Name whose Module and Provenance + -- is correct. It might be in the cache arising from an *occurrence*, + -- whereas we are now at the binding site. + -- Similarly for known-key things. -- For example, GHCmain.lhs imports as SOURCE - -- Main; but Main.main is a known-key thing.) - Just name | isSystemName name -- A known-key name; fix the provenance and module - -> getOmitQualFn `thenRn` \ omit_fn -> + -- Main; but Main.main is a known-key thing. + Just name -> getOmitQualFn `thenRn` \ omit_fn -> let new_name = setNameProvenance (setNameModule name mod) (NonLocalDef ImplicitImport (omit_fn name)) @@ -76,17 +85,13 @@ newImportedGlobalName mod occ setNameSupplyRn (us, inst_ns, new_cache) `thenRn_` returnRn new_name - | otherwise - -> returnRn name - Nothing -> -- Miss in the cache! -- Build a new original name, and put it in the cache getOmitQualFn `thenRn` \ omit_fn -> - setModuleFlavourRn mod `thenRn` \ mod' -> let (us', us1) = splitUniqSupply us uniq = uniqFromSupply us1 - name = mkGlobalName uniq mod' occ (NonLocalDef ImplicitImport (omit_fn name)) + name = mkGlobalName uniq mod occ (NonLocalDef ImplicitImport (omit_fn name)) -- For in-scope things we improve the provenance -- in RnNames.importsFromImportDecl new_cache = addToFM cache key name @@ -95,26 +100,44 @@ newImportedGlobalName mod occ returnRn name -newImportedGlobalFromRdrName rdr_name +-- Make an imported global name, checking first to see if it's in the cache +mkImportedGlobalName :: ModuleName -> OccName -> RnM d Name +mkImportedGlobalName mod_name occ + = getNameSupplyRn `thenRn` \ (us, inst_ns, cache) -> + let + key = (mod_name, occ) + in + case lookupFM cache key of + Just name -> returnRn name + Nothing -> setNameSupplyRn (us', inst_ns, new_cache) `thenRn_` + returnRn name + where + (us', us1) = splitUniqSupply us + uniq = uniqFromSupply us1 + name = mkGlobalName uniq (mkVanillaModule mod_name) occ + (NonLocalDef ImplicitImport False) + new_cache = addToFM cache key name + +mkImportedGlobalFromRdrName rdr_name | isQual rdr_name - = newImportedGlobalName (rdrNameModule rdr_name) (rdrNameOcc rdr_name) + = mkImportedGlobalName (rdrNameModule rdr_name) (rdrNameOcc rdr_name) | otherwise = -- An Unqual is allowed; interface files contain -- unqualified names for locally-defined things, such as -- constructors of a data type. - getModuleRn `thenRn ` \ mod_name -> - newImportedGlobalName mod_name (rdrNameOcc rdr_name) + getModuleRn `thenRn ` \ mod_name -> + mkImportedGlobalName mod_name (rdrNameOcc rdr_name) -newLocallyDefinedGlobalName :: Module -> OccName - -> (Name -> ExportFlag) -> SrcLoc - -> RnM s d Name -newLocallyDefinedGlobalName mod occ rec_exp_fn loc +newLocalTopBinder :: Module -> OccName + -> (Name -> ExportFlag) -> SrcLoc + -> RnM d Name +newLocalTopBinder mod occ rec_exp_fn loc = -- First check the cache getNameSupplyRn `thenRn` \ (us, inst_ns, cache) -> let - key = (mod,occ) + key = (moduleName mod,occ) mk_prov name = LocalDef loc (rec_exp_fn name) -- We must set the provenance of the thing in the cache -- correctly, particularly whether or not it is locally defined. @@ -149,49 +172,58 @@ newLocallyDefinedGlobalName mod occ rec_exp_fn loc in setNameSupplyRn (us', inst_ns, new_cache) `thenRn_` returnRn new_name +\end{code} +%********************************************************* +%* * +\subsection{Dfuns and default methods +%* * +%********************************************************* -newLocalNames :: [(RdrName,SrcLoc)] -> RnM s d [Name] -newLocalNames rdr_names - = getNameSupplyRn `thenRn` \ (us, inst_ns, cache) -> - let - n = length rdr_names - (us', us1) = splitUniqSupply us - uniqs = uniqsFromSupply n us1 - locals = [ mkLocalName uniq (rdrNameOcc rdr_name) loc - | ((rdr_name,loc), uniq) <- rdr_names `zip` uniqs - ] - in - setNameSupplyRn (us', inst_ns, cache) `thenRn_` - returnRn locals - -newDFunName cl_occ tycon_occ (Just n) src_loc -- Imported ones have "Just n" - = newImportedGlobalFromRdrName n +@newImplicitBinder@ is used for (a) dfuns (b) default methods, defined in this module -newDFunName cl_occ tycon_occ Nothing src_loc -- Local instance decls have a "Nothing" +\begin{code} +newImplicitBinder occ src_loc = getModuleRn `thenRn` \ mod_name -> - newInstUniq (cl_occ, tycon_occ) `thenRn` \ inst_uniq -> - let - dfun_occ = mkDFunOcc cl_occ tycon_occ inst_uniq - in - newLocallyDefinedGlobalName mod_name dfun_occ (\_ -> Exported) src_loc + newLocalTopBinder (mkThisModule mod_name) occ (\_ -> Exported) src_loc +\end{code} +Make a name for the dict fun for an instance decl --- mkUnboundName makes a place-holder Name; it shouldn't be looked at except possibly --- during compiler debugging. -mkUnboundName :: RdrName -> Name -mkUnboundName rdr_name = mkLocalName unboundKey (rdrNameOcc rdr_name) noSrcLoc +\begin{code} +newDFunName :: (OccName, OccName) -> SrcLoc -> RnMS Name +newDFunName key@(cl_occ, tycon_occ) loc + = newInstUniq key `thenRn` \ inst_uniq -> + newImplicitBinder (mkDFunOcc cl_occ tycon_occ inst_uniq) loc +\end{code} -isUnboundName :: Name -> Bool -isUnboundName name = getUnique name == unboundKey +\begin{code} +getDFunKey :: RenamedHsType -> (OccName, OccName) -- Used to manufacture DFun names +getDFunKey (HsForAllTy _ _ ty) = getDFunKey ty +getDFunKey (MonoFunTy _ ty) = getDFunKey ty +getDFunKey (MonoDictTy cls (ty:_)) = (nameOccName cls, get_tycon_key ty) + +get_tycon_key (MonoTyVar tv) = nameOccName (getName tv) +get_tycon_key (MonoTyApp ty _) = get_tycon_key ty +get_tycon_key (MonoTupleTy tys True) = getOccName (tupleTyCon (length tys)) +get_tycon_key (MonoTupleTy tys False) = getOccName (unboxedTupleTyCon (length tys)) +get_tycon_key (MonoListTy _) = getOccName listTyCon +get_tycon_key (MonoFunTy _ _) = getOccName funTyCon \end{code} + +%********************************************************* +%* * +\subsection{Binding} +%* * +%********************************************************* + \begin{code} ------------------------------------- bindLocatedLocalsRn :: SDoc -- Documentation string for error message -> [(RdrName,SrcLoc)] - -> ([Name] -> RnMS s a) - -> RnMS s a + -> ([Name] -> RnMS a) + -> RnMS a bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope = checkDupOrQualNames doc_str rdr_names_w_loc `thenRn_` @@ -203,11 +235,28 @@ bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope returnRn () ) `thenRn_` - newLocalNames rdr_names_w_loc `thenRn` \ names -> + getNameSupplyRn `thenRn` \ (us, inst_ns, cache) -> + getModeRn `thenRn` \ mode -> + let + n = length rdr_names_w_loc + (us', us1) = splitUniqSupply us + uniqs = uniqsFromSupply n us1 + names = [ mk_name uniq (rdrNameOcc rdr_name) loc + | ((rdr_name,loc), uniq) <- rdr_names_w_loc `zip` uniqs + ] + mk_name = case mode of + SourceMode -> mkLocalName + InterfaceMode -> mkImportedLocalName + -- Keep track of whether the name originally came from + -- an interface file. + in + setNameSupplyRn (us', inst_ns, cache) `thenRn_` + let new_name_env = addListToRdrEnv name_env (map fst rdr_names_w_loc `zip` names) in setLocalNameEnv new_name_env (enclosed_scope names) + where check_shadow name_env (rdr_name,loc) = case lookupRdrEnv name_env rdr_name of @@ -215,23 +264,57 @@ bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope Just name -> pushSrcLocRn loc $ addWarnRn (shadowedNameWarn rdr_name) +bindCoreLocalFVRn :: RdrName -> (Name -> RnMS (a, FreeVars)) + -> RnMS (a, FreeVars) + -- A specialised variant when renaming stuff from interface + -- files (of which there is a lot) + -- * one at a time + -- * no checks for shadowing + -- * always imported + -- * deal with free vars +bindCoreLocalFVRn rdr_name enclosed_scope + = getSrcLocRn `thenRn` \ loc -> + getLocalNameEnv `thenRn` \ name_env -> + getNameSupplyRn `thenRn` \ (us, inst_ns, cache) -> + let + (us', us1) = splitUniqSupply us + uniq = uniqFromSupply us1 + name = mkImportedLocalName uniq (rdrNameOcc rdr_name) loc + in + setNameSupplyRn (us', inst_ns, cache) `thenRn_` + let + new_name_env = extendRdrEnv name_env rdr_name name + in + setLocalNameEnv new_name_env (enclosed_scope name) `thenRn` \ (result, fvs) -> + returnRn (result, delFromNameSet fvs name) + +bindCoreLocalsFVRn [] thing_inside = thing_inside [] +bindCoreLocalsFVRn (b:bs) thing_inside = bindCoreLocalFVRn b $ \ name' -> + bindCoreLocalsFVRn bs $ \ names' -> + thing_inside (name':names') ------------------------------------- -bindLocalsRn doc_str rdr_names enclosed_scope +bindLocalRn doc rdr_name enclosed_scope + = getSrcLocRn `thenRn` \ loc -> + bindLocatedLocalsRn doc [(rdr_name,loc)] $ \ (n:ns) -> + ASSERT( null ns ) + enclosed_scope n + +bindLocalsRn doc rdr_names enclosed_scope = getSrcLocRn `thenRn` \ loc -> - bindLocatedLocalsRn (text doc_str) + bindLocatedLocalsRn doc (rdr_names `zip` repeat loc) enclosed_scope -- binLocalsFVRn is the same as bindLocalsRn -- except that it deals with free vars -bindLocalsFVRn doc_str rdr_names enclosed_scope - = bindLocalsRn doc_str rdr_names $ \ names -> +bindLocalsFVRn doc rdr_names enclosed_scope + = bindLocalsRn doc rdr_names $ \ names -> enclosed_scope names `thenRn` \ (thing, fvs) -> returnRn (thing, delListFromNameSet fvs names) ------------------------------------- -extendTyVarEnvFVRn :: [HsTyVar Name] -> RnMS s (a, FreeVars) -> RnMS s (a, FreeVars) +extendTyVarEnvFVRn :: [HsTyVar Name] -> RnMS (a, FreeVars) -> RnMS (a, FreeVars) -- This tiresome function is used only in rnDecl on InstDecl extendTyVarEnvFVRn tyvars enclosed_scope = getLocalNameEnv `thenRn` \ env -> @@ -245,16 +328,16 @@ extendTyVarEnvFVRn tyvars enclosed_scope returnRn (thing, delListFromNameSet fvs tyvar_names) bindTyVarsRn :: SDoc -> [HsTyVar RdrName] - -> ([HsTyVar Name] -> RnMS s a) - -> RnMS s a + -> ([HsTyVar Name] -> RnMS a) + -> RnMS a bindTyVarsRn doc_str tyvar_names enclosed_scope = bindTyVars2Rn doc_str tyvar_names $ \ names tyvars -> enclosed_scope tyvars -- Gruesome name: return Names as well as HsTyVars bindTyVars2Rn :: SDoc -> [HsTyVar RdrName] - -> ([Name] -> [HsTyVar Name] -> RnMS s a) - -> RnMS s a + -> ([Name] -> [HsTyVar Name] -> RnMS a) + -> RnMS a bindTyVars2Rn doc_str tyvar_names enclosed_scope = getSrcLocRn `thenRn` \ loc -> let @@ -264,16 +347,16 @@ bindTyVars2Rn doc_str tyvar_names enclosed_scope enclosed_scope names (zipWith replaceTyVarName tyvar_names names) bindTyVarsFVRn :: SDoc -> [HsTyVar RdrName] - -> ([HsTyVar Name] -> RnMS s (a, FreeVars)) - -> RnMS s (a, FreeVars) + -> ([HsTyVar Name] -> RnMS (a, FreeVars)) + -> RnMS (a, FreeVars) bindTyVarsFVRn doc_str rdr_names enclosed_scope = bindTyVars2Rn doc_str rdr_names $ \ names tyvars -> enclosed_scope tyvars `thenRn` \ (thing, fvs) -> returnRn (thing, delListFromNameSet fvs names) bindTyVarsFV2Rn :: SDoc -> [HsTyVar RdrName] - -> ([Name] -> [HsTyVar Name] -> RnMS s (a, FreeVars)) - -> RnMS s (a, FreeVars) + -> ([Name] -> [HsTyVar Name] -> RnMS (a, FreeVars)) + -> RnMS (a, FreeVars) bindTyVarsFV2Rn doc_str rdr_names enclosed_scope = bindTyVars2Rn doc_str rdr_names $ \ names tyvars -> enclosed_scope names tyvars `thenRn` \ (thing, fvs) -> @@ -283,7 +366,7 @@ bindTyVarsFV2Rn doc_str rdr_names enclosed_scope ------------------------------------- checkDupOrQualNames, checkDupNames :: SDoc -> [(RdrName, SrcLoc)] - -> RnM s d () + -> RnM d () -- Works in any variant of the renamer monad checkDupOrQualNames doc_str rdr_names_w_loc @@ -320,10 +403,10 @@ lookupBndrRn rdr_name getModeRn `thenRn` \ mode -> case mode of - InterfaceMode _ -> -- Look in the global name cache - newImportedGlobalFromRdrName rdr_name + InterfaceMode -> -- Look in the global name cache + mkImportedGlobalFromRdrName rdr_name - SourceMode -> -- Source mode, so look up a *qualified* version + SourceMode -> -- Source mode, so look up a *qualified* version -- of the name, so that we get the right one even -- if there are many with the same occ name -- There must *be* a binding @@ -338,21 +421,19 @@ lookupBndrRn rdr_name -- Perhaps surprisingly, even wired-in names are recorded. -- Why? So that we know which wired-in names are referred to when -- deciding which instance declarations to import. -lookupOccRn :: RdrName -> RnMS s Name +lookupOccRn :: RdrName -> RnMS Name lookupOccRn rdr_name = getNameEnvs `thenRn` \ (global_env, local_env) -> - lookup_occ global_env local_env rdr_name `thenRn` \ name -> - addOccurrenceName name + lookup_occ global_env local_env rdr_name -- lookupGlobalOccRn is like lookupOccRn, except that it looks in the global -- environment. It's used only for -- record field names -- class op names in class and instance decls -lookupGlobalOccRn :: RdrName -> RnMS s Name +lookupGlobalOccRn :: RdrName -> RnMS Name lookupGlobalOccRn rdr_name = getNameEnvs `thenRn` \ (global_env, local_env) -> - lookup_global_occ global_env rdr_name `thenRn` \ name -> - addOccurrenceName name + lookup_global_occ global_env rdr_name -- Look in both local and global env lookup_occ global_env local_env rdr_name @@ -369,11 +450,12 @@ lookup_global_occ global_env rdr_name Nothing -> getModeRn `thenRn` \ mode -> case mode of -- Not found when processing source code; so fail - SourceMode -> failUnboundNameErrRn rdr_name + SourceMode -> failWithRn (mkUnboundName rdr_name) + (unknownNameErr rdr_name) -- Not found when processing an imported declaration, -- so we create a new name for the purpose - InterfaceMode _ -> newImportedGlobalFromRdrName rdr_name + InterfaceMode -> mkImportedGlobalFromRdrName rdr_name -- lookupImplicitOccRn takes an RdrName representing an *original* name, and @@ -393,25 +475,8 @@ lookup_global_occ global_env rdr_name -- whether there are any instance decls in this module are "special". -- The name cache should have the correct provenance, though. -lookupImplicitOccRn :: RdrName -> RnMS s Name -lookupImplicitOccRn rdr_name - = newImportedGlobalFromRdrName rdr_name `thenRn` \ name -> - addOccurrenceName name - -addImplicitOccRn :: Name -> RnMS s Name -addImplicitOccRn name = addOccurrenceName name - -addImplicitOccsRn :: [Name] -> RnMS s () -addImplicitOccsRn names = addOccurrenceNames names -\end{code} - -\begin{code} -lookupFixity :: Name -> RnMS s Fixity -lookupFixity name - = getFixityEnv `thenRn` \ fixity_env -> - case lookupNameEnv fixity_env name of - Just (FixitySig _ fixity _) -> returnRn fixity - Nothing -> returnRn (Fixity 9 InfixL) -- Default case +lookupImplicitOccRn :: RdrName -> RnMS Name +lookupImplicitOccRn rdr_name = mkImportedGlobalFromRdrName rdr_name \end{code} unQualInScope returns a function that takes a Name and tells whether @@ -435,14 +500,6 @@ unQualInScope env %* * %************************************************************************ -=============== RnEnv ================ -\begin{code} -plusRnEnv (RnEnv n1 f1) (RnEnv n2 f2) - = RnEnv (n1 `plusGlobalRdrEnv` n2) - (f1 `plusNameEnv` f2) -\end{code} - - =============== NameEnv ================ \begin{code} plusGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrEnv -> GlobalRdrEnv @@ -497,10 +554,10 @@ is_duplicate n1 n2 | isLocallyDefined n1 && isLocallyDefined n2 = False =============== ExportAvails ================ \begin{code} -mkEmptyExportAvails :: Module -> ExportAvails +mkEmptyExportAvails :: ModuleName -> ExportAvails mkEmptyExportAvails mod_name = (unitFM mod_name [], emptyUFM) -mkExportAvails :: Module -> Bool -> GlobalRdrEnv -> [AvailInfo] -> ExportAvails +mkExportAvails :: ModuleName -> Bool -> GlobalRdrEnv -> [AvailInfo] -> ExportAvails mkExportAvails mod_name unqual_imp name_env avails = (mod_avail_env, entity_avail_env) where @@ -623,13 +680,21 @@ unitFV :: Name -> FreeVars emptyFVs :: FreeVars plusFVs :: [FreeVars] -> FreeVars -emptyFVs = emptyNameSet -plusFVs = unionManyNameSets -plusFV = unionNameSets +isEmptyFVs = isEmptyNameSet +emptyFVs = emptyNameSet +plusFVs = unionManyNameSets +plusFV = unionNameSets -- No point in adding implicitly imported names to the free-var set addOneFV s n = addOneToNameSet s n unitFV n = unitNameSet n + +-- A useful utility +mapFvRn f xs = mapRn f xs `thenRn` \ stuff -> + let + (ys, fvs_s) = unzip stuff + in + returnRn (ys, plusFVs fvs_s) \end{code} @@ -641,7 +706,7 @@ unitFV n = unitNameSet n \begin{code} -warnUnusedLocalBinds, warnUnusedTopNames, warnUnusedMatches :: [Name] -> RnM s d () +warnUnusedLocalBinds, warnUnusedTopNames, warnUnusedMatches :: [Name] -> RnM d () warnUnusedTopNames names | not opt_WarnUnusedBinds && not opt_WarnUnusedImports = returnRn () -- Don't force ns unless necessary @@ -657,7 +722,7 @@ warnUnusedMatches names ------------------------- -warnUnusedBinds :: (Bool -> Bool) -> [Name] -> RnM s d () +warnUnusedBinds :: (Bool -> Bool) -> [Name] -> RnM d () warnUnusedBinds warn_when_local names = mapRn_ (warnUnusedGroup warn_when_local) groups where @@ -674,7 +739,7 @@ warnUnusedBinds warn_when_local names ------------------------- -warnUnusedGroup :: (Bool -> Bool) -> [Name] -> RnM s d () +warnUnusedGroup :: (Bool -> Bool) -> [Name] -> RnM d () warnUnusedGroup _ [] = returnRn () @@ -708,11 +773,6 @@ fixityClashErr (rdr_name, ((_,how_in_scope1), (_, how_in_scope2))) 4 (vcat [ppr how_in_scope1, ppr how_in_scope2]) -failUnboundNameErrRn :: RdrName -> RnM s d Name -failUnboundNameErrRn rdr_name = - failWithRn (mkUnboundName rdr_name) - (unknownNameErr rdr_name) - shadowedNameWarn shadow = hsep [ptext SLIT("This binding for"), quotes (ppr shadow), diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index 1c4914e..e483327 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/ghc/compiler/rename/RnExpr.lhs @@ -11,7 +11,7 @@ free variables. \begin{code} module RnExpr ( - rnMatch, rnGRHSs, rnPat, + rnMatch, rnGRHSs, rnPat, rnExpr, rnExprs, checkPrecMatch ) where @@ -25,8 +25,9 @@ import RdrHsSyn import RnHsSyn import RnMonad import RnEnv +import RnIfaces ( lookupFixity ) import CmdLineOpts ( opt_GlasgowExts, opt_IgnoreAsserts ) -import BasicTypes ( Fixity(..), FixityDirection(..) ) +import BasicTypes ( Fixity(..), FixityDirection(..), defaultFixity ) import PrelInfo ( numClass_RDR, fractionalClass_RDR, eqClass_RDR, ccallableClass_RDR, creturnableClass_RDR, monadClass_RDR, enumClass_RDR, ordClass_RDR, @@ -58,7 +59,7 @@ import Outputable ********************************************************* \begin{code} -rnPat :: RdrNamePat -> RnMS s (RenamedPat, FreeVars) +rnPat :: RdrNamePat -> RnMS (RenamedPat, FreeVars) rnPat WildPatIn = returnRn (WildPatIn, emptyFVs) @@ -79,9 +80,9 @@ rnPat (SigPatIn pat ty) doc = text "a pattern type-signature" rnPat (LitPatIn lit) - = litOccurrence lit `thenRn_` - lookupImplicitOccRn eqClass_RDR `thenRn_` -- Needed to find equality on pattern - returnRn (LitPatIn lit, emptyFVs) + = litOccurrence lit `thenRn` \ fvs1 -> + lookupImplicitOccRn eqClass_RDR `thenRn` \ eq -> -- Needed to find equality on pattern + returnRn (LitPatIn lit, fvs1 `addOneFV` eq) rnPat (LazyPatIn pat) = rnPat pat `thenRn` \ (pat', fvs) -> @@ -94,15 +95,21 @@ rnPat (AsPatIn name pat) rnPat (ConPatIn con pats) = lookupOccRn con `thenRn` \ con' -> - mapAndUnzipRn rnPat pats `thenRn` \ (patslist, fvs_s) -> - returnRn (ConPatIn con' patslist, plusFVs fvs_s `addOneFV` con') + mapFvRn rnPat pats `thenRn` \ (patslist, fvs) -> + returnRn (ConPatIn con' patslist, fvs `addOneFV` con') rnPat (ConOpPatIn pat1 con _ pat2) = rnPat pat1 `thenRn` \ (pat1', fvs1) -> lookupOccRn con `thenRn` \ con' -> - lookupFixity con' `thenRn` \ fixity -> rnPat pat2 `thenRn` \ (pat2', fvs2) -> - mkConOpPatRn pat1' con' fixity pat2' `thenRn` \ pat' -> + + getModeRn `thenRn` \ mode -> + -- See comments with rnExpr (OpApp ...) + (case mode of + InterfaceMode -> returnRn (ConOpPatIn pat1' con' defaultFixity pat2') + SourceMode -> lookupFixity con' `thenRn` \ fixity -> + mkConOpPatRn pat1' con' fixity pat2' + ) `thenRn` \ pat' -> returnRn (pat', fvs1 `plusFV` fvs2 `addOneFV` con') -- Negated patters can only be literals, and they are dealt with @@ -124,20 +131,20 @@ rnPat (ParPatIn pat) returnRn (ParPatIn pat', fvs) rnPat (NPlusKPatIn name lit) - = litOccurrence lit `thenRn_` - lookupImplicitOccRn ordClass_RDR `thenRn_` + = litOccurrence lit `thenRn` \ fvs -> + lookupImplicitOccRn ordClass_RDR `thenRn` \ ord -> lookupBndrRn name `thenRn` \ name' -> - returnRn (NPlusKPatIn name' lit, emptyFVs) + returnRn (NPlusKPatIn name' lit, fvs `addOneFV` ord) rnPat (ListPatIn pats) - = addImplicitOccRn listTyCon_name `thenRn_` - mapAndUnzipRn rnPat pats `thenRn` \ (patslist, fvs_s) -> - returnRn (ListPatIn patslist, plusFVs fvs_s) + = mapFvRn rnPat pats `thenRn` \ (patslist, fvs) -> + returnRn (ListPatIn patslist, fvs `addOneFV` listTyCon_name) rnPat (TuplePatIn pats boxed) - = addImplicitOccRn (tupleTyCon_name boxed (length pats)) `thenRn_` - mapAndUnzipRn rnPat pats `thenRn` \ (patslist, fvs_s) -> - returnRn (TuplePatIn patslist boxed, plusFVs fvs_s) + = mapFvRn rnPat pats `thenRn` \ (patslist, fvs) -> + returnRn (TuplePatIn patslist boxed, fvs `addOneFV` tycon_name) + where + tycon_name = tupleTyCon_name boxed (length pats) rnPat (RecPatIn con rpats) = lookupOccRn con `thenRn` \ con' -> @@ -152,7 +159,7 @@ rnPat (RecPatIn con rpats) ************************************************************************ \begin{code} -rnMatch :: RdrNameMatch -> RnMS s (RenamedMatch, FreeVars) +rnMatch :: RdrNameMatch -> RnMS (RenamedMatch, FreeVars) rnMatch match@(Match _ pats maybe_rhs_sig grhss) = pushSrcLocRn (getMatchLoc match) $ @@ -164,7 +171,7 @@ rnMatch match@(Match _ pats maybe_rhs_sig grhss) tyvars_in_sigs = rhs_sig_tyvars `unionLists` tyvars_in_pats rhs_sig_tyvars = case maybe_rhs_sig of Nothing -> [] - Just ty -> extractHsTyVars ty + Just ty -> extractHsTyRdrNames ty tyvars_in_pats = extractPatsTyVars pats forall_tyvars = filter (not . (`elemFM` name_env)) tyvars_in_sigs doc = text "a pattern type-signature" @@ -174,9 +181,9 @@ rnMatch match@(Match _ pats maybe_rhs_sig grhss) -- Note that we do a single bindLocalsRn for all the -- matches together, so that we spot the repeated variable in -- f x x = 1 - bindLocalsFVRn "a pattern" (collectPatsBinders pats) $ \ new_binders -> + bindLocalsFVRn doc (collectPatsBinders pats) $ \ new_binders -> - mapAndUnzipRn rnPat pats `thenRn` \ (pats', pat_fvs_s) -> + mapFvRn rnPat pats `thenRn` \ (pats', pat_fvs) -> rnGRHSs grhss `thenRn` \ (grhss', grhss_fvs) -> (case maybe_rhs_sig of Nothing -> returnRn (Nothing, emptyFVs) @@ -189,7 +196,7 @@ rnMatch match@(Match _ pats maybe_rhs_sig grhss) let binder_set = mkNameSet new_binders unused_binders = nameSetToList (binder_set `minusNameSet` grhss_fvs) - all_fvs = grhss_fvs `plusFV` plusFVs pat_fvs_s `plusFV` ty_fvs + all_fvs = grhss_fvs `plusFV` pat_fvs `plusFV` ty_fvs in warnUnusedMatches unused_binders `thenRn_` @@ -204,13 +211,13 @@ rnMatch match@(Match _ pats maybe_rhs_sig grhss) %************************************************************************ \begin{code} -rnGRHSs :: RdrNameGRHSs -> RnMS s (RenamedGRHSs, FreeVars) +rnGRHSs :: RdrNameGRHSs -> RnMS (RenamedGRHSs, FreeVars) rnGRHSs (GRHSs grhss binds maybe_ty) = ASSERT( not (maybeToBool maybe_ty) ) rnBinds binds $ \ binds' -> - mapAndUnzipRn rnGRHS grhss `thenRn` \ (grhss', fvGRHSs) -> - returnRn (GRHSs grhss' binds' Nothing, plusFVs fvGRHSs) + mapFvRn rnGRHS grhss `thenRn` \ (grhss', fvGRHSs) -> + returnRn (GRHSs grhss' binds' Nothing, fvGRHSs) rnGRHS (GRHS guarded locn) = pushSrcLocRn locn $ @@ -238,7 +245,7 @@ rnGRHS (GRHS guarded locn) %************************************************************************ \begin{code} -rnExprs :: [RdrNameHsExpr] -> RnMS s ([RenamedHsExpr], FreeVars) +rnExprs :: [RdrNameHsExpr] -> RnMS ([RenamedHsExpr], FreeVars) rnExprs ls = rnExprs' ls emptyUniqSet where rnExprs' [] acc = returnRn ([], acc) @@ -261,21 +268,20 @@ grubby_seqNameSet ns result | isNullUFM ns = result Variables. We look up the variable and return the resulting name. \begin{code} -rnExpr :: RdrNameHsExpr -> RnMS s (RenamedHsExpr, FreeVars) +rnExpr :: RdrNameHsExpr -> RnMS (RenamedHsExpr, FreeVars) rnExpr (HsVar v) = lookupOccRn v `thenRn` \ name -> if nameUnique name == assertIdKey then -- We expand it to (GHCerr.assert__ location) - mkAssertExpr `thenRn` \ expr -> - returnRn (expr, emptyUniqSet) + mkAssertExpr else -- The normal case returnRn (HsVar name, unitFV name) rnExpr (HsLit lit) - = litOccurrence lit `thenRn_` - returnRn (HsLit lit, emptyFVs) + = litOccurrence lit `thenRn` \ fvs -> + returnRn (HsLit lit, fvs) rnExpr (HsLam match) = rnMatch match `thenRn` \ (match', fvMatch) -> @@ -295,11 +301,12 @@ rnExpr (OpApp e1 op _ e2) -- When renaming code synthesised from "deriving" declarations -- we're in Interface mode, and we should ignore fixity; assume -- that the deriving code generator got the association correct - lookupFixity op_name `thenRn` \ fixity -> + -- Don't even look up the fixity when in interface mode getModeRn `thenRn` \ mode -> (case mode of - SourceMode -> mkOpAppRn e1' op' fixity e2' - InterfaceMode _ -> returnRn (OpApp e1' op' fixity e2') + SourceMode -> lookupFixity op_name `thenRn` \ fixity -> + mkOpAppRn e1' op' fixity e2' + InterfaceMode -> returnRn (OpApp e1' op' defaultFixity e2') ) `thenRn` \ final_e -> returnRn (final_e, @@ -309,7 +316,7 @@ rnExpr (NegApp e n) = rnExpr e `thenRn` \ (e', fv_e) -> lookupImplicitOccRn negate_RDR `thenRn` \ neg -> mkNegAppRn e' (HsVar neg) `thenRn` \ final_e -> - returnRn (final_e, fv_e) + returnRn (final_e, fv_e `addOneFV` neg) rnExpr (HsPar e) = rnExpr e `thenRn` \ (e', fvs_e) -> @@ -327,11 +334,12 @@ rnExpr (SectionR op expr) rnExpr (CCall fun args may_gc is_casm fake_result_ty) -- Check out the comment on RnIfaces.getNonWiredDataDecl about ccalls - = lookupImplicitOccRn ccallableClass_RDR `thenRn_` - lookupImplicitOccRn creturnableClass_RDR `thenRn_` - lookupImplicitOccRn ioDataCon_RDR `thenRn_` + = lookupImplicitOccRn ccallableClass_RDR `thenRn` \ cc -> + lookupImplicitOccRn creturnableClass_RDR `thenRn` \ cr -> + lookupImplicitOccRn ioDataCon_RDR `thenRn` \ io -> rnExprs args `thenRn` \ (args', fvs_args) -> - returnRn (CCall fun args' may_gc is_casm fake_result_ty, fvs_args) + returnRn (CCall fun args' may_gc is_casm fake_result_ty, + fvs_args `addOneFV` cc `addOneFV` cr `addOneFV` io) rnExpr (HsSCC label expr) = rnExpr expr `thenRn` \ (expr', fvs_expr) -> @@ -340,8 +348,8 @@ rnExpr (HsSCC label expr) rnExpr (HsCase expr ms src_loc) = pushSrcLocRn src_loc $ rnExpr expr `thenRn` \ (new_expr, e_fvs) -> - mapAndUnzipRn rnMatch ms `thenRn` \ (new_ms, ms_fvs) -> - returnRn (HsCase new_expr new_ms src_loc, plusFVs (e_fvs : ms_fvs)) + mapFvRn rnMatch ms `thenRn` \ (new_ms, ms_fvs) -> + returnRn (HsCase new_expr new_ms src_loc, e_fvs `plusFV` ms_fvs) rnExpr (HsLet binds expr) = rnBinds binds $ \ binds' -> @@ -350,24 +358,24 @@ rnExpr (HsLet binds expr) rnExpr (HsDo do_or_lc stmts src_loc) = pushSrcLocRn src_loc $ - lookupImplicitOccRn monadClass_RDR `thenRn_` + lookupImplicitOccRn monadClass_RDR `thenRn` \ monad -> rnStmts rnExpr stmts `thenRn` \ (stmts', fvs) -> - returnRn (HsDo do_or_lc stmts' src_loc, fvs) + returnRn (HsDo do_or_lc stmts' src_loc, fvs `addOneFV` monad) rnExpr (ExplicitList exps) - = addImplicitOccRn listTyCon_name `thenRn_` - rnExprs exps `thenRn` \ (exps', fvs) -> - returnRn (ExplicitList exps', fvs) + = rnExprs exps `thenRn` \ (exps', fvs) -> + returnRn (ExplicitList exps', fvs `addOneFV` listTyCon_name) rnExpr (ExplicitTuple exps boxed) - = addImplicitOccRn (tupleTyCon_name boxed (length exps)) `thenRn_` - rnExprs exps `thenRn` \ (exps', fvExps) -> - returnRn (ExplicitTuple exps' boxed, fvExps) + = rnExprs exps `thenRn` \ (exps', fvs) -> + returnRn (ExplicitTuple exps' boxed, fvs `addOneFV` tycon_name) + where + tycon_name = tupleTyCon_name boxed (length exps) rnExpr (RecordCon con_id rbinds) = lookupOccRn con_id `thenRn` \ conname -> rnRbinds "construction" rbinds `thenRn` \ (rbinds', fvRbinds) -> - returnRn (RecordCon conname rbinds', fvRbinds) + returnRn (RecordCon conname rbinds', fvRbinds `addOneFV` conname) rnExpr (RecordUpd expr rbinds) = rnExpr expr `thenRn` \ (expr', fvExpr) -> @@ -387,9 +395,9 @@ rnExpr (HsIf p b1 b2 src_loc) returnRn (HsIf p' b1' b2' src_loc, plusFVs [fvP, fvB1, fvB2]) rnExpr (ArithSeqIn seq) - = lookupImplicitOccRn enumClass_RDR `thenRn_` + = lookupImplicitOccRn enumClass_RDR `thenRn` \ enum -> rn_seq seq `thenRn` \ (new_seq, fvs) -> - returnRn (ArithSeqIn new_seq, fvs) + returnRn (ArithSeqIn new_seq, fvs `addOneFV` enum) where rn_seq (From expr) = rnExpr expr `thenRn` \ (expr', fvExpr) -> @@ -422,8 +430,8 @@ rnExpr (ArithSeqIn seq) \begin{code} rnRbinds str rbinds = mapRn_ field_dup_err dup_fields `thenRn_` - mapAndUnzipRn rn_rbind rbinds `thenRn` \ (rbinds', fvRbind_s) -> - returnRn (rbinds', plusFVs fvRbind_s) + mapFvRn rn_rbind rbinds `thenRn` \ (rbinds', fvRbind) -> + returnRn (rbinds', fvRbind) where (_, dup_fields) = removeDups compare [ f | (f,_,_) <- rbinds ] @@ -436,8 +444,8 @@ rnRbinds str rbinds rnRpats rpats = mapRn_ field_dup_err dup_fields `thenRn_` - mapAndUnzipRn rn_rpat rpats `thenRn` \ (rpats', fvs_s) -> - returnRn (rpats', plusFVs fvs_s) + mapFvRn rn_rpat rpats `thenRn` \ (rpats', fvs) -> + returnRn (rpats', fvs) where (_, dup_fields) = removeDups compare [ f | (f,_,_) <- rpats ] @@ -464,11 +472,11 @@ be @{r}@, and the free var set for the entire Quals will be @{r}@. This Quals. \begin{code} -type RnExprTy s = RdrNameHsExpr -> RnMS s (RenamedHsExpr, FreeVars) +type RnExprTy = RdrNameHsExpr -> RnMS (RenamedHsExpr, FreeVars) -rnStmts :: RnExprTy s +rnStmts :: RnExprTy -> [RdrNameStmt] - -> RnMS s ([RenamedStmt], FreeVars) + -> RnMS ([RenamedStmt], FreeVars) rnStmts rn_expr [] = returnRn ([], emptyFVs) @@ -478,20 +486,21 @@ rnStmts rn_expr (stmt:stmts) rnStmts rn_expr stmts `thenRn` \ (stmts', fvs) -> returnRn (stmt' : stmts', fvs) -rnStmt :: RnExprTy s -> RdrNameStmt - -> (RenamedStmt -> RnMS s (a, FreeVars)) - -> RnMS s (a, FreeVars) +rnStmt :: RnExprTy -> RdrNameStmt + -> (RenamedStmt -> RnMS (a, FreeVars)) + -> RnMS (a, FreeVars) -- Because of mutual recursion we have to pass in rnExpr. rnStmt rn_expr (BindStmt pat expr src_loc) thing_inside = pushSrcLocRn src_loc $ rn_expr expr `thenRn` \ (expr', fv_expr) -> - bindLocalsFVRn "a pattern in do binding" binders $ \ new_binders -> + bindLocalsFVRn doc binders $ \ new_binders -> rnPat pat `thenRn` \ (pat', fv_pat) -> thing_inside (BindStmt pat' expr' src_loc) `thenRn` \ (result, fvs) -> returnRn (result, fv_expr `plusFV` fvs `plusFV` fv_pat) where binders = collectPatBinders pat + doc = text "a pattern in do binding" rnStmt rn_expr (ExprStmt expr src_loc) thing_inside = pushSrcLocRn src_loc $ @@ -532,7 +541,7 @@ operator appications left-associatively. \begin{code} mkOpAppRn :: RenamedHsExpr -> RenamedHsExpr -> Fixity -> RenamedHsExpr - -> RnMS s RenamedHsExpr + -> RnMS RenamedHsExpr mkOpAppRn e1@(OpApp e11 op1 fix1 e12) op2 fix2 e2 @@ -595,7 +604,7 @@ not_op_app mode other = True \begin{code} mkConOpPatRn :: RenamedPat -> Name -> Fixity -> RenamedPat - -> RnMS s RenamedPat + -> RnMS RenamedPat mkConOpPatRn p1@(ConOpPatIn p11 op1 fix1 p12) op2 fix2 p2 @@ -627,13 +636,19 @@ not_op_pat other = True \end{code} \begin{code} -checkPrecMatch :: Bool -> Name -> RenamedMatch -> RnMS s () +checkPrecMatch :: Bool -> Name -> RenamedMatch -> RnMS () checkPrecMatch False fn match = returnRn () + checkPrecMatch True op (Match _ [p1,p2] _ _) - = checkPrec op p1 False `thenRn_` - checkPrec op p2 True + = getModeRn `thenRn` \ mode -> + -- See comments with rnExpr (OpApp ...) + case mode of + InterfaceMode -> returnRn () + SourceMode -> checkPrec op p1 False `thenRn_` + checkPrec op p2 True + checkPrecMatch True op _ = panic "checkPrecMatch" checkPrec op (ConOpPatIn _ op1 _ _) right @@ -694,24 +709,25 @@ are made available. \begin{code} litOccurrence (HsChar _) - = addImplicitOccRn charTyCon_name + = returnRn (unitFV charTyCon_name) litOccurrence (HsCharPrim _) - = addImplicitOccRn (getName charPrimTyCon) + = returnRn (unitFV (getName charPrimTyCon)) litOccurrence (HsString _) - = addImplicitOccRn listTyCon_name `thenRn_` - addImplicitOccRn charTyCon_name + = returnRn (unitFV listTyCon_name `plusFV` unitFV charTyCon_name) litOccurrence (HsStringPrim _) - = addImplicitOccRn (getName addrPrimTyCon) + = returnRn (unitFV (getName addrPrimTyCon)) litOccurrence (HsInt _) - = lookupImplicitOccRn numClass_RDR -- Int and Integer are forced in by Num + = lookupImplicitOccRn numClass_RDR `thenRn` \ num -> + returnRn (unitFV num) -- Int and Integer are forced in by Num litOccurrence (HsFrac _) - = lookupImplicitOccRn fractionalClass_RDR `thenRn_` - lookupImplicitOccRn ratioDataCon_RDR + = lookupImplicitOccRn fractionalClass_RDR `thenRn` \ frac -> + lookupImplicitOccRn ratioDataCon_RDR `thenRn` \ ratio -> + returnRn (unitFV frac `plusFV` unitFV ratio) -- We have to make sure that the Ratio type is imported with -- its constructor, because literals of type Ratio t are -- built with that constructor. @@ -719,16 +735,17 @@ litOccurrence (HsFrac _) -- when fractionalClass does. litOccurrence (HsIntPrim _) - = addImplicitOccRn (getName intPrimTyCon) + = returnRn (unitFV (getName intPrimTyCon)) litOccurrence (HsFloatPrim _) - = addImplicitOccRn (getName floatPrimTyCon) + = returnRn (unitFV (getName floatPrimTyCon)) litOccurrence (HsDoublePrim _) - = addImplicitOccRn (getName doublePrimTyCon) + = returnRn (unitFV (getName doublePrimTyCon)) litOccurrence (HsLitLit _) - = lookupImplicitOccRn ccallableClass_RDR + = lookupImplicitOccRn ccallableClass_RDR `thenRn` \ cc -> + returnRn (unitFV cc) \end{code} %************************************************************************ @@ -738,10 +755,9 @@ litOccurrence (HsLitLit _) %************************************************************************ \begin{code} -mkAssertExpr :: RnMS s RenamedHsExpr +mkAssertExpr :: RnMS (RenamedHsExpr, FreeVars) mkAssertExpr = - newImportedGlobalFromRdrName assertErr_RDR `thenRn` \ name -> - addOccurrenceName name `thenRn_` + mkImportedGlobalFromRdrName assertErr_RDR `thenRn` \ name -> getSrcLocRn `thenRn` \ sloc -> -- if we're ignoring asserts, return (\ _ e -> e) @@ -757,7 +773,7 @@ mkAssertExpr = (GRHSs [GRHS [ExprStmt (HsVar vname) loc] loc] EmptyBinds Nothing) in - returnRn expr + returnRn (expr, unitFV name) else let expr = @@ -765,7 +781,7 @@ mkAssertExpr = (HsLit (HsString (_PK_ (showSDoc (ppr sloc))))) in - returnRn expr + returnRn (expr, unitFV name) \end{code} diff --git a/ghc/compiler/rename/RnHsSyn.lhs b/ghc/compiler/rename/RnHsSyn.lhs index 29abb3b..496a518 100644 --- a/ghc/compiler/rename/RnHsSyn.lhs +++ b/ghc/compiler/rename/RnHsSyn.lhs @@ -26,6 +26,7 @@ type RenamedClassOpSig = Sig Name type RenamedConDecl = ConDecl Name type RenamedContext = Context Name type RenamedHsDecl = HsDecl Name RenamedPat +type RenamedRuleDecl = RuleDecl Name RenamedPat type RenamedTyClDecl = TyClDecl Name RenamedPat type RenamedSpecDataSig = SpecDataSig Name type RenamedDefaultDecl = DefaultDecl Name diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs index eebe37e..ff21596 100644 --- a/ghc/compiler/rename/RnIfaces.lhs +++ b/ghc/compiler/rename/RnIfaces.lhs @@ -5,66 +5,60 @@ \begin{code} module RnIfaces ( - getInterfaceExports, - getImportedInstDecls, - getSpecialInstModules, getDeferredDataDecls, + getInterfaceExports, + getImportedInstDecls, getImportedRules, + lookupFixity, loadHomeInterface, importDecl, recordSlurp, - getImportVersions, getSlurpedNames, getRnStats, getImportedFixities, + getImportVersions, getSlurped, checkUpToDate, - getDeclBinders, - mkSearchPath + getDeclBinders ) where #include "HsVersions.h" -import CmdLineOpts ( opt_PruneTyDecls, opt_PruneInstDecls, - opt_D_show_rn_imports, opt_IgnoreIfacePragmas - ) +import CmdLineOpts ( opt_NoPruneDecls, opt_IgnoreIfacePragmas ) import HsSyn ( HsDecl(..), TyClDecl(..), InstDecl(..), IfaceSig(..), HsType(..), ConDecl(..), IE(..), ConDetails(..), Sig(..), - FixitySig(..), - hsDeclName, countTyClDecls, isDataDecl, isClassOpSig + FixitySig(..), RuleDecl(..), + isClassOpSig ) -import BasicTypes ( Version, NewOrData(..) ) -import RdrHsSyn ( RdrNameHsDecl, RdrNameInstDecl, RdrNameTyClDecl, +import BasicTypes ( Version, NewOrData(..), defaultFixity ) +import RdrHsSyn ( RdrNameHsDecl, RdrNameInstDecl, RdrNameTyClDecl, RdrNameRuleDecl, + extractHsTyRdrNames ) -import RnEnv ( newImportedGlobalName, newImportedGlobalFromRdrName, - addImplicitOccsRn, pprAvail, - availName, availNames, addAvailToNameSet +import RnEnv ( mkImportedGlobalName, newImportedBinder, mkImportedGlobalFromRdrName, + lookupOccRn, + pprAvail, + availName, availNames, addAvailToNameSet, + FreeVars, emptyFVs ) -import RnSource ( rnHsSigType ) import RnMonad import RnHsSyn ( RenamedHsDecl ) import ParseIface ( parseIface, IfaceStuff(..) ) import FiniteMap ( FiniteMap, sizeFM, emptyFM, delFromFM, lookupFM, addToFM, addToFM_C, addListToFM, - fmToList + fmToList, elemFM, foldFM ) import Name ( Name {-instance NamedThing-}, nameModule, isLocallyDefined, - isWiredInName, maybeWiredInTyConName, - maybeWiredInIdName, nameUnique, NamedThing(..), - pprEncodedFS + isWiredInName, nameUnique, NamedThing(..) ) -import Module ( Module, mkBootModule, moduleString, pprModule, - mkDynamicModule, moduleIfaceFlavour, bootFlavour, hiFile, - moduleUserString, moduleFS, setModuleFlavour +import Module ( Module, moduleString, pprModule, + mkVanillaModule, pprModuleName, + moduleUserString, moduleName, isLibModule, + ModuleName, WhereFrom(..), ) import RdrName ( RdrName, rdrNameOcc ) import NameSet -import Id ( idType, isDataConId_maybe ) -import DataCon ( dataConTyCon, dataConType ) -import TyCon ( TyCon, tyConDataCons, isSynTyCon, getSynTyConDefn ) -import Type ( namesOfType ) import Var ( Id ) import SrcLoc ( mkSrcLoc, SrcLoc ) import PrelMods ( pREL_GHC ) import PrelInfo ( cCallishTyKeys, thinAirModules ) import Bag -import Maybes ( MaybeErr(..), maybeToBool ) +import Maybes ( MaybeErr(..), maybeToBool, orElse ) import ListSetOps ( unionLists ) import Outputable import Unique ( Unique ) @@ -77,86 +71,6 @@ import List ( nub ) \end{code} - -%********************************************************* -%* * -\subsection{Statistics} -%* * -%********************************************************* - -\begin{code} -getRnStats :: [RenamedHsDecl] -> RnMG SDoc -getRnStats all_decls - = getIfacesRn `thenRn` \ ifaces -> - let - n_mods = sizeFM (iModMap ifaces) - - decls_imported = filter is_imported_decl all_decls - - decls_read = [decl | (_, avail, decl, True) <- nameEnvElts (iDecls ifaces), - -- Data, newtype, and class decls are in the decls_fm - -- under multiple names; the tycon/class, and each - -- constructor/class op too. - -- The 'True' selects just the 'main' decl - not (isLocallyDefined (availName avail)) - ] - - (cd_rd, dd_rd, add_rd, nd_rd, and_rd, sd_rd, vd_rd, _) = count_decls decls_read - (cd_sp, dd_sp, add_sp, nd_sp, and_sp, sd_sp, vd_sp, id_sp) = count_decls decls_imported - - (unslurped_insts, _) = iDefInsts ifaces - inst_decls_unslurped = length (bagToList unslurped_insts) - inst_decls_read = id_sp + inst_decls_unslurped - - stats = vcat - [int n_mods <> text " interfaces read", - hsep [ int cd_sp, text "class decls imported, out of", - int cd_rd, text "read"], - hsep [ int dd_sp, text "data decls imported (of which", int add_sp, - text "abstractly), out of", - int dd_rd, text "read"], - hsep [ int nd_sp, text "newtype decls imported (of which", int and_sp, - text "abstractly), out of", - int nd_rd, text "read"], - hsep [int sd_sp, text "type synonym decls imported, out of", - int sd_rd, text "read"], - hsep [int vd_sp, text "value signatures imported, out of", - int vd_rd, text "read"], - hsep [int id_sp, text "instance decls imported, out of", - int inst_decls_read, text "read"] - ] - in - returnRn (hcat [text "Renamer stats: ", stats]) - -is_imported_decl (DefD _) = False -is_imported_decl (ValD _) = False -is_imported_decl decl = not (isLocallyDefined (hsDeclName decl)) - -count_decls decls - = -- pprTrace "count_decls" (ppr decls - -- - -- $$ - -- text "=========" - -- $$ - -- ppr imported_decls - -- ) $ - (class_decls, - data_decls, abstract_data_decls, - newtype_decls, abstract_newtype_decls, - syn_decls, - val_decls, - inst_decls) - where - tycl_decls = [d | TyClD d <- decls] - (class_decls, data_decls, newtype_decls, syn_decls) = countTyClDecls tycl_decls - abstract_data_decls = length [() | TyData DataType _ _ _ [] _ _ _ <- tycl_decls] - abstract_newtype_decls = length [() | TyData NewType _ _ _ [] _ _ _ <- tycl_decls] - - val_decls = length [() | SigD _ <- decls] - inst_decls = length [() | InstD _ <- decls] - -\end{code} - %********************************************************* %* * \subsection{Loading a new interface file} @@ -164,94 +78,106 @@ count_decls decls %********************************************************* \begin{code} -loadHomeInterface :: SDoc -> Name -> RnMG (Module, Ifaces) +loadHomeInterface :: SDoc -> Name -> RnM d (Module, Ifaces) loadHomeInterface doc_str name - = loadInterface doc_str (nameModule name) + = loadInterface doc_str (moduleName (nameModule name)) ImportBySystem -loadInterface :: SDoc -> Module -> RnMG (Module, Ifaces) -loadInterface doc_str load_mod - = getIfacesRn `thenRn` \ ifaces -> +loadInterface :: SDoc -> ModuleName -> WhereFrom -> RnM d (Module, Ifaces) +loadInterface doc_str mod_name from + = getIfacesRn `thenRn` \ ifaces -> let - hi_boot_wanted = bootFlavour (moduleIfaceFlavour load_mod) - mod_map = iModMap ifaces - (insts, tycls_names) = iDefInsts ifaces - + mod_map = iImpModInfo ifaces + mod_info = lookupFM mod_map mod_name + in_map = maybeToBool mod_info in + + -- Issue a warning for a redundant {- SOURCE -} import + -- It's redundant if the moduld is in the iImpModInfo at all, + -- because we arrange to read all the ordinary imports before + -- any of the {- SOURCE -} imports + warnCheckRn (not (in_map && case from of {ImportByUserSource -> True; other -> False})) + (warnRedundantSourceImport mod_name) `thenRn_` + -- CHECK WHETHER WE HAVE IT ALREADY - case lookupFM mod_map load_mod of { - Just (existing_hif, _, _) - | hi_boot_wanted || not (bootFlavour existing_hif) - -> -- Already in the cache, and new version is no better than old, - -- so don't re-read it - returnRn (setModuleFlavour existing_hif load_mod, ifaces) ; - other -> + case mod_info of { + Just (_, _, Just (load_mod, _, _)) + -> -- We're read it already so don't re-read it + returnRn (load_mod, ifaces) ; + + mod_map_result -> -- READ THE MODULE IN - findAndReadIface doc_str load_mod `thenRn` \ read_result -> + findAndReadIface doc_str mod_name from in_map `thenRn` \ (hi_boot_read, read_result) -> case read_result of { - Nothing | not hi_boot_wanted && load_mod `elem` thinAirModules - -> -- Hack alert! When compiling PrelBase we have to load the - -- decls for packCString# and friends; they are 'thin-air' Ids - -- (see PrelInfo.lhs). So if we don't find the HiFile we quietly - -- look for a .hi-boot file instead, and use that - -- - -- NB this causes multiple "failed" attempts to read PrelPack, - -- which makes curious reading with -dshow-rn-trace, but - -- there's no harm done - loadInterface doc_str (mkBootModule load_mod) - - - | otherwise - -> -- Not found, so add an empty export env to the Ifaces map + Nothing -> -- Not found, so add an empty export env to the Ifaces map -- so that we don't look again let - new_mod_map = addToFM mod_map load_mod (hiFile, 0, []) - new_ifaces = ifaces { iModMap = new_mod_map } + mod = mkVanillaModule mod_name + new_mod_map = addToFM mod_map mod_name (0, False, Just (mod, False, [])) + new_ifaces = ifaces { iImpModInfo = new_mod_map } in setIfacesRn new_ifaces `thenRn_` - failWithRn (load_mod, new_ifaces) (noIfaceErr load_mod) ; + failWithRn (mod, new_ifaces) (noIfaceErr mod hi_boot_read) ; -- Found and parsed! - Just (the_mod, ParsedIface mod_vers usages exports rd_inst_mods rd_decls rd_insts) -> - + Just (mod, iface) -> -- LOAD IT INTO Ifaces - -- First set the module -- NB: *first* we do loadDecl, so that the provenance of all the locally-defined --- names is done correctly (notably, whether this is an .hi file or .hi-boot file). -- If we do loadExport first the wrong info gets into the cache (unless we -- explicitly tag each export which seems a bit of a bore) - getModuleRn `thenRn` \ this_mod -> - setModuleRn the_mod $ -- First set the module name of the module being loaded, - -- so that unqualified occurrences in the interface file - -- get the right qualifer - foldlRn loadDecl (iDecls ifaces) rd_decls `thenRn` \ new_decls -> - foldlRn loadFixDecl (iFixes ifaces) rd_decls `thenRn` \ new_fixities -> - foldlRn loadInstDecl insts rd_insts `thenRn` \ new_insts -> - - mapRn (loadExport this_mod) exports `thenRn` \ avails_s -> + getModuleRn `thenRn` \ this_mod_nm -> let - -- Notice: the 'flavour' of the loaded Module does not have to - -- be the same as the requested Module. - the_mod_hif = moduleIfaceFlavour the_mod - mod_details = (the_mod_hif, mod_vers, concat avails_s) - - -- Exclude this module from the "special-inst" modules - new_inst_mods = iInstMods ifaces `unionLists` (filter (/= this_mod) rd_inst_mods) - - new_ifaces = ifaces { iModMap = addToFM mod_map the_mod mod_details, - iDecls = new_decls, - iFixes = new_fixities, - iDefInsts = (new_insts, tycls_names), - iInstMods = new_inst_mods } + rd_decls = pi_decls iface + in + foldlRn (loadDecl mod) (iDecls ifaces) rd_decls `thenRn` \ new_decls -> + foldlRn (loadInstDecl mod) (iInsts ifaces) (pi_insts iface) `thenRn` \ new_insts -> + foldlRn (loadRule mod) (iRules ifaces) (pi_rules iface) `thenRn` \ new_rules -> + foldlRn (loadFixDecl mod_name) (iFixes ifaces) rd_decls `thenRn` \ new_fixities -> + mapRn (loadExport this_mod_nm) (pi_exports iface) `thenRn` \ avails_s -> + let + -- For an explicit user import, add to mod_map info about + -- the things the imported module depends on, extracted + -- from its usage info. + mod_map1 = case from of + ImportByUser -> addModDeps mod mod_map (pi_usages iface) + other -> mod_map + + -- Now add info about this module + mod_map2 = addToFM mod_map1 mod_name mod_details + mod_details = (pi_mod iface, pi_orphan iface, Just (mod, hi_boot_read, concat avails_s)) + + new_ifaces = ifaces { iImpModInfo = mod_map2, + iDecls = new_decls, + iFixes = new_fixities, + iRules = new_rules, + iInsts = new_insts } in setIfacesRn new_ifaces `thenRn_` - returnRn (the_mod, new_ifaces) + returnRn (mod, new_ifaces) }} -loadExport :: Module -> ExportItem -> RnMG [AvailInfo] +addModDeps :: Module -> ImportedModuleInfo + -> [ImportVersion a] -> ImportedModuleInfo +addModDeps mod mod_deps new_deps + = foldr add mod_deps new_deps + where + is_lib = isLibModule mod -- Don't record dependencies when importing a library module + add (imp_mod, version, has_orphans, _) deps + | is_lib && not has_orphans = deps + | otherwise = addToFM_C combine deps imp_mod (version, has_orphans, Nothing) + -- Record dependencies for modules that are + -- either are dependent via a non-library module + -- or contain orphan rules or instance decls + + -- Don't ditch a module that's already loaded!! + combine old@(_, _, Just _) new = old + combine old@(_, _, Nothing) new = new + +loadExport :: ModuleName -> ExportItem -> RnM d [AvailInfo] loadExport this_mod (mod, entities) | mod == this_mod = returnRn [] -- If the module exports anything defined in this module, just ignore it. @@ -271,10 +197,9 @@ loadExport this_mod (mod, entities) -- but it's a bogus thing to do! | otherwise - = setModuleFlavourRn mod `thenRn` \ mod' -> - mapRn (load_entity mod') entities + = mapRn (load_entity mod) entities where - new_name mod occ = newImportedGlobalName mod occ + new_name mod occ = mkImportedGlobalName mod occ load_entity mod (Avail occ) = new_name mod occ `thenRn` \ name -> @@ -285,27 +210,28 @@ loadExport this_mod (mod, entities) returnRn (AvailTC name names) -loadFixDecl :: FixityEnv +loadFixDecl :: ModuleName -> FixityEnv -> (Version, RdrNameHsDecl) - -> RnMG FixityEnv -loadFixDecl fixity_env (version, FixD (FixitySig rdr_name fixity loc)) + -> RnM d FixityEnv +loadFixDecl mod_name fixity_env (version, FixD sig@(FixitySig rdr_name fixity loc)) = -- Ignore the version; when the fixity changes the version of -- its 'host' entity changes, so we don't need a separate version -- number for fixities - newImportedGlobalFromRdrName rdr_name `thenRn` \ name -> + mkImportedGlobalName mod_name (rdrNameOcc rdr_name) `thenRn` \ name -> let new_fixity_env = addToNameEnv fixity_env name (FixitySig name fixity loc) in returnRn new_fixity_env -- Ignore the other sorts of decl -loadFixDecl fixity_env other_decl = returnRn fixity_env +loadFixDecl mod_name fixity_env other_decl = returnRn fixity_env -loadDecl :: DeclsMap +loadDecl :: Module + -> DeclsMap -> (Version, RdrNameHsDecl) - -> RnMG DeclsMap + -> RnM d DeclsMap -loadDecl decls_map (version, decl) +loadDecl mod decls_map (version, decl) = getDeclBinders new_name decl `thenRn` \ maybe_avail -> case maybe_avail of { Nothing -> returnRn decls_map; -- No bindings @@ -315,7 +241,7 @@ loadDecl decls_map (version, decl) let main_name = availName avail new_decls_map = foldl add_decl decls_map - [ (name, (version,avail,decl',name==main_name)) + [ (name, (version, avail, name==main_name, (mod, decl))) | name <- sys_bndrs ++ availNames avail] add_decl decls_map (name, stuff) = WARN( name `elemNameEnv` decls_map, ppr name ) @@ -324,7 +250,11 @@ loadDecl decls_map (version, decl) returnRn new_decls_map } where - new_name rdr_name loc = newImportedGlobalFromRdrName rdr_name + -- newImportedBinder puts into the cache the binder with the + -- module information set correctly. When the decl is later renamed, + -- the binding site will thereby get the correct module. + new_name rdr_name loc = newImportedBinder mod rdr_name + {- If a signature decl is being loaded, and optIgnoreIfacePragmas is on, we toss away unfolding information. @@ -341,16 +271,15 @@ loadDecl decls_map (version, decl) 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) - _ -> decl + decl' = case decl of + SigD (IfaceSig name tp ls loc) | opt_IgnoreIfacePragmas -> SigD (IfaceSig name tp [] loc) + other -> decl -loadInstDecl :: Bag IfaceInst +loadInstDecl :: Module + -> Bag GatedDecl -> RdrNameInstDecl - -> RnMG (Bag IfaceInst) -loadInstDecl insts decl@(InstDecl inst_ty binds uprags dfun_name src_loc) + -> RnM d (Bag GatedDecl) +loadInstDecl mod insts decl@(InstDecl inst_ty binds uprags dfun_name src_loc) = -- Find out what type constructors and classes are "gates" for the -- instance declaration. If all these "gates" are slurped in then @@ -365,16 +294,20 @@ loadInstDecl insts decl@(InstDecl inst_ty binds uprags dfun_name src_loc) munged_inst_ty = case inst_ty of HsForAllTy tvs cxt ty -> HsForAllTy tvs [] ty other -> inst_ty + free_names = extractHsTyRdrNames munged_inst_ty in - -- We find the gates by renaming the instance type with in a - -- and returning the free variables of the type - initRnMS emptyRnEnv vanillaInterfaceMode ( - discardOccurrencesRn (rnHsSigType (text "an instance decl") munged_inst_ty) - ) `thenRn` \ (_, gate_names) -> - getModuleRn `thenRn` \ mod_name -> - returnRn (((mod_name, decl), gate_names) `consBag` insts) - -vanillaInterfaceMode = InterfaceMode Compulsory + setModuleRn (moduleName mod) $ + mapRn mkImportedGlobalFromRdrName free_names `thenRn` \ gate_names -> + returnRn ((mkNameSet gate_names, (mod, InstD decl)) `consBag` insts) + +loadRule :: Module -> Bag GatedDecl + -> RdrNameRuleDecl -> RnM d (Bag GatedDecl) +-- "Gate" the rule simply by whether the rule variable is +-- needed. We can refine this later. +loadRule mod rules decl@(IfaceRuleDecl var body src_loc) + = setModuleRn (moduleName mod) $ + mkImportedGlobalFromRdrName var `thenRn` \ var_name -> + returnRn ((unitNameSet var_name, (mod, RuleD decl)) `consBag` rules) \end{code} @@ -385,45 +318,51 @@ vanillaInterfaceMode = InterfaceMode Compulsory %******************************************************** \begin{code} -checkUpToDate :: Module -> RnMG Bool -- True <=> no need to recompile +checkUpToDate :: ModuleName -> RnMG Bool -- True <=> no need to recompile checkUpToDate mod_name - = findAndReadIface doc_str mod_name `thenRn` \ read_result -> + = getIfacesRn `thenRn` \ ifaces -> + findAndReadIface doc_str mod_name + ImportByUser + (error "checkUpToDate") `thenRn` \ (_, read_result) -> -- CHECK WHETHER WE HAVE IT ALREADY case read_result of Nothing -> -- Old interface file not found, so we'd better bail out traceRn (sep [ptext SLIT("Didnt find old iface"), - pprModule mod_name]) `thenRn_` + pprModuleName mod_name]) `thenRn_` returnRn False - Just (_, ParsedIface _ usages _ _ _ _) + Just (_, iface) -> -- Found it, so now check it - checkModUsage usages + checkModUsage (pi_usages iface) where -- Only look in current directory, with suffix .hi - doc_str = sep [ptext SLIT("need usage info from"), pprModule mod_name] + doc_str = sep [ptext SLIT("need usage info from"), pprModuleName mod_name] checkModUsage [] = returnRn True -- Yes! Everything is up to date! -checkModUsage ((mod, old_mod_vers, whats_imported) : rest) - = loadInterface doc_str mod `thenRn` \ (mod, ifaces) -> +checkModUsage ((mod_name, old_mod_vers, _, whats_imported) : rest) + = loadInterface doc_str mod_name ImportBySystem `thenRn` \ (mod, ifaces) -> let - maybe_new_mod_vers = lookupFM (iModMap ifaces) mod - Just (_, new_mod_vers, _) = maybe_new_mod_vers + maybe_mod_vers = case lookupFM (iImpModInfo ifaces) mod_name of + Just (version, _, Just (_, _, _)) -> Just version + other -> Nothing in - -- If we can't find a version number for the old module then - -- bail out saying things aren't up to date - if not (maybeToBool maybe_new_mod_vers) then - traceRn (sep [ptext SLIT("Can't find version number for module"), pprModule mod]) `thenRn_` - returnRn False - else + case maybe_mod_vers of { + Nothing -> -- If we can't find a version number for the old module then + -- bail out saying things aren't up to date + traceRn (sep [ptext SLIT("Can't find version number for module"), + pprModuleName mod_name]) `thenRn_` + returnRn False ; + + Just new_mod_vers -> -- If the module version hasn't changed, just move on if new_mod_vers == old_mod_vers then - traceRn (sep [ptext SLIT("Module version unchanged:"), pprModule mod]) `thenRn_` + traceRn (sep [ptext SLIT("Module version unchanged:"), pprModuleName mod_name]) `thenRn_` checkModUsage rest else - traceRn (sep [ptext SLIT("Module version has changed:"), pprModule mod]) `thenRn_` + traceRn (sep [ptext SLIT("Module version has changed:"), pprModuleName mod_name]) `thenRn_` -- Module version changed, so check entities inside @@ -437,22 +376,22 @@ checkModUsage ((mod, old_mod_vers, whats_imported) : rest) Specifically old_local_vers -> -- Non-empty usage list, so check item by item - checkEntityUsage mod (iDecls ifaces) old_local_vers `thenRn` \ up_to_date -> + checkEntityUsage mod_name (iDecls ifaces) old_local_vers `thenRn` \ up_to_date -> if up_to_date then traceRn (ptext SLIT("...but the bits I use haven't.")) `thenRn_` checkModUsage rest -- This one's ok, so check the rest else returnRn False -- This one failed, so just bail out now - } + }} where - doc_str = sep [ptext SLIT("need version info for"), pprModule mod] + doc_str = sep [ptext SLIT("need version info for"), pprModuleName mod_name] checkEntityUsage mod decls [] = returnRn True -- Yes! All up to date! checkEntityUsage mod decls ((occ_name,old_vers) : rest) - = newImportedGlobalName mod occ_name `thenRn` \ name -> + = mkImportedGlobalName mod occ_name `thenRn` \ name -> case lookupNameEnv decls name of Nothing -> -- We used it before, but it ain't there now @@ -478,57 +417,48 @@ checkEntityUsage mod decls ((occ_name,old_vers) : rest) %********************************************************* \begin{code} -importDecl :: Occurrence -> RnMode -> RnMG (Maybe RdrNameHsDecl) - -- Returns Nothing for a wired-in or already-slurped decl - -importDecl (name, loc) mode - = checkSlurped name `thenRn` \ already_slurped -> - if already_slurped then --- traceRn (sep [text "Already slurped:", ppr name]) `thenRn_` +importDecl :: Name -> RnMG (Maybe (Module, RdrNameHsDecl)) + -- Returns Nothing for + -- (a) wired in name + -- (b) local decl + -- (c) already slurped + +importDecl name + | isWiredInName name + = returnRn Nothing + | otherwise + = getSlurped `thenRn` \ already_slurped -> + if name `elemNameSet` already_slurped then returnRn Nothing -- Already dealt with else - if isWiredInName name then - getWiredInDecl name mode - else - getIfacesRn `thenRn` \ ifaces -> - let - mod = nameModule name - in - if mod == iMod ifaces then -- Don't bring in decls from - addWarnRn (importDeclWarn mod name loc) `thenRn_` --- pprTrace "importDecl wierdness:" (ppr name) $ - returnRn Nothing -- the renamed module's own interface file - -- - else - getNonWiredInDecl name loc mode + getModuleRn `thenRn` \ this_mod -> + let + mod = moduleName (nameModule name) + in + if mod == this_mod then -- Don't bring in decls from + -- the renamed module's own interface file + addWarnRn (importDeclWarn mod name) `thenRn_` + returnRn Nothing + else + getNonWiredInDecl name \end{code} \begin{code} -getNonWiredInDecl :: Name -> SrcLoc -> RnMode -> RnMG (Maybe RdrNameHsDecl) -getNonWiredInDecl needed_name loc mode +getNonWiredInDecl :: Name -> RnMG (Maybe (Module, RdrNameHsDecl)) +getNonWiredInDecl needed_name = traceRn doc_str `thenRn_` loadHomeInterface doc_str needed_name `thenRn` \ (_, ifaces) -> case lookupNameEnv (iDecls ifaces) needed_name of - -- Special case for data/newtype type declarations - Just (version, avail, TyClD tycl_decl, _) | isDataDecl tycl_decl - -> getNonWiredDataDecl needed_name version avail tycl_decl `thenRn` \ (avail', maybe_decl) -> - recordSlurp (Just version) necessity avail' `thenRn_` - returnRn maybe_decl - - Just (version,avail,decl,_) - -> recordSlurp (Just version) necessity avail `thenRn_` + Just (version,avail,_,decl) + -> recordSlurp (Just version) avail `thenRn_` returnRn (Just decl) - Nothing -> -- Can happen legitimately for "Optional" occurrences - case necessity of { - Optional -> addWarnRn (getDeclWarn needed_name loc); - other -> addErrRn (getDeclErr needed_name loc) - } `thenRn_` - returnRn Nothing + Nothing -- Can happen legitimately for "Optional" occurrences + -> addErrRn (getDeclErr needed_name) `thenRn_` + returnRn Nothing where - necessity = modeToNecessity mode - doc_str = sep [ptext SLIT("need decl for"), ppr needed_name, ptext SLIT("needed at"), ppr loc] + doc_str = ptext SLIT("need decl for") <+> ppr needed_name \end{code} @getWiredInDecl@ maps a wired-in @Name@ to what it makes available. @@ -550,95 +480,6 @@ Specifically, All this is necessary so that we know all types that are "in play", so that we know just what instances to bring into scope. -\begin{code} -getWiredInDecl name mode - = setModuleRn mod_name ( - initRnMS emptyRnEnv new_mode get_wired - ) `thenRn` \ avail -> - recordSlurp Nothing necessity avail `thenRn_` - - -- Force in the home module in case it has instance decls for - -- the thing we are interested in. - -- - -- Mini hack 1: no point for non-tycons/class; and if we - -- do this we find PrelNum trying to import PackedString, - -- because PrelBase's .hi file mentions PackedString.unpackString - -- But PackedString.hi isn't built by that point! - -- - -- Mini hack 2; GHC is guaranteed not to have - -- instance decls, so it's a waste of time to read it - -- - -- NB: We *must* look at the availName of the slurped avail, - -- not the name passed to getWiredInDecl! Why? Because if a data constructor - -- or class op is passed to getWiredInDecl we'll pull in the whole data/class - -- decl, and recordSlurp will record that fact. But since the data constructor - -- isn't a tycon/class we won't force in the home module. And even if the - -- type constructor/class comes along later, loadDecl will say that it's already - -- been slurped, so getWiredInDecl won't even be called. Pretty obscure bug, this was. - let - main_name = availName avail - main_is_tc = case avail of { AvailTC _ _ -> True; Avail _ -> False } - mod = nameModule main_name - doc_str = sep [ptext SLIT("need home module for wired in thing"), ppr name] - in - (if not main_is_tc || mod == pREL_GHC then - returnRn () - else - loadHomeInterface doc_str main_name `thenRn_` - returnRn () - ) `thenRn_` - - returnRn Nothing -- No declaration to process further - where - necessity = modeToNecessity mode - new_mode = case mode of - InterfaceMode _ -> mode - SourceMode -> vanillaInterfaceMode - - get_wired | is_tycon -- ... a type constructor - = get_wired_tycon the_tycon - - | maybeToBool maybe_data_con -- ... a wired-in data constructor - = get_wired_tycon (dataConTyCon data_con) - - | otherwise -- ... a wired-in non data-constructor - = get_wired_id the_id - - mod_name = nameModule name - maybe_wired_in_tycon = maybeWiredInTyConName name - is_tycon = maybeToBool maybe_wired_in_tycon - maybe_wired_in_id = maybeWiredInIdName name - Just the_tycon = maybe_wired_in_tycon - Just the_id = maybe_wired_in_id - maybe_data_con = isDataConId_maybe the_id - Just data_con = maybe_data_con - - -get_wired_id id - = addImplicitOccsRn id_mentions `thenRn_` - returnRn (Avail (getName id)) - where - id_mentions = nameSetToList (namesOfType ty) - ty = idType id - -get_wired_tycon tycon - | isSynTyCon tycon - = addImplicitOccsRn (nameSetToList mentioned) `thenRn_` - returnRn (AvailTC tc_name [tc_name]) - where - tc_name = getName tycon - (tyvars,ty) = getSynTyConDefn tycon - mentioned = namesOfType ty `minusNameSet` mkNameSet (map getName tyvars) - -get_wired_tycon tycon - | otherwise -- data or newtype - = addImplicitOccsRn (nameSetToList mentioned) `thenRn_` - returnRn (AvailTC tycon_name (tycon_name : map getName data_cons)) - where - tycon_name = getName tycon - data_cons = tyConDataCons tycon - mentioned = foldr (unionNameSets . namesOfType . dataConType) emptyNameSet data_cons -\end{code} @@ -648,187 +489,100 @@ get_wired_tycon tycon %* * %********************************************************* +@getInterfaceExports@ is called only for directly-imported modules + \begin{code} -getInterfaceExports :: Module -> RnMG (Module, Avails) -getInterfaceExports mod - = loadInterface doc_str mod `thenRn` \ (mod, ifaces) -> - case lookupFM (iModMap ifaces) mod of +getInterfaceExports :: ModuleName -> WhereFrom -> RnMG (Module, Avails) +getInterfaceExports mod_name from + = loadInterface doc_str mod_name from `thenRn` \ (mod, ifaces) -> + case lookupFM (iImpModInfo ifaces) mod_name of Nothing -> -- Not there; it must be that the interface file wasn't found; -- the error will have been reported already. -- (Actually loadInterface should put the empty export env in there -- anyway, but this does no harm.) returnRn (mod, []) - Just (_, _, avails) -> returnRn (mod, avails) + Just (_, _, Just (mod, _, avails)) -> returnRn (mod, avails) where - doc_str = sep [pprModule mod, ptext SLIT("is directly imported")] + doc_str = sep [pprModuleName mod_name, ptext SLIT("is directly imported")] \end{code} %********************************************************* %* * -\subsection{Data type declarations are handled specially} +\subsection{Instance declarations are handled specially} %* * %********************************************************* -Data type declarations get special treatment. If we import a data type decl -with all its constructors, we end up importing all the types mentioned in -the constructors' signatures, and hence {\em their} data type decls, and so on. -In effect, we get the transitive closure of data type decls. Worse, this drags -in tons on instance decls, and their unfoldings, and so on. - -If only the type constructor is mentioned, then all this is a waste of time. -If any of the data constructors are mentioned then we really have to -drag in the whole declaration. - -So when we import the type constructor for a @data@ or @newtype@ decl, we -put it in the "deferred data/newtype decl" pile in Ifaces. Right at the end -we slurp these decls, if they havn't already been dragged in by an occurrence -of a constructor. - -\begin{code} -getNonWiredDataDecl needed_name - version - avail@(AvailTC tycon_name _) - ty_decl@(TyData new_or_data context tycon tyvars condecls derivings pragmas src_loc) - | null condecls || - -- HACK ALERT! If the data type is abstract then it must from a - -- hand-written hi-boot file. We put it in the deferred pile unconditionally, - -- because we don't want to read it in, and then later find a decl for a constructor - -- from that type, read the real interface file, and read in the full data type - -- decl again!!! - - (needed_name == tycon_name - && opt_PruneTyDecls - -- don't prune newtypes, as the code generator may - -- want to peer inside a newtype type constructor - -- (ClosureInfo.fun_result_ty is the culprit.) - && not (new_or_data == NewType) - && not (nameUnique needed_name `elem` cCallishTyKeys)) - -- Hack! Don't prune these tycons whose constructors - -- the desugarer must be able to see when desugaring - -- a CCall. Ugh! - - = -- Need the type constructor; so put it in the deferred set for now - getIfacesRn `thenRn` \ ifaces -> - let - deferred_data_decls = iDefData ifaces - new_ifaces = ifaces {iDefData = new_deferred_data_decls} - - no_constr_ty_decl = TyData new_or_data [] tycon tyvars [] derivings pragmas src_loc - new_deferred_data_decls = addToNameEnv deferred_data_decls tycon_name - (nameModule tycon_name, no_constr_ty_decl) - -- Nota bene: we nuke both the constructors and the context in the deferred decl. - -- If we don't nuke the context then renaming the deferred data decls can give - -- new unresolved names (for the classes). This could be handled, but there's - -- no point. If the data type is completely abstract then we aren't interested - -- its context. - in - setIfacesRn new_ifaces `thenRn_` - returnRn (AvailTC tycon_name [tycon_name], Nothing) - - | otherwise - = -- Need a data constructor, so delete the data decl from the deferred set if it's there - getIfacesRn `thenRn` \ ifaces -> - let - deferred_data_decls = iDefData ifaces - new_ifaces = ifaces {iDefData = new_deferred_data_decls} - - new_deferred_data_decls = delFromNameEnv deferred_data_decls tycon_name - in - setIfacesRn new_ifaces `thenRn_` - returnRn (avail, Just (TyClD ty_decl)) -\end{code} - \begin{code} -getDeferredDataDecls :: RnMG [(Module, RdrNameTyClDecl)] -getDeferredDataDecls - = getIfacesRn `thenRn` \ ifaces -> +getImportedInstDecls :: NameSet -> RnMG [(Module,RdrNameHsDecl)] +getImportedInstDecls gates + = -- First load any orphan-instance modules that aren't aready loaded + -- Orphan-instance modules are recorded in the module dependecnies + getIfacesRn `thenRn` \ ifaces -> let - deferred_list = nameEnvElts (iDefData ifaces) - trace_msg = hang (text "Slurping abstract data/newtype decls for: ") - 4 (ppr (map fst deferred_list)) + orphan_mods = [mod | (mod, (_, True, Nothing)) <- fmToList (iImpModInfo ifaces)] in - traceRn trace_msg `thenRn_` - returnRn deferred_list -\end{code} - - -%********************************************************* -%* * -\subsection{Instance declarations are handled specially} -%* * -%********************************************************* - -\begin{code} -getImportedInstDecls :: RnMG [(Module,RdrNameInstDecl)] -getImportedInstDecls - = -- First load any special-instance modules that aren't aready loaded - getSpecialInstModules `thenRn` \ inst_mods -> - mapRn_ load_it inst_mods `thenRn_` + traceRn (text "Loading orphan modules" <+> fsep (map pprModuleName orphan_mods)) `thenRn_` + mapRn_ load_it orphan_mods `thenRn_` -- Now we're ready to grab the instance declarations -- Find the un-gated ones and return them, -- removing them from the bag kept in Ifaces - getIfacesRn `thenRn` \ ifaces -> + getIfacesRn `thenRn` \ ifaces -> let - (insts, tycls_names) = iDefInsts ifaces + (decls, new_insts) = selectGated gates (iInsts ifaces) + in + setIfacesRn (ifaces { iInsts = new_insts }) `thenRn_` - -- An instance decl is ungated if all its gates have been slurped - select_ungated :: IfaceInst -- A gated inst decl + traceRn (sep [text "getImportedInstDecls:", + nest 4 (fsep (map ppr (nameSetToList gates))), + text "Slurped" <+> int (length decls) <+> text "instance declarations"]) `thenRn_` + returnRn decls + where + load_it mod = loadInterface (doc_str mod) mod ImportBySystem + doc_str mod = sep [pprModuleName mod, ptext SLIT("is a orphan-instance module")] - -> ([(Module, RdrNameInstDecl)], [IfaceInst]) -- Accumulator +getImportedRules :: RnMG [(Module,RdrNameHsDecl)] +getImportedRules + = getIfacesRn `thenRn` \ ifaces -> + let + gates = iSlurp ifaces -- Anything at all that's been slurped + (decls, new_rules) = selectGated gates (iRules ifaces) + in + setIfacesRn (ifaces { iRules = new_rules }) `thenRn_` + traceRn (sep [text "getImportedRules:", + text "Slurped" <+> int (length decls) <+> text "rules"]) `thenRn_` + returnRn decls - -> ([(Module, RdrNameInstDecl)], -- The ungated ones - [IfaceInst]) -- Still gated, but with - -- depeleted gates - select_ungated (decl,gates) (ungated_decls, gated_decls) - | isEmptyNameSet remaining_gates - = (decl : ungated_decls, gated_decls) - | otherwise - = (ungated_decls, (decl, remaining_gates) : gated_decls) - where - remaining_gates = gates `minusNameSet` tycls_names +selectGated gates decl_bag +#ifdef DEBUG + | opt_NoPruneDecls -- Just to try the effect of not gating at all + = (foldrBag (\ (_,d) ds -> d:ds) [] decl_bag, emptyBag) -- Grab them all - (un_gated_insts, still_gated_insts) = foldrBag select_ungated ([], []) insts - - new_ifaces = ifaces {iDefInsts = (listToBag still_gated_insts, tycls_names)} - -- NB: don't throw away tycls_names; - -- we may comre across more instance decls - in - traceRn (sep [text "getInstDecls:", fsep (map ppr (nameSetToList tycls_names))]) `thenRn_` - setIfacesRn new_ifaces `thenRn_` - returnRn un_gated_insts + | otherwise +#endif + = foldrBag select ([], emptyBag) decl_bag where - load_it mod = loadInterface (doc_str mod) mod - doc_str mod = sep [pprModule mod, ptext SLIT("is a special-instance module")] - - -getSpecialInstModules :: RnMG [Module] -getSpecialInstModules - = getIfacesRn `thenRn` \ ifaces -> - returnRn (iInstMods ifaces) - -getImportedFixities :: GlobalRdrEnv -> RnMG FixityEnv - -- Get all imported fixities - -- We first make sure that all the home modules - -- of all in-scope variables are loaded. -getImportedFixities gbl_env - = let - home_modules = [ nameModule name | names <- rdrEnvElts gbl_env, - name <- names, - not (isLocallyDefined name) - ] - in - mapRn_ load (nub home_modules) `thenRn_` - - -- Now we can snaffle the fixity env - getIfacesRn `thenRn` \ ifaces -> - returnRn (iFixes ifaces) + select (reqd, decl) (yes, no) + | isEmptyNameSet (reqd `minusNameSet` gates) = (decl:yes, no) + | otherwise = (yes, (reqd,decl) `consBag` no) + +lookupFixity :: Name -> RnMS Fixity +lookupFixity name + | isLocallyDefined name + = getFixityEnv `thenRn` \ local_fix_env -> + case lookupNameEnv local_fix_env name of + Just (FixitySig _ fix _) -> returnRn fix + Nothing -> returnRn defaultFixity + + | otherwise -- Imported + = loadHomeInterface doc name `thenRn` \ (_, ifaces) -> + case lookupNameEnv (iFixes ifaces) name of + Just (FixitySig _ fix _) -> returnRn fix + Nothing -> returnRn defaultFixity where - load mod = loadInterface doc_str mod - where - doc_str = ptext SLIT("Need fixities from") <+> ppr mod + doc = ptext SLIT("Checking fixity for") <+> ppr name \end{code} @@ -876,89 +630,74 @@ On the other hand, if A exports "module B" then we *do* count module B among A's usages, because we must recompile A to ensure that A.hi changes appropriately. \begin{code} -getImportVersions :: Module -- Name of this module +getImportVersions :: ModuleName -- Name of this module -> Maybe [IE any] -- Export list for this module -> RnMG (VersionInfo Name) -- Version info for these names getImportVersions this_mod exports = getIfacesRn `thenRn` \ ifaces -> let - mod_map = iModMap ifaces - imp_names = iVSlurp ifaces + mod_map = iImpModInfo ifaces + imp_names = iVSlurp ifaces -- mv_map groups together all the things imported from a particular module. - mv_map, mv_map_mod :: FiniteMap Module (WhatsImported Name) + mv_map1, mv_map2 :: FiniteMap ModuleName (WhatsImported Name) - mv_map_mod = foldl add_mod emptyFM export_mods - -- mv_map_mod records all the modules that have a "module M" + -- mv_map1 records all the modules that have a "module M" -- in this module's export list with an "Everything" - - mv_map = foldl add_mv mv_map_mod imp_names - -- mv_map adds the version numbers of things exported individually - - mk_version_info (mod, local_versions) - = case lookupFM mod_map mod of - Just (hif, version, _) -> (mod, version, local_versions) + mv_map1 = foldr add_mod emptyFM export_mods + + -- mv_map2 adds the version numbers of things exported individually + mv_map2 = foldr add_mv mv_map1 imp_names + + -- Build the result list by adding info for each module, + -- *omitting* (a) library modules + -- (b) source-imported modules + mk_version_info mod_name (version, has_orphans, cts) so_far + | omit cts = so_far -- Don't record usage info for this module + | otherwise = (mod_name, version, has_orphans, whats_imported) : so_far + where + whats_imported = case lookupFM mv_map2 mod_name of + Just wi -> wi + Nothing -> Specifically [] + + omit (Just (mod, boot_import, _)) = isLibModule mod || boot_import + omit Nothing = False in - returnRn (map mk_version_info (fmToList mv_map)) + returnRn (foldFM mk_version_info [] mod_map) where export_mods = case exports of Nothing -> [] Just es -> [mod | IEModuleContents mod <- es, mod /= this_mod] - add_mv mv_map v@(name, version) + add_mv v@(name, version) mv_map = addToFM_C add_item mv_map mod (Specifically [v]) where - mod = nameModule name + mod = moduleName (nameModule name) add_item Everything _ = Everything add_item (Specifically xs) _ = Specifically (v:xs) - add_mod mv_map mod = addToFM mv_map mod Everything + add_mod mod mv_map = addToFM mv_map mod Everything \end{code} \begin{code} -checkSlurped name - = getIfacesRn `thenRn` \ ifaces -> - returnRn (name `elemNameSet` iSlurp ifaces) - -getSlurpedNames :: RnMG NameSet -getSlurpedNames +getSlurped = getIfacesRn `thenRn` \ ifaces -> returnRn (iSlurp ifaces) -recordSlurp maybe_version necessity avail - = {- traceRn (hsep [text "Record slurp:", pprAvail avail, - -- NB PprForDebug prints export flag, which is too - -- strict; it's a knot-tied thing in RnNames - case necessity of {Compulsory -> text "comp"; Optional -> text "opt" } ]) `thenRn_` - -} - getIfacesRn `thenRn` \ ifaces -> +recordSlurp maybe_version avail + = getIfacesRn `thenRn` \ ifaces@(Ifaces { iSlurp = slurped_names, + iVSlurp = imp_names }) -> let - Ifaces { iSlurp = slurped_names, - iVSlurp = imp_names, - iDefInsts = (insts, tycls_names) } = ifaces - new_slurped_names = addAvailToNameSet slurped_names avail new_imp_names = case maybe_version of Just version -> (availName avail, version) : imp_names Nothing -> imp_names - - -- Add to the names that will let in instance declarations; - -- but only (a) if it's a type/class - -- (b) if it's compulsory (unless the test flag opt_PruneInstDecls is off) - new_tycls_names = case avail of - AvailTC tc _ | not opt_PruneInstDecls || - case necessity of {Optional -> False; Compulsory -> True } - -> tycls_names `addOneToNameSet` tc - otherwise -> tycls_names - - new_ifaces = ifaces { iSlurp = new_slurped_names, - iVSlurp = new_imp_names, - iDefInsts = (insts, new_tycls_names) } in - setIfacesRn new_ifaces + setIfacesRn (ifaces { iSlurp = new_slurped_names, + iVSlurp = new_imp_names }) \end{code} @@ -976,9 +715,9 @@ 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 -> RnMG Name) -- New-name function +getDeclBinders :: (RdrName -> SrcLoc -> RnM d Name) -- New-name function -> RdrNameHsDecl - -> RnMG (Maybe AvailInfo) + -> RnM d (Maybe AvailInfo) getDeclBinders new_name (TyClD (TyData _ _ tycon _ condecls _ _ src_loc)) = new_name tycon src_loc `thenRn` \ tycon_name -> @@ -991,7 +730,7 @@ getDeclBinders new_name (TyClD (TySynonym tycon _ _ src_loc)) = new_name tycon src_loc `thenRn` \ tycon_name -> returnRn (Just (AvailTC tycon_name [tycon_name])) -getDeclBinders new_name (TyClD (ClassDecl _ cname _ sigs _ _ tname dname src_loc)) +getDeclBinders new_name (TyClD (ClassDecl _ cname _ sigs _ _ _ _ _ src_loc)) = new_name cname src_loc `thenRn` \ class_name -> -- Record the names for the class ops @@ -1011,6 +750,7 @@ getDeclBinders new_name (FixD _) = returnRn Nothing getDeclBinders new_name (ForD _) = returnRn Nothing getDeclBinders new_name (DefD _) = returnRn Nothing getDeclBinders new_name (InstD _) = returnRn Nothing +getDeclBinders new_name (RuleD _) = returnRn Nothing ---------------- getConFieldNames new_name (ConDecl con _ _ (RecCon fielddecls) src_loc : rest) @@ -1040,11 +780,16 @@ A the moment that's just the tycon and datacon that come with a class decl. They aren'te returned by getDeclBinders because they aren't in scope; but they *should* be put into the DeclsMap of this module. +Note that this excludes the default-method names of a class decl, +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 _ _ tname dname src_loc)) - = new_name dname src_loc `thenRn` \ datacon_name -> - new_name tname src_loc `thenRn` \ tycon_name -> - returnRn [tycon_name, datacon_name] +getDeclSysBinders new_name (TyClD (ClassDecl _ cname _ sigs _ _ tname dname snames src_loc)) + = new_name dname src_loc `thenRn` \ datacon_name -> + new_name tname src_loc `thenRn` \ tycon_name -> + sequenceRn [new_name n src_loc | n <- snames] `thenRn` \ scsel_names -> + returnRn (tycon_name : datacon_name : scsel_names) getDeclSysBinders new_name other_decl = returnRn [] @@ -1057,100 +802,79 @@ getDeclSysBinders new_name other_decl %********************************************************* \begin{code} -findAndReadIface :: SDoc -> Module -> RnMG (Maybe (Module, ParsedIface)) +findAndReadIface :: SDoc -> ModuleName -> WhereFrom + -> Bool -- Only relevant for SystemImport + -- True <=> Look for a .hi file + -- False <=> Look for .hi-boot file unless there's + -- a library .hi file + -> RnM d (Bool, Maybe (Module, ParsedIface)) + -- Bool is True if the interface actually read was a .hi-boot one -- Nothing <=> file not found, or unreadable, or illegible -- Just x <=> successfully found and parsed -findAndReadIface doc_str mod_name +findAndReadIface doc_str mod_name from hi_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. - getModuleHiMap from_hi_boot `thenRn` \ himap -> - case (lookupFM himap (moduleUserString mod_name)) of + + getHiMaps `thenRn` \ hi_maps -> + + case find_path from hi_maps of -- Found the file - Just fpath -> readIface mod_name fpath - Nothing -> traceRn (ptext SLIT("...failed")) `thenRn_` - returnRn Nothing + (hi_boot, Just (fpath, mod)) -> traceRn (ptext SLIT("...reading from") <+> text fpath) `thenRn_` + readIface mod fpath `thenRn` \ result -> + returnRn (hi_boot, result) + (hi_boot, Nothing) -> traceRn (ptext SLIT("...not found")) `thenRn_` + returnRn (hi_boot, Nothing) where - hif = moduleIfaceFlavour mod_name - from_hi_boot = bootFlavour hif + find_path ImportByUser (hi_map, _) = (False, lookupFM hi_map mod_name) + find_path ImportByUserSource (_, hiboot_map) = (True, lookupFM hiboot_map mod_name) + + find_path ImportBySystem (hi_map, hiboot_map) + | hi_file + = -- If the module we seek is in our dependent set, + -- Look for a .hi file + (False, lookupFM hi_map mod_name) + + | otherwise + -- Check if there's a library module of that name + -- If not, look for an hi-boot file + = case lookupFM hi_map mod_name of + stuff@(Just (_, mod)) | isLibModule mod -> (False, stuff) + other -> (True, lookupFM hiboot_map mod_name) trace_msg = sep [hsep [ptext SLIT("Reading"), - if from_hi_boot then ptext SLIT("[boot]") else empty, + ppr from, ptext SLIT("interface for"), - pprModule mod_name <> semi], + pprModuleName mod_name <> semi], nest 4 (ptext SLIT("reason:") <+> doc_str)] \end{code} @readIface@ tries just the one file. \begin{code} -readIface :: Module -> (String, Bool) -> RnMG (Maybe (Module, ParsedIface)) +readIface :: Module -> String -> RnM d (Maybe (Module, ParsedIface)) -- Nothing <=> file not found, or unreadable, or illegible -- Just x <=> successfully found and parsed -readIface requested_mod (file_path, is_dll) - = ioToRnMG (hGetStringBuffer file_path) `thenRn` \ read_result -> +readIface the_mod file_path + = ioToRnM (hGetStringBuffer file_path) `thenRn` \ read_result -> case read_result of Right contents -> case parseIface contents (mkSrcLoc (mkFastString file_path) 1) of Failed err -> failWithRn Nothing err Succeeded (PIface mod_nm iface) -> - (if mod_nm /= moduleFS requested_mod then - addWarnRn (hsep [ ptext SLIT("Something is amiss; requested module name") - , pprModule requested_mod + warnCheckRn (mod_nm == moduleName the_mod) + (hsep [ ptext SLIT("Something is amiss; requested module name") + , pprModule the_mod , ptext SLIT("differs from name found in the interface file ") - , pprEncodedFS mod_nm - ]) - else - returnRn ()) `thenRn_` - let - the_mod - | is_dll = mkDynamicModule requested_mod - | otherwise = requested_mod - in - if opt_D_show_rn_imports then - putDocRn (hcat[ptext SLIT("Read module "), pprEncodedFS mod_nm, - ptext SLIT(" from "), text file_path]) `thenRn_` - returnRn (Just (the_mod, iface)) - else - returnRn (Just (the_mod, iface)) + , pprModuleName mod_nm + ]) `thenRn_` + returnRn (Just (the_mod, iface)) Left err | isDoesNotExistError err -> returnRn Nothing | otherwise -> failWithRn Nothing (cannaeReadFile file_path err) - -\end{code} - -%********************************************************* -%* * -\subsection{Utils} -%* * -%********************************************************* - -@mkSearchPath@ takes a string consisting of a colon-separated list -of directories and corresponding suffixes, and turns it into a list -of (directory, suffix) pairs. For example: - -\begin{verbatim} - mkSearchPath "foo%.hi:.%.p_hi:baz%.mc_hi" - = [("foo",".hi"),( ".", ".p_hi"), ("baz",".mc_hi")] -\begin{verbatim} - -\begin{code} -mkSearchPath :: Maybe String -> SearchPath -mkSearchPath Nothing = [(".",".hi")] -- ToDo: default should be to look in - -- the directory the module we're compiling - -- lives. -mkSearchPath (Just s) = go s - where - go "" = [] - go s = - case span (/= '%') s of - (dir,'%':rs) -> - case span (/= ':') rs of - (hisuf,_:rest) -> (dir,hisuf):go rest - (hisuf,[]) -> [(dir,hisuf)] \end{code} %********************************************************* @@ -1160,9 +884,12 @@ mkSearchPath (Just s) = go s %********************************************************* \begin{code} -noIfaceErr filename - = hcat [ptext SLIT("Could not find valid interface file "), - quotes (pprModule filename)] +noIfaceErr filename boot_file + = hsep [ptext SLIT("Could not find valid"), boot, + ptext SLIT("interface file"), quotes (pprModule filename)] + where + boot | boot_file = ptext SLIT("[boot]") + | otherwise = empty cannaeReadFile file err = hcat [ptext SLIT("Failed in reading file: "), @@ -1170,20 +897,20 @@ cannaeReadFile file err ptext SLIT("; error="), text (show err)] -getDeclErr name loc - = sep [ptext SLIT("Failed to find interface decl for") <+> quotes (ppr name), - ptext SLIT("needed at") <+> ppr loc] +getDeclErr name + = ptext SLIT("Failed to find interface decl for") <+> quotes (ppr name) getDeclWarn name loc = sep [ptext SLIT("Failed to find (optional) interface decl for") <+> quotes (ppr name), ptext SLIT("desired at") <+> ppr loc] -importDeclWarn mod name loc +importDeclWarn mod name = sep [ptext SLIT("Compiler tried to import decl from interface file with same name as module."), ptext SLIT("(possible cause: module name clashes with interface file already in scope.)") ] $$ - hsep [ptext SLIT("Interface:"), quotes (pprModule mod), comma, ptext SLIT("name:"), quotes (ppr name), - comma, ptext SLIT("desired at:"), ppr loc - ] + hsep [ptext SLIT("Interface:"), quotes (pprModuleName mod), + comma, ptext SLIT("name:"), quotes (ppr name)] +warnRedundantSourceImport mod_name + = ptext SLIT("Unnecessary {- SOURCE -} in the import of module") <+> quotes (pprModuleName mod_name) \end{code} diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs index 189649b..d6ab30b 100644 --- a/ghc/compiler/rename/RnMonad.lhs +++ b/ghc/compiler/rename/RnMonad.lhs @@ -20,10 +20,9 @@ module RnMonad( #include "HsVersions.h" -import SST -import GlaExts ( RealWorld, stToIO ) -import List ( intersperse ) - +import PrelIOBase ( fixIO ) -- Should be in GlaExts +import IOExts ( IORef, newIORef, readIORef, writeIORef, unsafePerformIO ) + import HsSyn import RdrHsSyn import RnHsSyn ( RenamedFixitySig ) @@ -34,37 +33,29 @@ import ErrUtils ( addShortErrLocLine, addShortWarnLocLine, ) import Name ( Name, OccName, NamedThing(..), isLocallyDefinedName, nameModule, nameOccName, - decode + decode, mkLocalName ) -import Module ( Module, IfaceFlavour, setModuleFlavour, mkSysModuleFS, - bootFlavour, moduleString, moduleIfaceFlavour, mkDynFlavour +import Module ( Module, ModuleName, ModuleHiMap, SearchPath, WhereFrom, + mkModuleHiMaps, moduleName ) import NameSet -import RdrName ( RdrName ) -import CmdLineOpts ( opt_D_show_rn_trace, opt_IgnoreIfacePragmas, - opt_WarnHiShadows, opt_Static - ) +import RdrName ( RdrName, dummyRdrVarName, rdrNameOcc ) +import CmdLineOpts ( opt_D_dump_rn_trace, opt_IgnoreIfacePragmas ) import PrelInfo ( builtinNames ) import TysWiredIn ( boolTyCon ) import SrcLoc ( SrcLoc, mkGeneratedSrcLoc ) -import Unique ( Unique ) +import Unique ( Unique, getUnique, unboundKey ) import UniqFM ( UniqFM ) import FiniteMap ( FiniteMap, emptyFM, bagToFM, lookupFM, addToFM, addListToFM, addListToFM_C, addToFM_C, eltsFM ) import Bag ( Bag, mapBag, emptyBag, isEmptyBag, snocBag ) -import Maybes ( seqMaybe, mapMaybe ) +import Maybes ( mapMaybe ) import UniqSet import UniqFM import UniqSupply import Util import Outputable -import DirUtils ( getDirectoryContents ) -import Directory ( doesFileExist ) -import IO ( hPutStrLn, stderr, isDoesNotExistError ) -import Monad ( foldM ) -import Maybe ( fromMaybe ) -import Constants ( interfaceFileFormatVersion ) infixr 9 `thenRn`, `thenRn_` \end{code} @@ -77,18 +68,17 @@ infixr 9 `thenRn`, `thenRn_` %************************************************************************ \begin{code} -sstToIO :: SST RealWorld r -> IO r -sstToIO sst = stToIO (sstToST sst) - -ioToRnMG :: IO r -> RnMG (Either IOError r) -ioToRnMG io rn_down g_down = ioToSST io +ioToRnM :: IO r -> RnM d (Either IOError r) +ioToRnM io rn_down g_down = (io >>= \ ok -> return (Right ok)) + `catch` + (\ err -> return (Left err)) -traceRn :: SDoc -> RnMG () -traceRn msg | opt_D_show_rn_trace = putDocRn msg +traceRn :: SDoc -> RnM d () +traceRn msg | opt_D_dump_rn_trace = putDocRn msg | otherwise = returnRn () -putDocRn :: SDoc -> RnMG () -putDocRn msg = ioToRnMG (printErrs msg) `thenRn_` +putDocRn :: SDoc -> RnM d () +putDocRn msg = ioToRnM (printErrs msg) `thenRn_` returnRn () \end{code} @@ -104,64 +94,44 @@ putDocRn msg = ioToRnMG (printErrs msg) `thenRn_` =================================================== \begin{code} -type RnM s d r = RnDown s -> d -> SST s r -type RnMS s r = RnM s (SDown s) r -- Renaming source -type RnMG r = RnM RealWorld GDown r -- Getting global names etc -type SSTRWRef a = SSTRef RealWorld a -- ToDo: there ought to be a standard defn of this +type RnM d r = RnDown -> d -> IO r +type RnMS r = RnM SDown r -- Renaming source +type RnMG r = RnM () r -- Getting global names etc -- Common part -data RnDown s = RnDown { - rn_loc :: SrcLoc, - rn_omit :: Name -> Bool, -- True <=> omit qualifier when printing - rn_ns :: SSTRef s RnNameSupply, - rn_errs :: SSTRef s (Bag WarnMsg, Bag ErrMsg), - rn_occs :: SSTRef s ([Occurrence],[Occurrence]), -- Occurrences: compulsory and optional resp - rn_hi_map :: ModuleHiMap, -- for .hi files - rn_hiboot_map :: ModuleHiMap, -- for .hi-boot files - rn_mod :: Module +data RnDown = RnDown { + rn_mod :: ModuleName, + rn_loc :: SrcLoc, + rn_omit :: Name -> Bool, -- True <=> omit qualifier when printing + rn_ns :: IORef RnNameSupply, + rn_errs :: IORef (Bag WarnMsg, Bag ErrMsg), + rn_ifaces :: IORef Ifaces, + rn_hi_maps :: (ModuleHiMap, -- for .hi files + ModuleHiMap) -- for .hi-boot files } -type Occurrence = (Name, SrcLoc) -- The srcloc is the occurrence site - -data Necessity = Compulsory | Optional -- We *must* find definitions for - -- compulsory occurrences; we *may* find them - -- for optional ones. - - -- For getting global names -data GDown = GDown { - rn_ifaces :: SSTRWRef Ifaces - } - -- For renaming source code -data SDown s = SDown { +data SDown = SDown { rn_mode :: RnMode, - rn_genv :: RnEnv, -- Global envt; the fixity component gets extended - -- with local fixity decls - rn_lenv :: LocalRdrEnv -- Local name envt + + rn_genv :: GlobalRdrEnv, -- Global envt; the fixity component gets extended + -- with local fixity decls + + rn_lenv :: LocalRdrEnv, -- Local name envt -- Does *not* includes global name envt; may shadow it -- Includes both ordinary variables and type variables; -- they are kept distinct because tyvar have a different -- occurrence contructor (Name.TvOcc) -- We still need the unsullied global name env so that -- we can look up record field names + + rn_fixenv :: FixityEnv -- Local fixities + -- The global ones are held in the + -- rn_ifaces field } data RnMode = SourceMode -- Renaming source code | InterfaceMode -- Renaming interface declarations. - Necessity -- The "necessity" - -- flag says free variables *must* be found and slurped - -- or whether they need not be. For value signatures of - -- things that are themselves compulsorily imported - -- we arrange that the type signature is read - -- in compulsory mode, - -- but the pragmas in optional mode. - -type SearchPath = [(String,String)] -- List of (directory,suffix) pairs to search - -- for interface files. - -type ModuleHiMap = FiniteMap String (String, Bool) - -- mapping from module name to the file path of its corresponding - -- interface file. \end{code} =================================================== @@ -179,11 +149,13 @@ type LocalRdrEnv = RdrNameEnv Name emptyRdrEnv :: RdrNameEnv a lookupRdrEnv :: RdrNameEnv a -> RdrName -> Maybe a addListToRdrEnv :: RdrNameEnv a -> [(RdrName,a)] -> RdrNameEnv a +extendRdrEnv :: RdrNameEnv a -> RdrName -> a -> RdrNameEnv a emptyRdrEnv = emptyFM lookupRdrEnv = lookupFM addListToRdrEnv = addListToFM rdrEnvElts = eltsFM +extendRdrEnv = addToFM -------------------------------- type NameEnv a = UniqFM a -- Domain is Name @@ -210,10 +182,9 @@ elemNameEnv = elemUFM -------------------------------- type FixityEnv = NameEnv RenamedFixitySig - --------------------------------- -data RnEnv = RnEnv GlobalRdrEnv FixityEnv -emptyRnEnv = RnEnv emptyRdrEnv emptyNameEnv + -- We keep the whole fixity sig so that we + -- can report line-number info when there is a duplicate + -- fixity declaration \end{code} \begin{code} @@ -232,7 +203,7 @@ type RnNameSupply -- way the uniques change less when you add an instance decl, -- hence less recompilation - , FiniteMap (Module,OccName) Name + , FiniteMap (ModuleName, OccName) Name -- Ensures that one (module,occname) pair gets one unique ) @@ -242,9 +213,9 @@ data ExportEnv = ExportEnv Avails Fixities type Avails = [AvailInfo] type Fixities = [(Name, Fixity)] -type ExportAvails = (FiniteMap Module Avails, -- Used to figure out "module M" export specifiers - -- Includes avails only from *unqualified* imports - -- (see 1.4 Report Section 5.1.1) +type ExportAvails = (FiniteMap ModuleName Avails, -- Used to figure out "module M" export specifiers + -- Includes avails only from *unqualified* imports + -- (see 1.4 Report Section 5.1.1) NameEnv AvailInfo) -- Used to figure out all other export specifiers. -- Maps a Name to the AvailInfo that contains it @@ -264,10 +235,18 @@ type RdrAvailInfo = GenAvailInfo OccName =================================================== \begin{code} -type ExportItem = (Module, [RdrAvailInfo]) +type ExportItem = (ModuleName, [RdrAvailInfo]) type VersionInfo name = [ImportVersion name] -type ImportVersion name = (Module, Version, WhatsImported name) +type ImportVersion name = (ModuleName, Version, WhetherHasOrphans, WhatsImported name) + +type WhetherHasOrphans = Bool + -- An "orphan" is + -- * an instance decl in a module other than the defn module for + -- one of the tycons or classes in the instance head + -- * a transformation rule in a module other than the one defining + -- the function in the head of the rule. + data WhatsImported name = Everything | Specifically [LocalVersion name] -- List guaranteed non-empty @@ -279,33 +258,33 @@ data WhatsImported name = Everything type LocalVersion name = (name, Version) data ParsedIface - = ParsedIface - Version -- Module version number - [ImportVersion OccName] -- Usages - [ExportItem] -- Exports - [Module] -- Special instance modules - [(Version, RdrNameHsDecl)] -- Local definitions - [RdrNameInstDecl] -- Local instance declarations + = ParsedIface { + pi_mod :: Version, -- Module version number + pi_orphan :: WhetherHasOrphans, -- Whether this module has orphans + pi_usages :: [ImportVersion OccName], -- Usages + pi_exports :: [ExportItem], -- Exports + pi_decls :: [(Version, RdrNameHsDecl)], -- Local definitions + pi_insts :: [RdrNameInstDecl], -- Local instance declarations + pi_rules :: [RdrNameRuleDecl] -- Rules + } -type InterfaceDetails = (VersionInfo Name, -- Version information for what this module imports - ExportEnv, -- What this module exports - [Module]) -- Instance modules +type InterfaceDetails = (WhetherHasOrphans, + VersionInfo Name, -- Version information for what this module imports + ExportEnv) -- What modules this one depends on -- needed by Main to fish out the fixities assoc list. getIfaceFixities :: InterfaceDetails -> Fixities -getIfaceFixities (_, ExportEnv _ fs, _) = fs +getIfaceFixities (_, _, ExportEnv _ fs) = fs type RdrNamePragma = () -- Fudge for now ------------------- data Ifaces = Ifaces { - iMod :: Module, -- Name of the module being compiled - - iModMap :: FiniteMap Module (IfaceFlavour, -- Exports - Version, - Avails), + iImpModInfo :: ImportedModuleInfo, + -- Modules this one depends on: that is, the union + -- of the modules its direct imports depend on. iDecls :: DeclsMap, -- A single, global map of Names to decls @@ -314,38 +293,48 @@ data Ifaces = Ifaces { iSlurp :: NameSet, -- All the names (whether "big" or "small", whether wired-in or not, -- whether locally defined or not) that have been slurped in so far. - iVSlurp :: [(Name,Version)], -- All the (a) non-wired-in (b) "big" (c) non-locally-defined names that - -- have been slurped in so far, with their versions. + iVSlurp :: [(Name,Version)], -- All the (a) non-wired-in (b) "big" (c) non-locally-defined + -- names that have been slurped in so far, with their versions. -- This is used to generate the "usage" information for this module. -- Subset of the previous field. - iDefInsts :: (Bag IfaceInst, NameSet), - -- The as-yet un-slurped instance decls; this bag is depleted when we - -- slurp an instance decl so that we don't slurp the same one twice. - -- Together with them is the set of tycons/classes that may allow - -- the instance decls in. - - iDefData :: NameEnv (Module, RdrNameTyClDecl), - -- Deferred data type declarations; each has the following properties - -- * it's a data type decl - -- * its TyCon is needed - -- * the decl may or may not have been slurped, depending on whether any - -- of the constrs are needed. - - iInstMods :: [Module] -- Set of modules with "special" instance declarations - -- Excludes this module + iInsts :: Bag GatedDecl, + -- The as-yet un-slurped instance decls; this bag is depleted when we + -- slurp an instance decl so that we don't slurp the same one twice. + -- Each is 'gated' by the names that must be available before + -- this instance decl is needed. + + iRules :: Bag GatedDecl + -- Ditto transformation rules } +type GatedDecl = (NameSet, (Module, RdrNameHsDecl)) -type DeclsMap = NameEnv (Version, AvailInfo, RdrNameHsDecl, Bool) +type ImportedModuleInfo + = FiniteMap ModuleName (Version, Bool, Maybe (Module, Bool, Avails)) + -- Suppose the domain element is module 'A' + -- + -- The first Bool is True if A contains + -- 'orphan' rules or instance decls + + -- The second Bool is true if the interface file actually + -- read was an .hi-boot file + + -- Nothing => A's interface not yet read, but this module has + -- imported a module, B, that itself depends on A + -- + -- Just xx => A's interface has been read. The Module in + -- the Just has the correct Dll flag + + -- This set is used to decide whether to look for + -- A.hi or A.hi-boot when importing A.f. + -- Basically, we look for A.hi if A is in the map, and A.hi-boot + -- otherwise + +type DeclsMap = NameEnv (Version, AvailInfo, Bool, (Module, RdrNameHsDecl)) -- A DeclsMap contains a binding for each Name in the declaration -- including the constructors of a type decl etc. -- The Bool is True just for the 'main' Name. - -type IfaceInst = ((Module, RdrNameInstDecl), -- Instance decl - NameSet) -- "Gate" names. Slurp this instance decl when this - -- set becomes empty. It's depleted whenever we - -- slurp another type or class decl. \end{code} @@ -356,196 +345,104 @@ type IfaceInst = ((Module, RdrNameInstDecl), -- Instance decl %************************************************************************ \begin{code} -initRn :: Module -> UniqSupply -> SearchPath -> SrcLoc +initRn :: ModuleName -> UniqSupply -> SearchPath -> SrcLoc -> RnMG r -> IO (r, Bag ErrMsg, Bag WarnMsg) initRn mod us dirs loc do_rn = do - (himap, hibmap) <- mkModuleHiMaps dirs - names_var <- sstToIO (newMutVarSST (us, emptyFM, builtins)) - errs_var <- sstToIO (newMutVarSST (emptyBag,emptyBag)) - iface_var <- sstToIO (newMutVarSST (emptyIfaces mod)) - occs_var <- sstToIO (newMutVarSST initOccs) + himaps <- mkModuleHiMaps dirs + names_var <- newIORef (us, emptyFM, builtins) + errs_var <- newIORef (emptyBag,emptyBag) + iface_var <- newIORef emptyIfaces let rn_down = RnDown { rn_loc = loc, rn_omit = \n -> False, rn_ns = names_var, - rn_errs = errs_var, rn_occs = occs_var, - rn_hi_map = himap, rn_hiboot_map = hibmap, + rn_errs = errs_var, + rn_hi_maps = himaps, + rn_ifaces = iface_var, rn_mod = mod } - g_down = GDown {rn_ifaces = iface_var } -- do the business - res <- sstToIO (do_rn rn_down g_down) + res <- do_rn rn_down () -- grab errors and return - (warns, errs) <- sstToIO (readMutVarSST errs_var) + (warns, errs) <- readIORef errs_var + return (res, errs, warns) -initRnMS :: RnEnv -> RnMode -> RnMS RealWorld r -> RnMG r -initRnMS rn_env mode m rn_down g_down +initRnMS :: GlobalRdrEnv -> FixityEnv -> RnMode -> RnMS r -> RnM d r +initRnMS rn_env fixity_env mode thing_inside rn_down g_down = let - s_down = SDown { rn_genv = rn_env, rn_lenv = emptyRdrEnv, rn_mode = mode } + s_down = SDown { rn_genv = rn_env, rn_lenv = emptyRdrEnv, + rn_fixenv = fixity_env, rn_mode = mode } in - m rn_down s_down - - -emptyIfaces :: Module -> Ifaces -emptyIfaces mod = Ifaces { iMod = mod, - iModMap = emptyFM, - iDecls = emptyNameEnv, - iFixes = emptyNameEnv, - iSlurp = emptyNameSet, - iVSlurp = [], - iDefInsts = (emptyBag, emptyNameSet), - iDefData = emptyNameEnv, - iInstMods = [] - } -builtins :: FiniteMap (Module,OccName) Name + thing_inside rn_down s_down + +initIfaceRnMS :: Module -> RnMS r -> RnM d r +initIfaceRnMS mod thing_inside + = initRnMS emptyRdrEnv emptyNameEnv InterfaceMode $ + setModuleRn (moduleName mod) thing_inside + +emptyIfaces :: Ifaces +emptyIfaces = Ifaces { iImpModInfo = emptyFM, + iDecls = emptyNameEnv, + iFixes = emptyNameEnv, + iSlurp = unitNameSet (mkUnboundName dummyRdrVarName), + -- Pretend that the dummy unbound name has already been + -- slurped. This is what's returned for an out-of-scope name, + -- and we don't want thereby to try to suck it in! + iVSlurp = [], + iInsts = emptyBag, + iRules = emptyBag + } + +-- mkUnboundName makes a place-holder Name; it shouldn't be looked at except possibly +-- during compiler debugging. +mkUnboundName :: RdrName -> Name +mkUnboundName rdr_name = mkLocalName unboundKey (rdrNameOcc rdr_name) noSrcLoc + +isUnboundName :: Name -> Bool +isUnboundName name = getUnique name == unboundKey + +builtins :: FiniteMap (ModuleName,OccName) Name builtins = bagToFM ( - mapBag (\ name -> ((nameModule name, nameOccName name), name)) + mapBag (\ name -> ((moduleName (nameModule name), nameOccName name), name)) builtinNames) - - -- Initial value for the occurrence pool. -initOccs :: ([Occurrence],[Occurrence]) -- Compulsory and optional respectively -initOccs = ([(getName boolTyCon, noSrcLoc)], []) - -- Booleans occur implicitly a lot, so it's tiresome to keep recording the fact, and - -- rather implausible that not one will be used in the module. - -- We could add some other common types, notably lists, but the general idea is - -- to do as much as possible explicitly. \end{code} -We (allege) that it is quicker to build up a mapping from module names -to the paths to their corresponding interface files once, than to search -along the import part every time we slurp in a new module (which we -do quite a lot of.) - -\begin{code} -mkModuleHiMaps :: SearchPath -> IO (ModuleHiMap, ModuleHiMap) -mkModuleHiMaps dirs = foldM (getAllFilesMatching dirs) (env,env) dirs - where - env = emptyFM - -{- a pseudo file which signals that the interface files - contained in a particular directory have got their - corresponding object codes stashed away in a DLL - - This stuff is only needed to deal with Win32 DLLs, - and conceivably we conditionally compile in support - for handling it. (ToDo?) --} -dir_contain_dll_his = "dLL_ifs.hi" - -getAllFilesMatching :: SearchPath - -> (ModuleHiMap, ModuleHiMap) - -> (FilePath, String) - -> IO (ModuleHiMap, ModuleHiMap) -getAllFilesMatching dirs hims (dir_path, suffix) = ( do - -- fpaths entries do not have dir_path prepended - fpaths <- getDirectoryContents dir_path - is_dyns <- catch - (if opt_Static || dir_path == "." then - return False - else - doesFileExist (dir_path ++ '/': dir_contain_dll_his)) - (\ _ {-don't care-} -> return False) - return (foldl (addModules is_dyns) hims fpaths) - ) -- soft failure - `catch` - (\ err -> do - hPutStrLn stderr - ("Import path element `" ++ dir_path ++ - if (isDoesNotExistError err) then - "' does not exist, ignoring." - else - "' couldn't read, ignoring.") - - return hims - ) - where - xiffus = reverse dotted_suffix - - dotted_suffix = - case suffix of - [] -> [] - ('.':xs) -> suffix - ls -> '.':ls - - hi_boot_version_xiffus = - reverse (show interfaceFileFormatVersion) ++ '-':hi_boot_xiffus - hi_boot_xiffus = "toob-ih." -- .hi-boot reversed. - - addModules is_dll his@(hi_env, hib_env) nm = fromMaybe his $ - FMAP (\ (mod_nm,v) -> (addToFM_C addNewOne hi_env mod_nm (v, is_dll), hib_env)) - (go xiffus rev_nm) `seqMaybe` - - FMAP (\ (mod_nm,v) -> (hi_env, addToFM_C overrideNew hib_env mod_nm (v,is_dll))) - (go hi_boot_version_xiffus rev_nm) `seqMaybe` - - FMAP (\ (mod_nm,v) -> (hi_env, addToFM_C addNewOne hib_env mod_nm (v,is_dll))) - (go hi_boot_xiffus rev_nm) - where - rev_nm = reverse nm - - go [] xs = Just (reverse xs, dir_path ++'/':nm) - go _ [] = Nothing - go (x:xs) (y:ys) - | x == y = go xs ys - | otherwise = Nothing - - addNewOne - | opt_WarnHiShadows = conflict - | otherwise = stickWithOld - - stickWithOld old new = old - overrideNew old new = new - - conflict old_path new_path - | old_path /= new_path = - pprTrace "Warning: " (text "Identically named interface files present on the import path, " $$ - text (show old_path) <+> text "shadows" $$ - text (show new_path) $$ - text "on the import path: " <+> - text (concat (intersperse ":" (map fst dirs)))) - old_path - | otherwise = old_path -- don't warn about innocous shadowings. - -\end{code} - - @renameSourceCode@ is used to rename stuff "out-of-line"; that is, not as part of -the main renamer. Examples: pragmas (which we don't want to rename unless -we actually explore them); and derived definitions, which are only generated +the main renamer. Sole examples: derived definitions, which are only generated in the type checker. The @RnNameSupply@ includes a @UniqueSupply@, so if you call it more than once you must either split it, or install a fresh unique supply. \begin{code} -renameSourceCode :: Module +renameSourceCode :: ModuleName -> RnNameSupply - -> RnMS RealWorld r + -> RnMS r -> r --- Alas, we can't use the real runST, with the desired signature: --- renameSourceCode :: RnNameSupply -> RnMS s r -> r --- because we can't manufacture "new versions of runST". - renameSourceCode mod_name name_supply m - = runSST ( - newMutVarSST name_supply `thenSST` \ names_var -> - newMutVarSST (emptyBag,emptyBag) `thenSST` \ errs_var -> - newMutVarSST ([],[]) `thenSST` \ occs_var -> + = unsafePerformIO ( + -- It's not really unsafe! When renaming source code we + -- only do any I/O if we need to read in a fixity declaration; + -- and that doesn't happen in pragmas etc + + newIORef name_supply >>= \ names_var -> + newIORef (emptyBag,emptyBag) >>= \ errs_var -> let rn_down = RnDown { rn_loc = mkGeneratedSrcLoc, rn_ns = names_var, - rn_errs = errs_var, rn_occs = occs_var, + rn_errs = errs_var, rn_mod = mod_name } - s_down = SDown { rn_mode = InterfaceMode Compulsory, - rn_genv = emptyRnEnv, rn_lenv = emptyRdrEnv } + s_down = SDown { rn_mode = InterfaceMode, -- So that we can refer to PrelBase.True etc + rn_genv = emptyRdrEnv, rn_lenv = emptyRdrEnv, + rn_fixenv = emptyNameEnv } in - m rn_down s_down `thenSST` \ result -> + m rn_down s_down >>= \ result -> - readMutVarSST errs_var `thenSST` \ (warns,errs) -> + readIORef errs_var >>= \ (warns,errs) -> (if not (isEmptyBag errs) then pprTrace "Urk! renameSourceCode found errors" (display errs) @@ -556,7 +453,7 @@ renameSourceCode mod_name name_supply m else id) $ - returnSST result + return result ) where display errs = pprBagOfErrors errs @@ -566,26 +463,26 @@ renameSourceCode mod_name name_supply m {-# INLINE returnRn #-} {-# INLINE andRn #-} -returnRn :: a -> RnM s d a -thenRn :: RnM s d a -> (a -> RnM s d b) -> RnM s d b -thenRn_ :: RnM s d a -> RnM s d b -> RnM s d b -andRn :: (a -> a -> a) -> RnM s d a -> RnM s d a -> RnM s d a -mapRn :: (a -> RnM s d b) -> [a] -> RnM s d [b] -mapRn_ :: (a -> RnM s d b) -> [a] -> RnM s d () -mapMaybeRn :: (a -> RnM s d (Maybe b)) -> [a] -> RnM s d [b] -sequenceRn :: [RnM s d a] -> RnM s d [a] -foldlRn :: (b -> a -> RnM s d b) -> b -> [a] -> RnM s d b -mapAndUnzipRn :: (a -> RnM s d (b,c)) -> [a] -> RnM s d ([b],[c]) -fixRn :: (a -> RnM s d a) -> RnM s d a - -returnRn v gdown ldown = returnSST v -thenRn m k gdown ldown = m gdown ldown `thenSST` \ r -> k r gdown ldown -thenRn_ m k gdown ldown = m gdown ldown `thenSST_` k gdown ldown -fixRn m gdown ldown = fixSST (\r -> m r gdown ldown) +returnRn :: a -> RnM d a +thenRn :: RnM d a -> (a -> RnM d b) -> RnM d b +thenRn_ :: RnM d a -> RnM d b -> RnM d b +andRn :: (a -> a -> a) -> RnM d a -> RnM d a -> RnM d a +mapRn :: (a -> RnM d b) -> [a] -> RnM d [b] +mapRn_ :: (a -> RnM d b) -> [a] -> RnM d () +mapMaybeRn :: (a -> RnM d (Maybe b)) -> [a] -> RnM d [b] +sequenceRn :: [RnM d a] -> RnM d [a] +foldlRn :: (b -> a -> RnM d b) -> b -> [a] -> RnM d b +mapAndUnzipRn :: (a -> RnM d (b,c)) -> [a] -> RnM d ([b],[c]) +fixRn :: (a -> RnM d a) -> RnM d a + +returnRn v gdown ldown = return v +thenRn m k gdown ldown = m gdown ldown >>= \ r -> k r gdown ldown +thenRn_ m k gdown ldown = m gdown ldown >> k gdown ldown +fixRn m gdown ldown = fixIO (\r -> m r gdown ldown) andRn combiner m1 m2 gdown ldown - = m1 gdown ldown `thenSST` \ res1 -> - m2 gdown ldown `thenSST` \ res2 -> - returnSST (combiner res1 res2) + = m1 gdown ldown >>= \ res1 -> + m2 gdown ldown >>= \ res2 -> + return (combiner res1 res2) sequenceRn [] = returnRn [] sequenceRn (m:ms) = m `thenRn` \ r -> @@ -639,209 +536,108 @@ mapMaybeRn f (x:xs) = f x `thenRn` \ maybe_r -> ================ Errors and warnings ===================== \begin{code} -failWithRn :: a -> Message -> RnM s d a +failWithRn :: a -> Message -> RnM d a failWithRn res msg (RnDown {rn_errs = errs_var, rn_loc = loc}) l_down - = readMutVarSST errs_var `thenSST` \ (warns,errs) -> - writeMutVarSST errs_var (warns, errs `snocBag` err) `thenSST_` - returnSST res + = readIORef errs_var >>= \ (warns,errs) -> + writeIORef errs_var (warns, errs `snocBag` err) >> + return res where err = addShortErrLocLine loc msg -warnWithRn :: a -> Message -> RnM s d a +warnWithRn :: a -> Message -> RnM d a warnWithRn res msg (RnDown {rn_errs = errs_var, rn_loc = loc}) l_down - = readMutVarSST errs_var `thenSST` \ (warns,errs) -> - writeMutVarSST errs_var (warns `snocBag` warn, errs) `thenSST_` - returnSST res + = readIORef errs_var >>= \ (warns,errs) -> + writeIORef errs_var (warns `snocBag` warn, errs) >> + return res where warn = addShortWarnLocLine loc msg -addErrRn :: Message -> RnM s d () +addErrRn :: Message -> RnM d () addErrRn err = failWithRn () err -checkRn :: Bool -> Message -> RnM s d () -- Check that a condition is true +checkRn :: Bool -> Message -> RnM d () -- Check that a condition is true checkRn False err = addErrRn err checkRn True err = returnRn () -warnCheckRn :: Bool -> Message -> RnM s d () -- Check that a condition is true +warnCheckRn :: Bool -> Message -> RnM d () -- Check that a condition is true warnCheckRn False err = addWarnRn err warnCheckRn True err = returnRn () -addWarnRn :: Message -> RnM s d () +addWarnRn :: Message -> RnM d () addWarnRn warn = warnWithRn () warn -checkErrsRn :: RnM s d Bool -- True <=> no errors so far +checkErrsRn :: RnM d Bool -- True <=> no errors so far checkErrsRn (RnDown {rn_errs = errs_var}) l_down - = readMutVarSST errs_var `thenSST` \ (warns,errs) -> - returnSST (isEmptyBag errs) + = readIORef errs_var >>= \ (warns,errs) -> + return (isEmptyBag errs) \end{code} ================ Source location ===================== \begin{code} -pushSrcLocRn :: SrcLoc -> RnM s d a -> RnM s d a +pushSrcLocRn :: SrcLoc -> RnM d a -> RnM d a pushSrcLocRn loc' m down l_down = m (down {rn_loc = loc'}) l_down -getSrcLocRn :: RnM s d SrcLoc +getSrcLocRn :: RnM d SrcLoc getSrcLocRn down l_down - = returnSST (rn_loc down) + = return (rn_loc down) \end{code} ================ Name supply ===================== \begin{code} -getNameSupplyRn :: RnM s d RnNameSupply +getNameSupplyRn :: RnM d RnNameSupply getNameSupplyRn rn_down l_down - = readMutVarSST (rn_ns rn_down) + = readIORef (rn_ns rn_down) -setNameSupplyRn :: RnNameSupply -> RnM s d () +setNameSupplyRn :: RnNameSupply -> RnM d () setNameSupplyRn names' (RnDown {rn_ns = names_var}) l_down - = writeMutVarSST names_var names' + = writeIORef names_var names' -- See comments with RnNameSupply above. -newInstUniq :: (OccName, OccName) -> RnM s d Int +newInstUniq :: (OccName, OccName) -> RnM d Int newInstUniq key (RnDown {rn_ns = names_var}) l_down - = readMutVarSST names_var `thenSST` \ (us, mapInst, cache) -> + = readIORef names_var >>= \ (us, mapInst, cache) -> let uniq = case lookupFM mapInst key of Just x -> x+1 Nothing -> 0 mapInst' = addToFM mapInst key uniq in - writeMutVarSST names_var (us, mapInst', cache) `thenSST_` - returnSST uniq + writeIORef names_var (us, mapInst', cache) >> + return uniq -getUniqRn :: RnM s d Unique +getUniqRn :: RnM d Unique getUniqRn (RnDown {rn_ns = names_var}) l_down - = readMutVarSST names_var `thenSST` \ (us, mapInst, cache) -> + = readIORef names_var >>= \ (us, mapInst, cache) -> let (us1,us') = splitUniqSupply us in - writeMutVarSST names_var (us', mapInst, cache) `thenSST_` - returnSST (uniqFromSupply us1) + writeIORef names_var (us', mapInst, cache) >> + return (uniqFromSupply us1) \end{code} -================ Occurrences ===================== - -Every time we get an occurrence of a name we put it in one of two lists: - one for "compulsory" occurrences - one for "optional" occurrences - -The significance of "compulsory" is - (a) we *must* find the declaration - (b) in the case of type or class names, the name is part of the - source level program, and we must slurp in any instance decls - involving it. - -We don't need instance decls "optional" names, because the type inference -process will never come across them. Optional names are buried inside -type checked (but not renamed) cross-module unfoldings and such. - -The pair of lists is held in a mutable variable in RnDown. - -The lists are kept separate so that we can process all the compulsory occurrences -before any of the optional ones. Why? Because suppose we processed an optional -"g", and slurped an interface decl of g::T->T. Then we'd rename the type T->T in -optional mode. But if we later need g compulsorily we'll find that it's already -been slurped and will do nothing. We could, I suppose, rename it a second time, -but it seems simpler just to do all the compulsory ones first. - -\begin{code} -addOccurrenceName :: Name -> RnMS s Name -- Same name returned as passed -addOccurrenceName name (RnDown {rn_loc = loc, rn_occs = occs_var}) - (SDown {rn_mode = mode}) - | isLocallyDefinedName name || - not_necessary necessity - = returnSST name - - | otherwise - = readMutVarSST occs_var `thenSST` \ (comp_occs, opt_occs) -> - let - new_occ_pair = case necessity of - Optional -> (comp_occs, (name,loc):opt_occs) - Compulsory -> ((name,loc):comp_occs, opt_occs) - in - writeMutVarSST occs_var new_occ_pair `thenSST_` - returnSST name - where - necessity = modeToNecessity mode - - -addOccurrenceNames :: [Name] -> RnMS s () -addOccurrenceNames names (RnDown {rn_loc = loc, rn_occs = occs_var}) - (SDown {rn_mode = mode}) - | not_necessary necessity - = returnSST () - - | otherwise - = readMutVarSST occs_var `thenSST` \ (comp_occs, opt_occs) -> - let - new_occ_pair = case necessity of - Optional -> (comp_occs, non_local_occs ++ opt_occs) - Compulsory -> (non_local_occs ++ comp_occs, opt_occs) - in - writeMutVarSST occs_var new_occ_pair - where - non_local_occs = [(name, loc) | name <- names, not (isLocallyDefinedName name)] - necessity = modeToNecessity mode - - -- Never look for optional things if we're - -- ignoring optional input interface information -not_necessary Compulsory = False -not_necessary Optional = opt_IgnoreIfacePragmas - -popOccurrenceName :: RnMode -> RnM s d (Maybe Occurrence) -popOccurrenceName mode (RnDown {rn_occs = occs_var}) l_down - = readMutVarSST occs_var `thenSST` \ occs -> - case (mode, occs) of - -- Find a compulsory occurrence - (InterfaceMode Compulsory, (comp:comps, opts)) - -> writeMutVarSST occs_var (comps, opts) `thenSST_` - returnSST (Just comp) - - -- Find an optional occurrence - -- We shouldn't be looking unless we've done all the compulsories - (InterfaceMode Optional, (comps, opt:opts)) - -> ASSERT2( null comps, ppr comps ) - writeMutVarSST occs_var (comps, opts) `thenSST_` - returnSST (Just opt) - - -- No suitable occurrence - other -> returnSST Nothing - --- discardOccurrencesRn does the enclosed thing with a *fresh* occurrences --- variable, and discards the list of occurrences thus found. It's useful --- when loading instance decls and specialisation signatures, when we want to --- know the names of the things in the types, but we don't want to treat them --- as occurrences. - -discardOccurrencesRn :: RnM s d a -> RnM s d a -discardOccurrencesRn enclosed_thing rn_down l_down - = newMutVarSST ([],[]) `thenSST` \ new_occs_var -> - enclosed_thing (rn_down {rn_occs = new_occs_var}) l_down -\end{code} - - ================ Module ===================== \begin{code} -getModuleRn :: RnM s d Module +getModuleRn :: RnM d ModuleName getModuleRn (RnDown {rn_mod = mod_name}) l_down - = returnSST mod_name + = return mod_name -setModuleRn :: Module -> RnM s d a -> RnM s d a +setModuleRn :: ModuleName -> RnM d a -> RnM d a setModuleRn new_mod enclosed_thing rn_down l_down = enclosed_thing (rn_down {rn_mod = new_mod}) l_down \end{code} \begin{code} -setOmitQualFn :: (Name -> Bool) -> RnM s d a -> RnM s d a +setOmitQualFn :: (Name -> Bool) -> RnM d a -> RnM d a setOmitQualFn fn m g_down l_down = m (g_down { rn_omit = fn }) l_down -getOmitQualFn :: RnM s d (Name -> Bool) +getOmitQualFn :: RnM d (Name -> Bool) getOmitQualFn (RnDown {rn_omit = omit_fn}) l_down - = returnSST omit_fn + = return omit_fn \end{code} %************************************************************************ @@ -853,39 +649,39 @@ getOmitQualFn (RnDown {rn_omit = omit_fn}) l_down ================ RnEnv ===================== \begin{code} -getNameEnvs :: RnMS s (GlobalRdrEnv, LocalRdrEnv) -getNameEnvs rn_down (SDown {rn_genv = RnEnv global_env fixity_env, rn_lenv = local_env}) - = returnSST (global_env, local_env) +getNameEnvs :: RnMS (GlobalRdrEnv, LocalRdrEnv) +getNameEnvs rn_down (SDown {rn_genv = global_env, rn_lenv = local_env}) + = return (global_env, local_env) -getLocalNameEnv :: RnMS s LocalRdrEnv +getLocalNameEnv :: RnMS LocalRdrEnv getLocalNameEnv rn_down (SDown {rn_lenv = local_env}) - = returnSST local_env + = return local_env -setLocalNameEnv :: LocalRdrEnv -> RnMS s a -> RnMS s a +setLocalNameEnv :: LocalRdrEnv -> RnMS a -> RnMS a setLocalNameEnv local_env' m rn_down l_down = m rn_down (l_down {rn_lenv = local_env'}) -getFixityEnv :: RnMS s FixityEnv -getFixityEnv rn_down (SDown {rn_genv = RnEnv name_env fixity_env}) - = returnSST fixity_env +getFixityEnv :: RnMS FixityEnv +getFixityEnv rn_down (SDown {rn_fixenv = fixity_env}) + = return fixity_env -extendFixityEnv :: [(Name, RenamedFixitySig)] -> RnMS s a -> RnMS s a +extendFixityEnv :: [(Name, RenamedFixitySig)] -> RnMS a -> RnMS a extendFixityEnv fixes enclosed_scope - rn_down l_down@(SDown {rn_genv = RnEnv name_env fixity_env}) + rn_down l_down@(SDown {rn_fixenv = fixity_env}) = let new_fixity_env = extendNameEnv fixity_env fixes in - enclosed_scope rn_down (l_down {rn_genv = RnEnv name_env new_fixity_env}) + enclosed_scope rn_down (l_down {rn_fixenv = new_fixity_env}) \end{code} ================ Mode ===================== \begin{code} -getModeRn :: RnMS s RnMode +getModeRn :: RnMS RnMode getModeRn rn_down (SDown {rn_mode = mode}) - = returnSST mode + = return mode -setModeRn :: RnMode -> RnMS s a -> RnMS s a +setModeRn :: RnMode -> RnMS a -> RnMS a setModeRn new_mode thing_inside rn_down l_down = thing_inside rn_down (l_down {rn_mode = new_mode}) \end{code} @@ -898,55 +694,15 @@ setModeRn new_mode thing_inside rn_down l_down %************************************************************************ \begin{code} -getIfacesRn :: RnMG Ifaces -getIfacesRn rn_down (GDown {rn_ifaces = iface_var}) - = readMutVarSST iface_var - -setIfacesRn :: Ifaces -> RnMG () -setIfacesRn ifaces rn_down (GDown {rn_ifaces = iface_var}) - = writeMutVarSST iface_var ifaces - -getModuleHiMap :: Bool -> RnM s d ModuleHiMap -getModuleHiMap want_hi_boot (RnDown {rn_hi_map = himap, rn_hiboot_map = hibmap}) _ - | want_hi_boot = returnSST hibmap - | otherwise = returnSST himap -\end{code} +getIfacesRn :: RnM d Ifaces +getIfacesRn (RnDown {rn_ifaces = iface_var}) _ + = readIORef iface_var -The interface file format is capable of distinguishing -between normal imports/exports of names from other modules -and 'hi-boot' mentions of names, with the flavour in the -being encoded inside a @Module@. +setIfacesRn :: Ifaces -> RnM d () +setIfacesRn ifaces (RnDown {rn_ifaces = iface_var}) _ + = writeIORef iface_var ifaces -@setModuleFlavourRn@ fixes up @Module@ values containing -normal flavours, returning a @Module@ value containing -the attributes of the module that's in scope. The only -attribute at the moment is the DLLness of a module, i.e., -whether the object code for that module resides in a -Win32 DLL or not. - -\begin{code} -setModuleFlavourRn :: Module -> RnM s d Module -setModuleFlavourRn mod - | bootFlavour hif = returnRn mod - | otherwise = - getModuleHiMap (bootFlavour hif) `thenRn` \ himap -> - case (lookupFM himap mod_pstr) of - Nothing -> returnRn mod - Just (_, is_in_a_dll) -> - returnRn (setModuleFlavour (mkDynFlavour is_in_a_dll hif) mod) - where - mod_pstr = moduleString mod - hif = moduleIfaceFlavour mod - -\end{code} - -%************************************************************************ -%* * -\subsection{HowInScope} -%* * -%************************************************************************ - -\begin{code} -modeToNecessity SourceMode = Compulsory -modeToNecessity (InterfaceMode necessity) = necessity +getHiMaps :: RnM d (ModuleHiMap, ModuleHiMap) +getHiMaps (RnDown {rn_hi_maps = himaps}) _ + = return himaps \end{code} diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index 58dd7a6..8e76d05 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -14,16 +14,16 @@ import CmdLineOpts ( opt_NoImplicitPrelude, opt_WarnDuplicateExports, opt_SourceUnchanged, opt_WarnUnusedBinds ) -import HsSyn ( HsModule(..), ImportDecl(..), HsDecl(..), TyClDecl(..), +import HsSyn ( HsModule(..), HsDecl(..), TyClDecl(..), IE(..), ieName, ForeignDecl(..), ForKind(..), isDynamic, - FixitySig(..), Sig(..), + FixitySig(..), Sig(..), ImportDecl(..), collectTopBinders ) import RdrHsSyn ( RdrNameIE, RdrNameImportDecl, RdrNameHsModule, RdrNameHsDecl ) -import RnIfaces ( getInterfaceExports, getDeclBinders, getImportedFixities, +import RnIfaces ( getInterfaceExports, getDeclBinders, recordSlurp, checkUpToDate ) import RnEnv @@ -35,15 +35,19 @@ import PrelInfo ( main_RDR ) import UniqFM ( lookupUFM ) import Bag ( bagToList ) import Maybes ( maybeToBool ) -import Module ( pprModule ) +import Module ( ModuleName, mkThisModule, pprModuleName, WhereFrom(..) ) import NameSet -import Name +import Name ( Name, ExportFlag(..), ImportReason(..), + isLocallyDefined, setNameImportReason, + nameOccName, getSrcLoc, pprProvenance, getNameProvenance + ) import RdrName ( RdrName, rdrNameOcc, mkRdrQual, mkRdrUnqual ) import SrcLoc ( SrcLoc ) import NameSet ( elemNameSet, emptyNameSet ) import Outputable import Unique ( getUnique ) import Util ( removeDups, equivClassesByUniq, sortLt ) +import List ( partition ) \end{code} @@ -57,7 +61,8 @@ import Util ( removeDups, equivClassesByUniq, sortLt ) \begin{code} getGlobalNames :: RdrNameHsModule -> RnMG (Maybe (ExportEnv, - RnEnv, + GlobalRdrEnv, + FixityEnv, -- Fixities for local decls only NameEnv AvailInfo -- Maps a name to its parent AvailInfo -- Just for in-scope things only )) @@ -85,18 +90,26 @@ getGlobalNames (HsModule this_mod _ exports imports decls mod_loc) importsFromLocalDecls this_mod rec_exp_fn decls `thenRn` \ (local_gbl_env, local_mod_avails) -> -- PROCESS IMPORT DECLS - mapAndUnzipRn importsFromImportDecl all_imports `thenRn` \ (imp_gbl_envs, imp_avails_s) -> + -- Do the non {- SOURCE -} ones first, so that we get a helpful + -- warning for {- SOURCE -} ones that are unnecessary + let + (source, ordinary) = partition is_source_import all_imports + is_source_import (ImportDecl _ ImportByUserSource _ _ _ _) = True + is_source_import other = False + in + mapAndUnzipRn importsFromImportDecl ordinary `thenRn` \ (imp_gbl_envs1, imp_avails_s1) -> + mapAndUnzipRn importsFromImportDecl source `thenRn` \ (imp_gbl_envs2, imp_avails_s2) -> -- COMBINE RESULTS -- We put the local env second, so that a local provenance -- "wins", even if a module imports itself. let gbl_env :: GlobalRdrEnv - imp_gbl_env = foldr plusGlobalRdrEnv emptyRdrEnv imp_gbl_envs + imp_gbl_env = foldr plusGlobalRdrEnv emptyRdrEnv (imp_gbl_envs2 ++ imp_gbl_envs1) gbl_env = imp_gbl_env `plusGlobalRdrEnv` local_gbl_env all_avails :: ExportAvails - all_avails = foldr plusExportAvails local_mod_avails imp_avails_s + all_avails = foldr plusExportAvails local_mod_avails (imp_avails_s2 ++ imp_avails_s1) in returnRn (gbl_env, all_avails) ) `thenRn` \ (gbl_env, all_avails) -> @@ -115,7 +128,7 @@ getGlobalNames (HsModule this_mod _ exports imports decls mod_loc) -- Then I must detect the name clash in A before going for an early -- exit. The early-exit code checks what's actually needed from B -- to compile A, and of course that doesn't include B.f. That's - -- why we wait till after the plusRnEnv stuff to do the early-exit. + -- why we wait till after the plusEnv stuff to do the early-exit. checkEarlyExit this_mod `thenRn` \ up_to_date -> if up_to_date then returnRn (junk_exp_fn, Nothing) @@ -135,7 +148,6 @@ getGlobalNames (HsModule this_mod _ exports imports decls mod_loc) -- DEAL WITH FIXITIES fixitiesFromLocalDecls gbl_env decls `thenRn` \ local_fixity_env -> - getImportedFixities gbl_env `thenRn` \ imp_fixity_env -> let -- Export only those fixities that are for names that are -- (a) defined in this module @@ -144,18 +156,15 @@ getGlobalNames (HsModule this_mod _ exports imports decls mod_loc) exported_fixities = [(name,fixity) | FixitySig name fixity _ <- nameEnvElts local_fixity_env, isLocallyDefined name ] - - fixity_env = imp_fixity_env `plusNameEnv` local_fixity_env in - traceRn (text "fixity env" <+> vcat (map ppr (nameEnvElts fixity_env))) `thenRn_` + traceRn (text "fixity env" <+> vcat (map ppr (nameEnvElts local_fixity_env))) `thenRn_` --- TIDY UP let export_env = ExportEnv exported_avails exported_fixities - rn_env = RnEnv gbl_env fixity_env (_, global_avail_env) = all_avails in - returnRn (Just (export_env, rn_env, global_avail_env)) + returnRn (Just (export_env, gbl_env, local_fixity_env, global_avail_env)) } where junk_exp_fn = error "RnNames:export_fn" @@ -165,19 +174,20 @@ getGlobalNames (HsModule this_mod _ exports imports decls mod_loc) -- NB: opt_NoImplicitPrelude is slightly different to import Prelude (); -- because the former doesn't even look at Prelude.hi for instance declarations, -- whereas the latter does. - prel_imports | this_mod == pRELUDE || + prel_imports | this_mod == pRELUDE_Name || explicit_prelude_import || opt_NoImplicitPrelude = [] - | otherwise = [ImportDecl pRELUDE + | otherwise = [ImportDecl pRELUDE_Name + ImportByUser False {- Not qualified -} Nothing {- No "as" -} Nothing {- No import list -} mod_loc] explicit_prelude_import - = not (null [ () | (ImportDecl mod qual _ _ _) <- imports, mod == pRELUDE ]) + = not (null [ () | (ImportDecl mod _ _ _ _ _) <- imports, mod == pRELUDE_Name ]) \end{code} \begin{code} @@ -209,17 +219,17 @@ importsFromImportDecl :: RdrNameImportDecl -> RnMG (GlobalRdrEnv, ExportAvails) -importsFromImportDecl (ImportDecl imp_mod qual_only as_mod import_spec iloc) +importsFromImportDecl (ImportDecl imp_mod_name from qual_only as_mod import_spec iloc) = pushSrcLocRn iloc $ - getInterfaceExports imp_mod `thenRn` \ (imp_mod, avails) -> + getInterfaceExports imp_mod_name from `thenRn` \ (imp_mod, avails) -> if null avails then -- If there's an error in getInterfaceExports, (e.g. interface -- file not found) we get lots of spurious errors from 'filterImports' - returnRn (emptyRdrEnv, mkEmptyExportAvails imp_mod) + returnRn (emptyRdrEnv, mkEmptyExportAvails imp_mod_name) else - filterImports imp_mod import_spec avails `thenRn` \ (filtered_avails, hides, explicits) -> + filterImports imp_mod_name import_spec avails `thenRn` \ (filtered_avails, hides, explicits) -> -- We 'improve' the provenance by setting -- (a) the import-reason field, so that the Name says how it came into scope @@ -230,7 +240,7 @@ importsFromImportDecl (ImportDecl imp_mod qual_only as_mod import_spec iloc) improve_prov name = setNameImportReason name (UserImport imp_mod iloc (is_explicit name)) is_explicit name = name `elemNameSet` explicits in - qualifyImports imp_mod + qualifyImports imp_mod_name (not qual_only) -- Maybe want unqualified names as_mod hides filtered_avails improve_prov `thenRn` \ (rdr_name_env, mod_avails) -> @@ -240,7 +250,7 @@ importsFromImportDecl (ImportDecl imp_mod qual_only as_mod import_spec iloc) \begin{code} -importsFromLocalDecls mod rec_exp_fn decls +importsFromLocalDecls mod_name rec_exp_fn decls = mapRn (getLocalDeclBinders newLocalName) decls `thenRn` \ avails_s -> let @@ -256,13 +266,13 @@ importsFromLocalDecls mod rec_exp_fn decls non_singleton other = False in -- Check for duplicate definitions - mapRn_ (addErrRn . dupDeclErr) dups `thenRn_` + mapRn_ (addErrRn . dupDeclErr) dups `thenRn_` -- Record that locally-defined things are available - mapRn_ (recordSlurp Nothing Compulsory) avails `thenRn_` + mapRn_ (recordSlurp Nothing) avails `thenRn_` -- Build the environment - qualifyImports mod + qualifyImports mod_name True -- Want unqualified names Nothing -- no 'as M' [] -- Hide nothing @@ -270,8 +280,9 @@ importsFromLocalDecls mod rec_exp_fn decls (\n -> n) where - newLocalName rdr_name loc = newLocallyDefinedGlobalName mod (rdrNameOcc rdr_name) - rec_exp_fn loc + newLocalName rdr_name loc = newLocalTopBinder mod (rdrNameOcc rdr_name) + rec_exp_fn loc + mod = mkThisModule mod_name getLocalDeclBinders :: (RdrName -> SrcLoc -> RnMG Name) -- New-name function -> RdrNameHsDecl @@ -309,14 +320,13 @@ fixitiesFromLocalDecls gbl_env decls getFixities acc (FixD fix) = fix_decl acc fix - - getFixities acc (TyClD (ClassDecl _ _ _ sigs _ _ _ _ _)) + getFixities acc (TyClD (ClassDecl _ _ _ sigs _ _ _ _ _ _)) = foldlRn fix_decl acc [sig | FixSig sig <- sigs] -- Get fixities from class decl sigs too. getFixities acc other_decl = returnRn acc - fix_decl acc (FixitySig rdr_name fixity loc) + fix_decl acc sig@(FixitySig rdr_name fixity loc) = -- Check for fixity decl for something not declared case lookupRdrEnv gbl_env rdr_name of { Nothing | opt_WarnUnusedBinds @@ -331,7 +341,6 @@ fixitiesFromLocalDecls gbl_env decls Just (FixitySig _ _ loc') -> addErrRn (dupFixityDecl rdr_name loc loc') `thenRn_` returnRn acc ; - Nothing -> returnRn (addToNameEnv acc name (FixitySig name fixity loc)) }} \end{code} @@ -346,7 +355,7 @@ fixitiesFromLocalDecls gbl_env decls available, and filters it through the import spec (if any). \begin{code} -filterImports :: Module -- The module being imported +filterImports :: ModuleName -- The module being imported -> Maybe (Bool, [RdrNameIE]) -- Import spec; True => hiding -> [AvailInfo] -- What's available -> RnMG ([AvailInfo], -- What's actually imported @@ -432,9 +441,9 @@ right qualified names. It also turns the @Names@ in the @ExportEnv@ into fully fledged @Names@. \begin{code} -qualifyImports :: Module -- Imported module +qualifyImports :: ModuleName -- Imported module -> Bool -- True <=> want unqualified import - -> Maybe Module -- Optional "as M" part + -> Maybe ModuleName -- Optional "as M" part -> [AvailInfo] -- What's to be hidden -> Avails -- Whats imported and how -> (Name -> Name) -- Improves the provenance on imported things @@ -503,7 +512,7 @@ includes ConcBase.StateAndSynchVar#, and so on... \begin{code} type ExportAccum -- The type of the accumulating parameter of -- the main worker function in exportsFromAvail - = ([Module], -- 'module M's seen so far + = ([ModuleName], -- 'module M's seen so far ExportOccMap, -- Tracks exported occurrence names NameEnv AvailInfo) -- The accumulated exported stuff, kept in an env -- so we can common-up related AvailInfos @@ -515,7 +524,7 @@ type ExportOccMap = FiniteMap OccName (Name, RdrNameIE) -- that have the same occurrence name -exportsFromAvail :: Module +exportsFromAvail :: ModuleName -> Maybe [RdrNameIE] -- Export spec -> ExportAvails -> GlobalRdrEnv @@ -526,7 +535,7 @@ exportsFromAvail :: Module exportsFromAvail this_mod Nothing export_avails global_name_env = exportsFromAvail this_mod true_exports export_avails global_name_env where - true_exports = Just $ if this_mod == mAIN + true_exports = Just $ if this_mod == mAIN_Name then [IEVar main_RDR] -- export Main.main *only* unless otherwise specified, else [IEModuleContents this_mod] @@ -629,16 +638,16 @@ mk_export_fn exported_names \begin{code} badImportItemErr mod ie - = sep [ptext SLIT("Module"), quotes (pprModule mod), + = sep [ptext SLIT("Module"), quotes (pprModuleName mod), ptext SLIT("does not export"), quotes (ppr ie)] dodgyImportWarn mod (IEThingAll tc) - = sep [ptext SLIT("Module") <+> quotes (pprModule mod) <+> ptext SLIT("exports") <+> quotes (ppr tc), + = sep [ptext SLIT("Module") <+> quotes (pprModuleName mod) <+> ptext SLIT("exports") <+> quotes (ppr tc), ptext SLIT("with no constructors/class operations;"), ptext SLIT("yet it is imported with a (..)")] modExportErr mod - = hsep [ ptext SLIT("Unknown module in export list: module"), quotes (pprModule mod)] + = hsep [ ptext SLIT("Unknown module in export list: module"), quotes (pprModuleName mod)] exportItemErr export_item = sep [ ptext SLIT("Bad export item"), quotes (ppr export_item)] @@ -664,7 +673,7 @@ dupExportWarn occ_name ie1 ie2 dupModuleExport mod = hsep [ptext SLIT("Duplicate"), - quotes (ptext SLIT("Module") <+> pprModule mod), + quotes (ptext SLIT("Module") <+> pprModuleName mod), ptext SLIT("in export list")] unusedFixityDecl rdr_name fixity diff --git a/ghc/compiler/rename/RnSource.hi-boot b/ghc/compiler/rename/RnSource.hi-boot index 0bf49d5..21e9592 100644 --- a/ghc/compiler/rename/RnSource.hi-boot +++ b/ghc/compiler/rename/RnSource.hi-boot @@ -2,10 +2,8 @@ _interface_ RnSource 1 _exports_ RnSource rnHsType rnHsSigType; _declarations_ -1 rnHsSigType _:_ _forall_ [a] => (Outputable.SDoc) - -> RdrHsSyn.RdrNameHsType - -> RnMonad.RnMS a (RnHsSyn.RenamedHsType, RnEnv.FreeVars) ;; -1 rnHsType _:_ _forall_ [a] => (Outputable.SDoc) - -> RdrHsSyn.RdrNameHsType - -> RnMonad.RnMS a (RnHsSyn.RenamedHsType, RnEnv.FreeVars) ;; +1 rnHsSigType _:_ Outputable.SDoc -> RdrHsSyn.RdrNameHsType + -> RnMonad.RnMS (RnHsSyn.RenamedHsType, RnEnv.FreeVars) ;; +1 rnHsType _:_ Outputable.SDoc -> RdrHsSyn.RdrNameHsType + -> RnMonad.RnMS (RnHsSyn.RenamedHsType, RnEnv.FreeVars) ;; diff --git a/ghc/compiler/rename/RnSource.hi-boot-5 b/ghc/compiler/rename/RnSource.hi-boot-5 index aeca07e..bb0593a 100644 --- a/ghc/compiler/rename/RnSource.hi-boot-5 +++ b/ghc/compiler/rename/RnSource.hi-boot-5 @@ -1,8 +1,6 @@ __interface RnSource 1 0 where __export RnSource rnHsSigType rnHsType; -1 rnHsSigType :: __forall [_a] => Outputable.SDoc - -> RdrHsSyn.RdrNameHsType - -> RnMonad.RnMS _a (RnHsSyn.RenamedHsType, RnEnv.FreeVars) ; -1 rnHsType :: __forall [_a] => Outputable.SDoc - -> RdrHsSyn.RdrNameHsType - -> RnMonad.RnMS _a (RnHsSyn.RenamedHsType, RnEnv.FreeVars) ; +1 rnHsSigType :: Outputable.SDoc -> RdrHsSyn.RdrNameHsType + -> RnMonad.RnMS (RnHsSyn.RenamedHsType, RnEnv.FreeVars) ; +1 rnHsType :: Outputable.SDoc -> RdrHsSyn.RdrNameHsType + -> RnMonad.RnMS (RnHsSyn.RenamedHsType, RnEnv.FreeVars) ; diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index 51f9ea3..0c29691 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -4,44 +4,41 @@ \section[RnSource]{Main pass of renamer} \begin{code} -module RnSource ( rnIfaceDecl, rnSourceDecls, rnHsType, rnHsSigType ) where +module RnSource ( rnDecl, rnSourceDecls, rnHsType, rnHsSigType ) where #include "HsVersions.h" import RnExpr import HsSyn -import HsDecls ( HsIdInfo(..), HsStrictnessInfo(..) ) import HsPragmas import HsTypes ( getTyVarName, pprClassAssertion, cmpHsTypes ) -import RdrName ( RdrName, isRdrDataCon, rdrNameOcc ) +import RdrName ( RdrName, isRdrDataCon, rdrNameOcc, isRdrTyVar ) import RdrHsSyn ( RdrNameContext, RdrNameHsType, RdrNameConDecl, - extractHsTyVars + extractHsTyRdrNames, extractRuleBndrsTyVars ) import RnHsSyn import HsCore import RnBinds ( rnTopBinds, rnMethodBinds, renameSigs, unknownSigErr ) import RnEnv ( bindTyVarsRn, lookupBndrRn, lookupOccRn, - lookupImplicitOccRn, addImplicitOccRn, - bindLocalsRn, + lookupImplicitOccRn, + bindLocalsRn, bindLocalRn, bindLocalsFVRn, bindTyVarsFVRn, bindTyVarsFV2Rn, extendTyVarEnvFVRn, + bindCoreLocalFVRn, bindCoreLocalsFVRn, checkDupOrQualNames, checkDupNames, - newLocallyDefinedGlobalName, newImportedGlobalName, - newImportedGlobalFromRdrName, - newDFunName, - FreeVars, emptyFVs, plusFV, plusFVs, unitFV, addOneFV + mkImportedGlobalName, mkImportedGlobalFromRdrName, + newDFunName, getDFunKey, newImplicitBinder, + FreeVars, emptyFVs, plusFV, plusFVs, unitFV, addOneFV, mapFvRn ) import RnMonad import Name ( Name, OccName, ExportFlag(..), Provenance(..), - nameOccName, NamedThing(..), - mkDefaultMethodOcc, mkDFunOcc + nameOccName, NamedThing(..) ) import NameSet +import OccName ( mkDefaultMethodOcc ) import BasicTypes ( TopLevelFlag(..) ) -import TysWiredIn ( tupleTyCon, unboxedTupleTyCon, listTyCon ) -import Type ( funTyCon ) import FiniteMap ( elemFM ) import PrelInfo ( derivingOccurrences, numClass_RDR, deRefStablePtr_NAME, makeStablePtr_NAME, @@ -78,7 +75,7 @@ Checks the (..) etc constraints in the export list. %********************************************************* \begin{code} -rnSourceDecls :: [RdrNameHsDecl] -> RnMS s ([RenamedHsDecl], FreeVars) +rnSourceDecls :: [RdrNameHsDecl] -> RnMS ([RenamedHsDecl], FreeVars) -- The decls get reversed, but that's ok rnSourceDecls decls @@ -89,11 +86,6 @@ rnSourceDecls decls go fvs ds' (FixD _:ds) = go fvs ds' ds go fvs ds' (d:ds) = rnDecl d `thenRn` \(d', fvs') -> go (fvs `plusFV` fvs') (d':ds') ds - -rnIfaceDecl :: RdrNameHsDecl -> RnMS s RenamedHsDecl -rnIfaceDecl d - = rnDecl d `thenRn` \ (d', fvs) -> - returnRn d' \end{code} @@ -105,7 +97,7 @@ rnIfaceDecl d \begin{code} -- rnDecl does all the work -rnDecl :: RdrNameHsDecl -> RnMS s (RenamedHsDecl, FreeVars) +rnDecl :: RdrNameHsDecl -> RnMS (RenamedHsDecl, FreeVars) rnDecl (ValD binds) = rnTopBinds binds `thenRn` \ (new_binds, fvs) -> returnRn (ValD new_binds, fvs) @@ -114,15 +106,9 @@ rnDecl (ValD binds) = rnTopBinds binds `thenRn` \ (new_binds, fvs) -> rnDecl (SigD (IfaceSig name ty id_infos loc)) = pushSrcLocRn loc $ lookupBndrRn name `thenRn` \ name' -> - rnIfaceType doc_str ty `thenRn` \ ty' -> - - -- Get the pragma info (if any). - setModeRn (InterfaceMode Optional) $ - -- In all the rest of the signature we read in optional mode, - -- so that (a) we don't die - mapRn rnIdInfo id_infos `thenRn` \ id_infos' -> - returnRn (SigD (IfaceSig name' ty' id_infos' loc), emptyFVs) - -- Don't need free-var info for iface binds + 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) where doc_str = text "the interface signature for" <+> quotes (ppr name) \end{code} @@ -152,11 +138,11 @@ rnDecl (TyClD (TyData new_or_data context tycon tyvars condecls derivings pragma bindTyVarsFVRn data_doc tyvars $ \ tyvars' -> rnContext data_doc context `thenRn` \ (context', cxt_fvs) -> checkDupOrQualNames data_doc con_names `thenRn_` - mapAndUnzipRn rnConDecl condecls `thenRn` \ (condecls', con_fvs_s) -> + mapFvRn rnConDecl condecls `thenRn` \ (condecls', con_fvs) -> rnDerivs derivings `thenRn` \ (derivings', deriv_fvs) -> ASSERT(isNoDataPragmas pragmas) returnRn (TyClD (TyData new_or_data context' tycon' tyvars' condecls' derivings' noDataPragmas src_loc), - cxt_fvs `plusFV` plusFVs con_fvs_s `plusFV` deriv_fvs) + 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 @@ -170,7 +156,7 @@ rnDecl (TyClD (TySynonym name tyvars ty src_loc)) where syn_doc = text "the declaration for type synonym" <+> quotes (ppr name) -rnDecl (TyClD (ClassDecl context cname tyvars sigs mbinds pragmas tname dname src_loc)) +rnDecl (TyClD (ClassDecl context cname tyvars sigs mbinds pragmas tname dname snames src_loc)) = pushSrcLocRn src_loc $ lookupBndrRn cname `thenRn` \ cname' -> @@ -182,8 +168,9 @@ rnDecl (TyClD (ClassDecl context cname tyvars sigs mbinds pragmas tname dname sr -- So the 'Imported' part of this call is not relevant. -- Unclean; but since these two are the only place this happens -- I can't work up the energy to do it more beautifully - newImportedGlobalFromRdrName tname `thenRn` \ tname' -> - newImportedGlobalFromRdrName dname `thenRn` \ dname' -> + mkImportedGlobalFromRdrName tname `thenRn` \ tname' -> + mkImportedGlobalFromRdrName dname `thenRn` \ dname' -> + mapRn mkImportedGlobalFromRdrName snames `thenRn` \ snames' -> -- Tyvars scope over bindings and context bindTyVarsFV2Rn cls_doc tyvars ( \ clas_tyvar_names tyvars' -> @@ -197,9 +184,9 @@ rnDecl (TyClD (ClassDecl context cname tyvars sigs mbinds pragmas tname dname sr (op_sigs, non_op_sigs) = partition isClassOpSig sigs (fix_sigs, non_sigs) = partition isFixitySig non_op_sigs in - checkDupOrQualNames sig_doc sig_rdr_names_w_locs `thenRn_` - mapAndUnzipRn (rn_op cname' clas_tyvar_names) op_sigs `thenRn` \ (sigs', sig_fvs_s) -> - mapRn_ (unknownSigErr) non_sigs `thenRn_` + checkDupOrQualNames sig_doc sig_rdr_names_w_locs `thenRn_` + mapFvRn (rn_op cname' clas_tyvar_names) op_sigs `thenRn` \ (sigs', sig_fvs) -> + mapRn_ (unknownSigErr) non_sigs `thenRn_` let binders = mkNameSet [ nm | (ClassOpSig nm _ _ _) <- sigs' ] in @@ -215,10 +202,11 @@ rnDecl (TyClD (ClassDecl context cname tyvars sigs mbinds pragmas tname dname sr -- for instance decls. ASSERT(isNoClassPragmas pragmas) - returnRn (TyClD (ClassDecl context' cname' tyvars' (fixs' ++ sigs') mbinds' NoClassPragmas tname' dname' src_loc), - plusFVs sig_fvs_s `plusFV` - fix_fvs `plusFV` - cxt_fvs `plusFV` + returnRn (TyClD (ClassDecl context' cname' tyvars' (fixs' ++ sigs') + mbinds' NoClassPragmas tname' dname' snames' src_loc), + sig_fvs `plusFV` + fix_fvs `plusFV` + cxt_fvs `plusFV` meth_fvs ) ) @@ -244,29 +232,32 @@ rnDecl (TyClD (ClassDecl context cname tyvars sigs mbinds pragmas tname dname sr mapRn_ check_in_op_ty clas_tyvars `thenRn_` -- Make the default-method name - let - dm_occ = mkDefaultMethodOcc (rdrNameOcc op) - in - getModuleRn `thenRn` \ mod_name -> - getModeRn `thenRn` \ mode -> + getModeRn `thenRn` \ mode -> (case (mode, maybe_dm) of - (SourceMode, _) | op `elem` meth_rdr_names - -> -- There's an explicit method decl - newLocallyDefinedGlobalName mod_name dm_occ - (\_ -> Exported) locn `thenRn` \ dm_name -> - returnRn (Just dm_name) + (SourceMode, _) + | op `elem` meth_rdr_names + -> -- Source class decl with an explicit method decl + newImplicitBinder (mkDefaultMethodOcc (rdrNameOcc op)) locn `thenRn` \ dm_name -> + returnRn (Just dm_name, emptyFVs) - (InterfaceMode _, Just _) - -> -- Imported class that has a default method decl - newImportedGlobalName mod_name dm_occ `thenRn` \ dm_name -> - addOccurrenceName dm_name `thenRn_` - returnRn (Just dm_name) + | otherwise + -> -- Source class dec, no explicit method decl + returnRn (Nothing, emptyFVs) - other -> returnRn Nothing - ) `thenRn` \ maybe_dm_name -> - - - returnRn (ClassOpSig op_name maybe_dm_name new_ty locn, op_ty_fvs) + (InterfaceMode, Just dm_rdr_name) + -> -- Imported class that has a default method decl + -- See comments with tname, snames, above + lookupImplicitOccRn dm_rdr_name `thenRn` \ dm_name -> + returnRn (Just dm_name, unitFV dm_name) + -- An imported class decl mentions, rather than defines, + -- the default method, so we must arrange to pull it in + + (InterfaceMode, Nothing) + -- Imported class with no default metho + -> returnRn (Nothing, emptyFVs) + ) `thenRn` \ (maybe_dm_name, dm_fvs) -> + + returnRn (ClassOpSig op_name maybe_dm_name new_ty locn, op_ty_fvs `plusFV` dm_fvs) \end{code} @@ -277,7 +268,7 @@ rnDecl (TyClD (ClassDecl context cname tyvars sigs mbinds pragmas tname dname sr %********************************************************* \begin{code} -rnDecl (InstD (InstDecl inst_ty mbinds uprags maybe_dfun src_loc)) +rnDecl (InstD (InstDecl inst_ty mbinds uprags dfun_rdr_name src_loc)) = pushSrcLocRn src_loc $ rnHsSigType (text "an instance decl") inst_ty `thenRn` \ (inst_ty', inst_fvs) -> let @@ -287,12 +278,13 @@ rnDecl (InstD (InstDecl inst_ty mbinds uprags maybe_dfun src_loc)) -- (Slightly strangely) the forall-d tyvars scope over -- the method bindings too in - extendTyVarEnvFVRn inst_tyvars $ -- Rename the bindings -- NB meth_names can be qualified! checkDupNames meth_doc meth_names `thenRn_` - rnMethodBinds mbinds `thenRn` \ (mbinds', meth_fvs) -> + extendTyVarEnvFVRn inst_tyvars ( + rnMethodBinds mbinds + ) `thenRn` \ (mbinds', meth_fvs) -> let binders = mkNameSet (map fst (bagToList (collectMonoBinders mbinds'))) @@ -312,15 +304,25 @@ rnDecl (InstD (InstDecl inst_ty mbinds uprags maybe_dfun src_loc)) -- You can't have fixity decls & type signatures -- within an instance declaration. mapRn_ unknownSigErr not_ok_idecl_sigs `thenRn_` + + -- 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. renameSigs False binders lookupOccRn ok_sigs `thenRn` \ (new_uprags, prag_fvs) -> - mkDFunName inst_ty' maybe_dfun src_loc `thenRn` \ dfun_name -> - addOccurrenceName dfun_name `thenRn_` - -- The dfun is not optional, because we use its version number - -- to identify the version of the instance declaration + + getModeRn `thenRn` \ mode -> + (case mode of + InterfaceMode -> lookupImplicitOccRn dfun_rdr_name `thenRn` \ dfun_name -> + returnRn (dfun_name, unitFV dfun_name) + SourceMode -> newDFunName (getDFunKey inst_ty') src_loc `thenRn` \ dfun_name -> + returnRn (dfun_name, emptyFVs) + ) `thenRn` \ (dfun_name, dfun_fv) -> -- The typechecker checks that all the bindings are for the right class. - returnRn (InstD (InstDecl inst_ty' mbinds' new_uprags (Just dfun_name) src_loc), - inst_fvs `plusFV` meth_fvs `plusFV` prag_fvs) + returnRn (InstD (InstDecl inst_ty' mbinds' new_uprags 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 = bagToList (collectMonoBinders mbinds) @@ -336,8 +338,8 @@ rnDecl (InstD (InstDecl inst_ty mbinds uprags maybe_dfun src_loc)) rnDecl (DefD (DefaultDecl tys src_loc)) = pushSrcLocRn src_loc $ rnHsTypes doc_str tys `thenRn` \ (tys', fvs) -> - lookupImplicitOccRn numClass_RDR `thenRn_` - returnRn (DefD (DefaultDecl tys' src_loc), fvs) + lookupImplicitOccRn numClass_RDR `thenRn` \ num -> + returnRn (DefD (DefaultDecl tys' src_loc), fvs `addOneFV` num) where doc_str = text "a `default' declaration" \end{code} @@ -352,23 +354,67 @@ rnDecl (DefD (DefaultDecl tys src_loc)) rnDecl (ForD (ForeignDecl name imp_exp ty ext_nm cconv src_loc)) = pushSrcLocRn src_loc $ lookupBndrRn name `thenRn` \ name' -> - (case imp_exp of - FoImport _ | not isDyn -> addImplicitOccRn name' - FoLabel -> addImplicitOccRn name' - FoExport | isDyn -> - addImplicitOccRn makeStablePtr_NAME `thenRn_` - addImplicitOccRn deRefStablePtr_NAME `thenRn_` - addImplicitOccRn bindIO_NAME `thenRn_` - returnRn name' - _ -> returnRn name') `thenRn_` - rnHsSigType fo_decl_msg ty `thenRn` \ (ty', fvs) -> - returnRn (ForD (ForeignDecl name' imp_exp ty' ext_nm cconv src_loc), fvs) + let + fvs1 = case imp_exp of + FoImport _ | not isDyn -> emptyFVs + FoLabel -> emptyFVs + FoExport | isDyn -> mkNameSet [makeStablePtr_NAME, + deRefStablePtr_NAME, + bindIO_NAME] + _ -> emptyFVs + in + 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 = isDynamic ext_nm +\end{code} + +%********************************************************* +%* * +\subsection{Rules} +%* * +%********************************************************* +\begin{code} +rnDecl (RuleD (IfaceRuleDecl var body src_loc)) + = pushSrcLocRn src_loc $ + lookupOccRn var `thenRn` \ var' -> + rnRuleBody body `thenRn` \ (body', fvs) -> + returnRn (RuleD (IfaceRuleDecl var' body' src_loc), fvs `addOneFV` var') + +rnDecl (RuleD (RuleDecl 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 (RuleDecl 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} @@ -376,14 +422,14 @@ rnDecl (ForD (ForeignDecl name imp_exp ty ext_nm cconv src_loc)) %********************************************************* \begin{code} -rnDerivs :: Maybe [RdrName] -> RnMS s (Maybe [Name], FreeVars) +rnDerivs :: Maybe [RdrName] -> RnMS (Maybe [Name], FreeVars) rnDerivs Nothing -- derivs not specified = returnRn (Nothing, emptyFVs) rnDerivs (Just ds) - = mapRn rn_deriv ds `thenRn` \ derivs -> - returnRn (Just derivs, foldl addOneFV emptyFVs derivs) + = mapFvRn rn_deriv ds `thenRn` \ (derivs, fvs) -> + returnRn (Just derivs, fvs) where rn_deriv clas = lookupOccRn clas `thenRn` \ clas_name -> @@ -393,18 +439,17 @@ rnDerivs (Just ds) -- generate code for this class. case lookupUFM derivingOccurrences clas_name of Nothing -> addErrRn (derivingNonStdClassErr clas_name) `thenRn_` - returnRn clas_name - - Just occs -> mapRn_ lookupImplicitOccRn occs `thenRn_` - returnRn clas_name + returnRn (clas_name, unitFV clas_name) + Just occs -> mapRn lookupImplicitOccRn occs `thenRn` \ names -> + returnRn (clas_name, mkNameSet (clas_name : names)) \end{code} \begin{code} conDeclName :: RdrNameConDecl -> (RdrName, SrcLoc) conDeclName (ConDecl n _ _ _ l) = (n,l) -rnConDecl :: RdrNameConDecl -> RnMS s (RenamedConDecl, FreeVars) +rnConDecl :: RdrNameConDecl -> RnMS (RenamedConDecl, FreeVars) rnConDecl (ConDecl name tvs cxt details locn) = pushSrcLocRn locn $ checkConName name `thenRn_` @@ -418,8 +463,8 @@ rnConDecl (ConDecl name tvs cxt details locn) doc = text "the definition of data constructor" <+> quotes (ppr name) rnConDetails doc locn (VanillaCon tys) - = mapAndUnzipRn (rnBangTy doc) tys `thenRn` \ (new_tys, fvs_s) -> - returnRn (VanillaCon new_tys, plusFVs fvs_s) + = mapFvRn (rnBangTy doc) tys `thenRn` \ (new_tys, fvs) -> + returnRn (VanillaCon new_tys, fvs) rnConDetails doc locn (InfixCon ty1 ty2) = rnBangTy doc ty1 `thenRn` \ (new_ty1, fvs1) -> @@ -438,8 +483,8 @@ rnConDetails doc locn (NewCon ty mb_field) rnConDetails doc locn (RecCon fields) = checkDupOrQualNames doc field_names `thenRn_` - mapAndUnzipRn (rnField doc) fields `thenRn` \ (new_fields, fvs_s) -> - returnRn (RecCon new_fields, plusFVs fvs_s) + mapFvRn (rnField doc) fields `thenRn` \ (new_fields, fvs) -> + returnRn (RecCon new_fields, fvs) where field_names = [(fld, locn) | (flds, _) <- fields, fld <- flds] @@ -478,55 +523,17 @@ checkConName name %********************************************************* %* * -\subsection{Naming a dfun} -%* * -%********************************************************* - -Make a name for the dict fun for an instance decl - -\begin{code} -mkDFunName :: RenamedHsType -- Instance type - -> Maybe RdrName -- Dfun thing from decl; Nothing <=> source - -> SrcLoc - -> RnMS s Name - -mkDFunName inst_ty maybe_df src_loc - = newDFunName cl_occ tycon_occ maybe_df src_loc - where - (cl_occ, tycon_occ) = get_key inst_ty - - get_key (HsForAllTy _ _ ty) = get_key ty - get_key (MonoFunTy _ ty) = get_key ty - get_key (MonoDictTy cls (ty:_)) = (nameOccName cls, get_tycon_key ty) - - get_tycon_key (MonoTyVar tv) = nameOccName (getName tv) - get_tycon_key (MonoTyApp ty _) = get_tycon_key ty - get_tycon_key (MonoTupleTy tys True) = getOccName (tupleTyCon (length tys)) - get_tycon_key (MonoTupleTy tys False) = getOccName (unboxedTupleTyCon (length tys)) - get_tycon_key (MonoListTy _) = getOccName listTyCon - get_tycon_key (MonoFunTy _ _) = getOccName funTyCon -\end{code} - - -%********************************************************* -%* * \subsection{Support code to rename types} %* * %********************************************************* \begin{code} -rnHsSigType :: SDoc -> RdrNameHsType -> RnMS s (RenamedHsType, FreeVars) +rnHsSigType :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars) -- rnHsSigType is used for source-language type signatures, -- which use *implicit* universal quantification. rnHsSigType doc_str ty = rnHsType (text "the type signature for" <+> doc_str) ty -rnIfaceType :: SDoc -> RdrNameHsType -> RnMS s RenamedHsType -rnIfaceType doc ty - = rnHsType doc ty `thenRn` \ (ty,_) -> - returnRn ty - - rnForAll doc forall_tyvars ctxt ty = bindTyVarsFVRn doc forall_tyvars $ \ new_tyvars -> rnContext doc ctxt `thenRn` \ (new_ctxt, cxt_fvs) -> @@ -548,12 +555,12 @@ checkConstraints explicit_forall doc forall_tyvars ctxt ty | otherwise = addErrRn (ctxtErr explicit_forall doc forall_tyvars ct ty) `thenRn_` returnRn Nothing where - forall_mentioned = foldr ((||) . any (`elem` forall_tyvars) . extractHsTyVars) + forall_mentioned = foldr ((||) . any (`elem` forall_tyvars) . extractHsTyRdrNames) False tys -rnHsType :: SDoc -> RdrNameHsType -> RnMS s (RenamedHsType, FreeVars) +rnHsType :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars) rnHsType doc (HsForAllTy Nothing ctxt ty) -- From source code (no kinds on tyvars) @@ -561,7 +568,7 @@ rnHsType doc (HsForAllTy Nothing ctxt ty) -- over FV(T) \ {in-scope-tyvars} = getLocalNameEnv `thenRn` \ name_env -> let - mentioned_tyvars = extractHsTyVars ty + mentioned_tyvars = filter isRdrTyVar (extractHsTyRdrNames ty) forall_tyvars = filter (not . (`elemFM` name_env)) mentioned_tyvars in checkConstraints False doc forall_tyvars ctxt ty `thenRn` \ ctxt' -> @@ -574,10 +581,10 @@ rnHsType doc (HsForAllTy (Just forall_tyvars) ctxt ty) -- That's only a warning... unless the tyvar is constrained by a -- context in which case it's an error = let - mentioned_tyvars = extractHsTyVars ty + mentioned_tyvars = filter isRdrTyVar (extractHsTyRdrNames ty) constrained_tyvars = [tv | (_,tys) <- ctxt, ty <- tys, - tv <- extractHsTyVars ty] + tv <- mentioned_tyvars] dubious_guys = filter (`notElem` mentioned_tyvars) forall_tyvar_names (bad_guys, warn_guys) = partition (`elem` constrained_tyvars) dubious_guys forall_tyvar_names = map getTyVarName forall_tyvars @@ -597,13 +604,11 @@ rnHsType doc (MonoFunTy ty1 ty2) returnRn (MonoFunTy ty1' ty2', fvs1 `plusFV` fvs2) rnHsType doc (MonoListTy ty) - = addImplicitOccRn listTyCon_name `thenRn_` - rnHsType doc ty `thenRn` \ (ty', fvs) -> + = rnHsType doc ty `thenRn` \ (ty', fvs) -> returnRn (MonoListTy ty', fvs `addOneFV` listTyCon_name) rnHsType doc (MonoTupleTy tys boxed) - = addImplicitOccRn tup_con_name `thenRn_` - rnHsTypes doc tys `thenRn` \ (tys', fvs) -> + = rnHsTypes doc tys `thenRn` \ (tys', fvs) -> returnRn (MonoTupleTy tys' boxed, fvs `addOneFV` tup_con_name) where tup_con_name = tupleTyCon_name boxed (length tys) @@ -622,14 +627,12 @@ rnHsType doc (MonoUsgTy usg ty) = rnHsType doc ty `thenRn` \ (ty', fvs) -> returnRn (MonoUsgTy usg ty', fvs) -rnHsTypes doc tys - = mapAndUnzipRn (rnHsType doc) tys `thenRn` \ (tys, fvs_s) -> - returnRn (tys, plusFVs fvs_s) +rnHsTypes doc tys = mapFvRn (rnHsType doc) tys \end{code} \begin{code} -rnContext :: SDoc -> RdrNameContext -> RnMS s (RenamedContext, FreeVars) +rnContext :: SDoc -> RdrNameContext -> RnMS (RenamedContext, FreeVars) rnContext doc ctxt = mapAndUnzipRn rn_ctxt ctxt `thenRn` \ (theta, fvs_s) -> @@ -659,152 +662,172 @@ rnContext doc ctxt %********************************************************* \begin{code} -rnIdInfo (HsStrictness str) = returnRn (HsStrictness str) +rnIdInfo (HsStrictness str) = returnRn (HsStrictness str, emptyFVs) -rnIdInfo (HsWorker worker cons) - -- The sole purpose of the "cons" field is so that we can mark the - -- constructors needed to build the wrapper as "needed", so that their - -- data type decl will be slurped in. After that their usefulness is - -- o'er, so we just put in the empty list. +rnIdInfo (HsWorker worker) = lookupOccRn worker `thenRn` \ worker' -> - mapRn lookupOccRn cons `thenRn_` - returnRn (HsWorker worker' []) - -rnIdInfo (HsUnfold inline (Just expr)) = rnCoreExpr expr `thenRn` \ expr' -> - returnRn (HsUnfold inline (Just expr')) -rnIdInfo (HsUnfold inline Nothing) = returnRn (HsUnfold inline Nothing) -rnIdInfo (HsArity arity) = returnRn (HsArity arity) -rnIdInfo (HsUpdate update) = returnRn (HsUpdate update) -rnIdInfo (HsNoCafRefs) = returnRn (HsNoCafRefs) -rnIdInfo (HsCprInfo cpr_info) = returnRn (HsCprInfo cpr_info) -rnIdInfo (HsSpecialise tyvars tys expr) - = bindTyVarsRn doc tyvars $ \ tyvars' -> - rnCoreExpr expr `thenRn` \ expr' -> - mapRn (rnIfaceType doc) tys `thenRn` \ tys' -> - returnRn (HsSpecialise tyvars' tys' expr') - where - doc = text "Specialise in interface pragma" + returnRn (HsWorker worker', unitFV worker') + +rnIdInfo (HsUnfold inline (Just expr)) = rnCoreExpr expr `thenRn` \ (expr', fvs) -> + returnRn (HsUnfold inline (Just expr'), fvs) +rnIdInfo (HsUnfold inline Nothing) = returnRn (HsUnfold inline Nothing, emptyFVs) +rnIdInfo (HsArity arity) = returnRn (HsArity arity, emptyFVs) +rnIdInfo (HsUpdate update) = returnRn (HsUpdate update, emptyFVs) +rnIdInfo (HsNoCafRefs) = returnRn (HsNoCafRefs, emptyFVs) +rnIdInfo (HsCprInfo cpr_info) = returnRn (HsCprInfo cpr_info, emptyFVs) +rnIdInfo (HsSpecialise rule_body) = rnRuleBody rule_body `thenRn` \ (rule_body', fvs) -> + returnRn (HsSpecialise rule_body', fvs) + +rnRuleBody (UfRuleBody str vars args rhs) + = rnCoreBndrs vars $ \ vars' -> + mapFvRn rnCoreExpr args `thenRn` \ (args', fvs1) -> + rnCoreExpr rhs `thenRn` \ (rhs', fvs2) -> + returnRn (UfRuleBody str vars' args' rhs', fvs1 `plusFV` fvs2) \end{code} UfCore expressions. \begin{code} rnCoreExpr (UfType ty) - = rnIfaceType (text "unfolding type") ty `thenRn` \ ty' -> - returnRn (UfType ty') + = rnHsType (text "unfolding type") ty `thenRn` \ (ty', fvs) -> + returnRn (UfType ty', fvs) rnCoreExpr (UfVar v) = lookupOccRn v `thenRn` \ v' -> - returnRn (UfVar v') + returnRn (UfVar v', unitFV v') rnCoreExpr (UfCon con args) - = rnUfCon con `thenRn` \ con' -> - mapRn rnCoreExpr args `thenRn` \ args' -> - returnRn (UfCon con' args') + = rnUfCon con `thenRn` \ (con', fvs1) -> + mapFvRn rnCoreExpr args `thenRn` \ (args', fvs2) -> + returnRn (UfCon con' args', fvs1 `plusFV` fvs2) rnCoreExpr (UfTuple con args) = lookupOccRn con `thenRn` \ con' -> - mapRn rnCoreExpr args `thenRn` \ args' -> - returnRn (UfTuple con' args') + mapFvRn rnCoreExpr args `thenRn` \ (args', fvs) -> + returnRn (UfTuple con' args', fvs `addOneFV` con') rnCoreExpr (UfApp fun arg) - = rnCoreExpr fun `thenRn` \ fun' -> - rnCoreExpr arg `thenRn` \ arg' -> - returnRn (UfApp fun' arg') - -rnCoreExpr (UfCase scrut bndr alts) - = rnCoreExpr scrut `thenRn` \ scrut' -> - bindLocalsRn "a UfCase" [bndr] $ \ [bndr'] -> - mapRn rnCoreAlt alts `thenRn` \ alts' -> - returnRn (UfCase scrut' bndr' alts') + = rnCoreExpr fun `thenRn` \ (fun', fv1) -> + rnCoreExpr arg `thenRn` \ (arg', fv2) -> + returnRn (UfApp fun' arg', fv1 `plusFV` fv2) + +rnCoreExpr (UfCase scrut bndr alts) + = rnCoreExpr scrut `thenRn` \ (scrut', fvs1) -> + bindCoreLocalFVRn bndr ( \ bndr' -> + mapFvRn rnCoreAlt alts `thenRn` \ (alts', fvs2) -> + returnRn (UfCase scrut' bndr' alts', fvs2) + ) `thenRn` \ (case', fvs3) -> + returnRn (case', fvs1 `plusFV` fvs3) rnCoreExpr (UfNote note expr) - = rnNote note `thenRn` \ note' -> - rnCoreExpr expr `thenRn` \ expr' -> - returnRn (UfNote note' expr') + = rnNote note `thenRn` \ (note', fvs1) -> + rnCoreExpr expr `thenRn` \ (expr', fvs2) -> + returnRn (UfNote note' expr', fvs1 `plusFV` fvs2) rnCoreExpr (UfLam bndr body) = rnCoreBndr bndr $ \ bndr' -> - rnCoreExpr body `thenRn` \ body' -> - returnRn (UfLam bndr' body') + rnCoreExpr body `thenRn` \ (body', fvs) -> + returnRn (UfLam bndr' body', fvs) rnCoreExpr (UfLet (UfNonRec bndr rhs) body) - = rnCoreExpr rhs `thenRn` \ rhs' -> - rnCoreBndr bndr $ \ bndr' -> - rnCoreExpr body `thenRn` \ body' -> - returnRn (UfLet (UfNonRec bndr' rhs') body') + = rnCoreExpr rhs `thenRn` \ (rhs', fvs1) -> + rnCoreBndr bndr ( \ bndr' -> + rnCoreExpr body `thenRn` \ (body', fvs2) -> + returnRn (UfLet (UfNonRec bndr' rhs') body', fvs2) + ) `thenRn` \ (result, fvs3) -> + returnRn (result, fvs1 `plusFV` fvs3) rnCoreExpr (UfLet (UfRec pairs) body) = rnCoreBndrs bndrs $ \ bndrs' -> - mapRn rnCoreExpr rhss `thenRn` \ rhss' -> - rnCoreExpr body `thenRn` \ body' -> - returnRn (UfLet (UfRec (bndrs' `zip` rhss')) body') + mapFvRn rnCoreExpr rhss `thenRn` \ (rhss', fvs1) -> + rnCoreExpr body `thenRn` \ (body', fvs2) -> + returnRn (UfLet (UfRec (bndrs' `zip` rhss')) body', fvs1 `plusFV` fvs2) where (bndrs, rhss) = unzip pairs \end{code} \begin{code} rnCoreBndr (UfValBinder name ty) thing_inside - = rnIfaceType (text str) ty `thenRn` \ ty' -> - bindLocalsRn str [name] $ \ [name'] -> - thing_inside (UfValBinder name' ty') + = rnHsType doc ty `thenRn` \ (ty', fvs1) -> + bindCoreLocalFVRn name ( \ name' -> + thing_inside (UfValBinder name' ty') + ) `thenRn` \ (result, fvs2) -> + returnRn (result, fvs1 `plusFV` fvs2) where - str = "unfolding id" + doc = text "unfolding id" rnCoreBndr (UfTyBinder name kind) thing_inside - = bindLocalsRn "an unfolding tyvar" [name] $ \ [name'] -> + = bindCoreLocalFVRn name $ \ name' -> thing_inside (UfTyBinder name' kind) -rnCoreBndrs bndrs thing_inside -- Expect them all to be ValBinders - = mapRn (rnIfaceType (text str)) tys `thenRn` \ tys' -> - bindLocalsRn str names $ \ names' -> - thing_inside (zipWith UfValBinder names' tys') - where - str = "unfolding id" - names = map (\ (UfValBinder name _ ) -> name) bndrs - tys = map (\ (UfValBinder _ ty) -> ty) bndrs +rnCoreBndrs [] thing_inside = thing_inside [] +rnCoreBndrs (b:bs) thing_inside = rnCoreBndr b $ \ name' -> + rnCoreBndrs bs $ \ names' -> + thing_inside (name':names') \end{code} \begin{code} rnCoreAlt (con, bndrs, rhs) - = rnUfCon con `thenRn` \ con' -> - bindLocalsRn "an unfolding alt" bndrs $ \ bndrs' -> - rnCoreExpr rhs `thenRn` \ rhs' -> - returnRn (con', bndrs', rhs') - + = rnUfCon con `thenRn` \ (con', fvs1) -> + bindCoreLocalsFVRn bndrs ( \ bndrs' -> + rnCoreExpr rhs `thenRn` \ (rhs', fvs2) -> + returnRn ((con', bndrs', rhs'), fvs2) + ) `thenRn` \ (result, fvs3) -> + returnRn (result, fvs1 `plusFV` fvs3) rnNote (UfCoerce ty) - = rnIfaceType (text "unfolding coerce") ty `thenRn` \ ty' -> - returnRn (UfCoerce ty') + = rnHsType (text "unfolding coerce") ty `thenRn` \ (ty', fvs) -> + returnRn (UfCoerce ty', fvs) -rnNote (UfSCC cc) = returnRn (UfSCC cc) -rnNote UfInlineCall = returnRn UfInlineCall +rnNote (UfSCC cc) = returnRn (UfSCC cc, emptyFVs) +rnNote UfInlineCall = returnRn (UfInlineCall, emptyFVs) +rnNote UfInlineMe = returnRn (UfInlineMe, emptyFVs) rnUfCon UfDefault - = returnRn UfDefault + = returnRn (UfDefault, emptyFVs) rnUfCon (UfDataCon con) = lookupOccRn con `thenRn` \ con' -> - returnRn (UfDataCon con') + returnRn (UfDataCon con', unitFV con') rnUfCon (UfLitCon lit) - = returnRn (UfLitCon lit) + = returnRn (UfLitCon lit, emptyFVs) rnUfCon (UfLitLitCon lit ty) - = rnIfaceType (text "litlit") ty `thenRn` \ ty' -> - returnRn (UfLitLitCon lit ty') + = rnHsType (text "litlit") ty `thenRn` \ (ty', fvs) -> + returnRn (UfLitLitCon lit ty', fvs) rnUfCon (UfPrimOp op) = lookupOccRn op `thenRn` \ op' -> - returnRn (UfPrimOp op') + returnRn (UfPrimOp op', emptyFVs) rnUfCon (UfCCallOp str is_dyn casm gc) - = returnRn (UfCCallOp str is_dyn casm gc) + = returnRn (UfCCallOp str is_dyn casm gc, emptyFVs) \end{code} %********************************************************* %* * +\subsection{Rule shapes} +%* * +%********************************************************* + +Check the shape of a transformation rule LHS. Currently +we only allow LHSs of the form (f e1 .. en), where f is +not one of the forall'd variables. + +\begin{code} +validRuleLhs foralls lhs + = check lhs + where + check (HsApp e1 e2) = check e1 + check (HsVar v) | v `notElem` foralls = True + check other = False +\end{code} + + +%********************************************************* +%* * \subsection{Errors} %* * %********************************************************* @@ -831,11 +854,21 @@ badDataCon name forAllWarn doc ty tyvar | not opt_WarnUnusedMatches = returnRn () | otherwise - = addWarnRn ( + = getModeRn `thenRn` \ mode -> + case mode of { +#ifndef DEBUG + InterfaceMode -> returnRn () ; -- Don't warn of unused tyvars in interface files + -- unless DEBUG is on, in which case it is slightly + -- informative. They can arise from mkRhsTyLam, +#endif -- leading to (say) f :: forall a b. [b] -> [b] + other -> + + addWarnRn ( sep [ptext SLIT("The universally quantified type variable") <+> quotes (ppr tyvar), nest 4 (ptext SLIT("does not appear in the type") <+> quotes (ppr ty))] $$ (ptext SLIT("In") <+> doc)) + } forAllErr doc ty tyvar = addErrRn ( @@ -854,4 +887,15 @@ ctxtErr explicit_forall doc tyvars constraint ty ] $$ (ptext SLIT("In") <+> doc) + +badRuleLhsErr name lhs + = sep [ptext SLIT("Rule") <+> ptext name <> colon, + nest 4 (ptext SLIT("Illegal left-hand side:") <+> ppr lhs)] + $$ + ptext SLIT("LHS must be of form (f e1 .. en) where f is not forall'd") + +badRuleVar name var + = sep [ptext SLIT("Rule") <+> ptext name <> colon, + ptext SLIT("Forall'd variable") <+> quotes (ppr var) <+> + ptext SLIT("does not appear on left hand side")] \end{code}