From 99073d876ea762016683fb0b22b9d343ff864eb4 Mon Sep 17 00:00:00 2001 From: simonpj Date: Tue, 24 Oct 2000 08:40:11 +0000 Subject: [PATCH] [project @ 2000-10-24 08:40:09 by simonpj] Small wibbles --- ghc/compiler/absCSyn/PprAbsC.lhs | 11 ++++++----- ghc/compiler/codeGen/CgClosure.lhs | 7 ++++--- ghc/compiler/codeGen/CgHeapery.lhs | 26 +++++++++++++------------- ghc/compiler/coreSyn/CoreTidy.lhs | 19 ++++++++++++------- ghc/compiler/deSugar/DsForeign.lhs | 15 +++++---------- ghc/compiler/deSugar/DsMonad.lhs | 1 - ghc/compiler/deSugar/Match.lhs | 2 +- ghc/compiler/main/HscMain.lhs | 3 +-- ghc/compiler/main/HscTypes.lhs | 22 +++++++++++++--------- ghc/compiler/parser/Parser.y | 11 ++++------- ghc/compiler/rename/ParseIface.y | 6 +----- ghc/compiler/rename/Rename.lhs | 6 ++---- ghc/compiler/rename/RnIfaces.lhs | 26 +++++++++++++++----------- ghc/compiler/stgSyn/CoreToStg.lhs | 7 ++----- ghc/compiler/typecheck/TcDeriv.lhs | 4 ++-- ghc/compiler/typecheck/TcIfaceSig.lhs | 3 --- ghc/compiler/typecheck/TcInstDcls.lhs | 15 +++++++-------- ghc/compiler/typecheck/TcModule.lhs | 20 +++++++++----------- ghc/compiler/typecheck/TcTyDecls.lhs | 2 +- ghc/compiler/utils/Maybes.lhs | 16 +++++++++------- 20 files changed, 107 insertions(+), 115 deletions(-) diff --git a/ghc/compiler/absCSyn/PprAbsC.lhs b/ghc/compiler/absCSyn/PprAbsC.lhs index 2ad4595..5eb0cc1 100644 --- a/ghc/compiler/absCSyn/PprAbsC.lhs +++ b/ghc/compiler/absCSyn/PprAbsC.lhs @@ -56,6 +56,7 @@ import UniqSet ( emptyUniqSet, elementOfUniqSet, import StgSyn ( SRT(..) ) import BitSet ( intBS ) import Outputable +import GlaExts import Util ( nOfThem ) import ST @@ -1266,9 +1267,9 @@ pprMagicId BaseReg = ptext SLIT("BaseReg") pprMagicId (VanillaReg pk n) = hcat [ pprVanillaReg n, char '.', pprUnionTag pk ] -pprMagicId (FloatReg n) = (<>) (ptext SLIT("F")) (int IBOX(n)) -pprMagicId (DoubleReg n) = (<>) (ptext SLIT("D")) (int IBOX(n)) -pprMagicId (LongReg _ n) = (<>) (ptext SLIT("L")) (int IBOX(n)) +pprMagicId (FloatReg n) = ptext SLIT("F") <> int (I# n) +pprMagicId (DoubleReg n) = ptext SLIT("D") <> int (I# n) +pprMagicId (LongReg _ n) = ptext SLIT("L") <> int (I# n) pprMagicId Sp = ptext SLIT("Sp") pprMagicId Su = ptext SLIT("Su") pprMagicId SpLim = ptext SLIT("SpLim") @@ -1277,8 +1278,8 @@ pprMagicId HpLim = ptext SLIT("HpLim") pprMagicId CurCostCentre = ptext SLIT("CCCS") pprMagicId VoidReg = panic "pprMagicId:VoidReg!" -pprVanillaReg :: FastInt -> SDoc -pprVanillaReg n = (<>) (char 'R') (int IBOX(n)) +pprVanillaReg :: Int# -> SDoc +pprVanillaReg n = char 'R' <> int (I# n) pprUnionTag :: PrimRep -> SDoc diff --git a/ghc/compiler/codeGen/CgClosure.lhs b/ghc/compiler/codeGen/CgClosure.lhs index 34a84cc..b2bd1fe 100644 --- a/ghc/compiler/codeGen/CgClosure.lhs +++ b/ghc/compiler/codeGen/CgClosure.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CgClosure.lhs,v 1.41 2000/07/14 08:14:53 simonpj Exp $ +% $Id: CgClosure.lhs,v 1.42 2000/10/24 08:40:09 simonpj Exp $ % \section[CgClosure]{Code generation for closures} @@ -57,7 +57,8 @@ import Outputable import Name ( nameOccName ) import OccName ( occNameFS ) - +import FastTypes ( iBox ) + getWrapperArgTypeCategories = panic "CgClosure.getWrapperArgTypeCategories (ToDo)" \end{code} @@ -539,7 +540,7 @@ argSatisfactionCheck closure_info arg_regs getSpRelOffset 0 `thenFC` \ (SpRel sp) -> let - off = I# sp + off = iBox sp rel_arg = mkIntCLit off in ASSERT(off /= 0) diff --git a/ghc/compiler/codeGen/CgHeapery.lhs b/ghc/compiler/codeGen/CgHeapery.lhs index 6ec7c84..be8e4e0 100644 --- a/ghc/compiler/codeGen/CgHeapery.lhs +++ b/ghc/compiler/codeGen/CgHeapery.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CgHeapery.lhs,v 1.23 2000/07/26 14:48:16 simonmar Exp $ +% $Id: CgHeapery.lhs,v 1.24 2000/10/24 08:40:10 simonpj Exp $ % \section[CgHeapery]{Heap management functions} @@ -197,7 +197,7 @@ fastEntryChecks regs tags ret node_points code tag_assts free_reg = case length regs + 1 of - IBOX(x) -> CReg (VanillaReg PtrRep x) + I# x -> CReg (VanillaReg PtrRep x) all_pointers = all pointer regs pointer (VanillaReg rep _) = isFollowableRep rep @@ -283,19 +283,19 @@ altHeapCheck is_fun regs tags fail_code (Just ret_addr) code tag_assts -} -- this will cover all cases for x86 - [VanillaReg rep ILIT(1)] + [VanillaReg rep 1#] | isFollowableRep rep -> CCheck HP_CHK_UT_ALT [mkIntCLit words_required, mkIntCLit 1, mkIntCLit 0, - CReg (VanillaReg RetRep ILIT(2)), + CReg (VanillaReg RetRep 2#), CLbl (mkReturnInfoLabel ret_addr) RetRep] tag_assts | otherwise -> CCheck HP_CHK_UT_ALT [mkIntCLit words_required, mkIntCLit 0, mkIntCLit 1, - CReg (VanillaReg RetRep ILIT(2)), + CReg (VanillaReg RetRep 2#), CLbl (mkReturnInfoLabel ret_addr) RetRep] tag_assts @@ -304,7 +304,7 @@ altHeapCheck is_fun regs tags fail_code (Just ret_addr) code in CCheck HP_CHK_GEN [mkIntCLit words_required, - mkIntCLit (IBOX(word2Int# liveness)), + mkIntCLit (I# (word2Int# liveness)), -- HP_CHK_GEN needs a direct return address, -- not an info table (might be different if -- we're not assembly-mangling/tail-jumping etc.) @@ -346,7 +346,7 @@ altHeapCheck is_fun regs [] AbsCNop Nothing code -- We need this case because the closure in Node won't return -- directly when we enter it (it could be a function), so the -- heap check code needs to push a seq frame on top of the stack. - [VanillaReg rep ILIT(1)] + [VanillaReg rep 1#] | rep == PtrRep && is_fun -> CCheck HP_CHK_SEQ_NP @@ -354,7 +354,7 @@ altHeapCheck is_fun regs [] AbsCNop Nothing code AbsCNop -- R1 is lifted (the common case) - [VanillaReg rep ILIT(1)] + [VanillaReg rep 1#] | rep == PtrRep -> CCheck HP_CHK_NP [mkIntCLit words_required, mkIntCLit 1{-regs live-}] @@ -369,15 +369,15 @@ altHeapCheck is_fun regs [] AbsCNop Nothing code CCheck HP_CHK_UNBX_R1 [mkIntCLit words_required] AbsCNop -- FloatReg1 - [FloatReg ILIT(1)] -> + [FloatReg 1#] -> CCheck HP_CHK_F1 [mkIntCLit words_required] AbsCNop -- DblReg1 - [DoubleReg ILIT(1)] -> + [DoubleReg 1#] -> CCheck HP_CHK_D1 [mkIntCLit words_required] AbsCNop -- LngReg1 - [LongReg _ ILIT(1)] -> + [LongReg _ 1#] -> CCheck HP_CHK_L1 [mkIntCLit words_required] AbsCNop #ifdef DEBUG @@ -406,7 +406,7 @@ fetchAndReschedule regs node_reqd = where liveness_mask = mkRegLiveness regs reschedule_code = absC (CMacroStmt GRAN_RESCHEDULE [ - mkIntCLit (IBOX(word2Int# liveness_mask)), + mkIntCLit (I# (word2Int# liveness_mask)), mkIntCLit (if node_reqd then 1 else 0)]) --HWL: generate GRAN_FETCH macro for GrAnSim @@ -440,7 +440,7 @@ yield regs node_reqd = liveness_mask = mkRegLiveness regs yield_code = absC (CMacroStmt GRAN_YIELD - [mkIntCLit (IBOX(word2Int# liveness_mask))]) + [mkIntCLit (I# (word2Int# liveness_mask))]) \end{code} \begin{code} diff --git a/ghc/compiler/coreSyn/CoreTidy.lhs b/ghc/compiler/coreSyn/CoreTidy.lhs index 3fbdc74..6254817 100644 --- a/ghc/compiler/coreSyn/CoreTidy.lhs +++ b/ghc/compiler/coreSyn/CoreTidy.lhs @@ -11,7 +11,7 @@ module CoreTidy ( #include "HsVersions.h" -import CmdLineOpts ( opt_D_dump_simpl, opt_D_verbose_core2core, opt_UsageSPOn ) +import CmdLineOpts ( DynFlags, DynFlag(..), opt_UsageSPOn, dopt ) import CoreSyn import CoreUnfold ( noUnfolding ) import CoreLint ( beginPass, endPass ) @@ -34,7 +34,7 @@ import Name ( getOccName, tidyTopName, mkLocalName, isLocallyDefined ) import OccName ( initTidyOccEnv, tidyOccName ) import Type ( tidyTopType, tidyType, tidyTypes, tidyTyVar, tidyTyVars ) import Module ( Module ) -import UniqSupply ( UniqSupply ) +import UniqSupply ( mkSplitUniqSupply ) import Unique ( Uniquable(..) ) import SrcLoc ( noSrcLoc ) import Util ( mapAccumL ) @@ -66,22 +66,27 @@ Several tasks are done by @tidyCorePgm@ from the uniques for local thunks etc.] \begin{code} -tidyCorePgm :: UniqSupply -> Module -> [CoreBind] -> RuleBase +tidyCorePgm :: DynFlags -> Module -> [CoreBind] -> RuleBase -> IO ([CoreBind], [ProtoCoreRule]) -tidyCorePgm us module_name binds_in rulebase_in +tidyCorePgm dflags module_name binds_in rulebase_in = do - beginPass "Tidy Core" + us <- mkSplitUniqSupply 'u' + + beginPass dflags "Tidy Core" binds_in1 <- if opt_UsageSPOn then _scc_ "CoreUsageSPInf" - doUsageSPInf us binds_in rulebase_in + doUsageSPInf dflags us binds_in rulebase_in else return binds_in let (tidy_env1, binds_out) = mapAccumL (tidyBind (Just module_name)) init_tidy_env binds_in1 rules_out = tidyProtoRules tidy_env1 (mk_local_protos rulebase_in) - endPass "Tidy Core" (opt_D_dump_simpl || opt_D_verbose_core2core) binds_out + endPass dflags "Tidy Core" (dopt Opt_D_dump_simpl dflags || + dopt Opt_D_verbose_core2core dflags) + binds_out + return (binds_out, rules_out) where -- We also make sure to avoid any exported binders. Consider diff --git a/ghc/compiler/deSugar/DsForeign.lhs b/ghc/compiler/deSugar/DsForeign.lhs index 12df319..a5dbf53 100644 --- a/ghc/compiler/deSugar/DsForeign.lhs +++ b/ghc/compiler/deSugar/DsForeign.lhs @@ -32,18 +32,13 @@ import Name ( mkGlobalName, nameModule, nameOccName, getOccString, import Type ( unUsgTy, repType, splitTyConApp_maybe, splitFunTys, splitForAllTys, Type, mkFunTys, mkForAllTys, mkTyConApp, - mkTyVarTy, mkFunTy, splitAppTy, applyTy, funResultTy - ) -import PrimOp ( PrimOp(..), CCall(..), - CCallTarget(..), dynamicTarget ) -import TysWiredIn ( unitTy, addrTy, stablePtrTyCon, - addrDataCon + mkFunTy, splitAppTy, applyTy, funResultTy ) +import PrimOp ( CCall(..), CCallTarget(..), dynamicTarget ) +import TysWiredIn ( unitTy, addrTy, stablePtrTyCon ) import TysPrim ( addrPrimTy ) -import PrelNames ( Uniquable(..), hasKey, - ioTyConKey, deRefStablePtrName, returnIOIdKey, - bindIOName, - returnIOName, makeStablePtrName +import PrelNames ( hasKey, ioTyConKey, deRefStablePtrName, + bindIOName, returnIOName, makeStablePtrName ) import Outputable diff --git a/ghc/compiler/deSugar/DsMonad.lhs b/ghc/compiler/deSugar/DsMonad.lhs index 5516cef..ecddeb4 100644 --- a/ghc/compiler/deSugar/DsMonad.lhs +++ b/ghc/compiler/deSugar/DsMonad.lhs @@ -37,7 +37,6 @@ import Type ( Type ) import UniqSupply ( initUs_, splitUniqSupply, uniqFromSupply, uniqsFromSupply, UniqSM, UniqSupply ) import Unique ( Unique ) -import UniqFM ( lookupWithDefaultUFM_Directly ) import Util ( zipWithEqual ) import Name ( Name, lookupNameEnv ) import HscTypes ( HomeSymbolTable, PersistentCompilerState(..), diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs index f65de3c..67f4851 100644 --- a/ghc/compiler/deSugar/Match.lhs +++ b/ghc/compiler/deSugar/Match.lhs @@ -8,7 +8,7 @@ module Match ( match, matchExport, matchWrapper, matchSimply, matchSinglePat ) w #include "HsVersions.h" -import CmdLineOpts ( DynFlag(..), DynFlags, dopt ) +import CmdLineOpts ( DynFlag(..), dopt ) import HsSyn import TcHsSyn ( TypecheckedPat, TypecheckedMatch ) import DsHsSyn ( outPatType ) diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index 797c850..2c1be78 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -111,7 +111,6 @@ hscMain flags core_cmds stg_cmds summary maybe_old_iface mkSplitUniqSupply 'd' >>= \ ds_uniqs -> -- desugarer mkSplitUniqSupply 'r' >>= \ ru_uniqs -> -- rules mkSplitUniqSupply 'c' >>= \ c2s_uniqs -> -- core-to-stg - mkSplitUniqSupply 'u' >>= \ tidy_uniqs -> -- tidy up mkSplitUniqSupply 'g' >>= \ st_uniqs -> -- stg-to-stg passes mkSplitUniqSupply 'n' >>= \ ncg_uniqs -> -- native-code generator @@ -158,7 +157,7 @@ hscMain flags core_cmds stg_cmds summary maybe_old_iface core2core core_cmds desugared rules >>= \ (simplified, orphan_rules) -> -- Do the final tidy-up - tidyCorePgm tidy_uniqs this_mod + tidyCorePgm this_mod simplified orphan_rules >>= \ (tidy_binds, tidy_orphan_rules) -> -- Run the occurrence analyser one last time, so that diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs index ee3c9e2..1b34ec0 100644 --- a/ghc/compiler/main/HscTypes.lhs +++ b/ghc/compiler/main/HscTypes.lhs @@ -9,7 +9,8 @@ module HscTypes ( ModDetails(..), ModIface(..), GlobalSymbolTable, HomeSymbolTable, PackageSymbolTable, - HomeIfaceTable, PackageIfaceTable, + HomeIfaceTable, PackageIfaceTable, + lookupTable, IfaceDecls(..), @@ -19,8 +20,6 @@ module HscTypes ( TypeEnv, extendTypeEnv, lookupTypeEnv, - lookupFixityEnv, - WhetherHasOrphans, ImportVersion, WhatsImported(..), PersistentRenamerState(..), IsBootInterface, Avails, DeclsMap, IfaceInsts, IfaceRules, GatedDecl, @@ -68,6 +67,7 @@ import Type ( Type ) import FiniteMap ( FiniteMap, emptyFM, addToFM, lookupFM, foldFM ) import Bag ( Bag ) +import Maybes ( seqMaybe ) import UniqFM ( UniqFM ) import Outputable import SrcLoc ( SrcLoc, isGoodSrcLoc ) @@ -118,7 +118,10 @@ data ModIface mi_version :: VersionInfo, -- Module version number mi_orphan :: WhetherHasOrphans, -- Whether this module has orphans - mi_usages :: [ImportVersion Name], -- Usages; kept sorted + mi_usages :: [ImportVersion Name], -- Usages; kept sorted so that it's easy + -- to decide whether to write a new iface file + -- (changing usages doesn't affect the version of + -- this module) mi_exports :: Avails, -- What it exports -- Kept sorted by (mod,occ), @@ -182,11 +185,12 @@ type GlobalSymbolTable = SymbolTable -- Domain = all modules Simple lookups in the symbol table. \begin{code} -lookupFixityEnv :: IfaceTable -> Name -> Maybe Fixity -lookupFixityEnv tbl name - = case lookupModuleEnv tbl (nameModule name) of - Nothing -> Nothing - Just details -> lookupNameEnv (mi_fixities details) name +lookupTable :: ModuleEnv a -> ModuleEnv a -> Name -> Maybe a +-- We often have two Symbol- or IfaceTables, and want to do a lookup +lookupTable ht pt name + = lookupModuleEnv ht mod `seqMaybe` lookupModuleEnv pt mod + where + mod = nameModule name \end{code} diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y index f228ea8..d82fe3f 100644 --- a/ghc/compiler/parser/Parser.y +++ b/ghc/compiler/parser/Parser.y @@ -1,6 +1,6 @@ {- ----------------------------------------------------------------------------- -$Id: Parser.y,v 1.42 2000/10/24 07:35:01 simonpj Exp $ +$Id: Parser.y,v 1.43 2000/10/24 08:40:10 simonpj Exp $ Haskell grammar. @@ -332,14 +332,12 @@ topdecl :: { RdrBinding } | srcloc 'data' ctype '=' constrs deriving {% checkDataHeader $3 `thenP` \(cs,c,ts) -> returnP (RdrHsDecl (TyClD - (mkTyData DataType cs c ts (reverse $5) (length $5) $6 - NoDataPragmas $1))) } + (mkTyData DataType cs c ts (reverse $5) (length $5) $6 $1))) } | srcloc 'newtype' ctype '=' newconstr deriving {% checkDataHeader $3 `thenP` \(cs,c,ts) -> returnP (RdrHsDecl (TyClD - (mkTyData NewType cs c ts [$5] 1 $6 - NoDataPragmas $1))) } + (mkTyData NewType cs c ts [$5] 1 $6 $1))) } | srcloc 'class' ctype fds where {% checkDataHeader $3 `thenP` \(cs,c,ts) -> @@ -347,8 +345,7 @@ topdecl :: { RdrBinding } (binds,sigs) = cvMonoBindsAndSigs cvClassOpSig (groupBindings $5) in returnP (RdrHsDecl (TyClD - (mkClassDecl cs c ts $4 sigs binds - NoClassPragmas $1))) } + (mkClassDecl cs c ts $4 sigs binds $1))) } | srcloc 'instance' inst_type where { let (binds,sigs) diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y index 94f29f1..a51631f 100644 --- a/ghc/compiler/rename/ParseIface.y +++ b/ghc/compiler/rename/ParseIface.y @@ -630,10 +630,6 @@ qdata_name :: { RdrName } qdata_name : data_name { $1 } | qdata_fs { mkSysQual dataName $1 } -qdata_names :: { [RdrName] } -qdata_names : { [] } - | qdata_name qdata_names { $1 : $2 } - var_or_data_name :: { RdrName } : var_name { $1 } | data_name { $1 } @@ -721,7 +717,7 @@ akind :: { Kind } -------------------------------------------------------------------------- id_info :: { [HsIdInfo RdrName] } - : { [] } + : id_info_item { [$1] } | id_info_item id_info { $1 : $2 } id_info_item :: { HsIdInfo RdrName } diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index 0cc7b3f..2f14e0d 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -75,9 +75,7 @@ renameModule :: DynFlags -> Finder -> HomeIfaceTable -> HomeSymbolTable -> PersistentCompilerState -> Module -> RdrNameHsModule - -> IO (PersistentCompilerState, Maybe ModIface) - -- The mi_decls in the ModIface include - -- ones imported from packages too + -> IO (PersistentCompilerState, Maybe (ModIface, [RenamedHsDecl])) renameModule dflags finder hit hst old_pcs this_module this_mod@(HsModule _ _ _ _ _ _ loc) @@ -110,7 +108,7 @@ rename this_module this_mod@(HsModule mod_name vers exports imports local_decls case maybe_stuff of { Nothing -> -- Everything is up to date; no need to recompile further rnDump [] [] `thenRn` \ dump_action -> - returnRn (Nothing, [], dump_action) ; + returnRn (Nothing, dump_action) ; Just (gbl_env, local_gbl_env, export_avails, global_avail_env) -> diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs index 4452723..6ff626d 100644 --- a/ghc/compiler/rename/RnIfaces.lhs +++ b/ghc/compiler/rename/RnIfaces.lhs @@ -98,10 +98,17 @@ loadInterface doc mod from tryLoadInterface :: SDoc -> ModuleName -> WhereFrom -> RnM d (Ifaces, Maybe Message) -- Returns (Just err) if an error happened - -- Guarantees to return with iImpModInfo m --> (... Just cts) - -- (If the load fails, we plug in a vanilla placeholder + -- Guarantees to return with iImpModInfo m --> (..., True) + -- (If the load fails, we plug in a vanilla placeholder) tryLoadInterface doc_str mod_name from - = getIfacesRn `thenRn` \ ifaces -> + = getHomeIfaceTableRn `thenRn` \ hit -> + getIfacesRn `thenRn` \ ifaces -> + + -- Check whether we have it already in the home package + case lookupModuleEnvByName hit mod_name of { + Just _ -> returnRn (ifaces, Nothing) ; -- In the home package + Nothing -> + let mod_map = iImpModInfo ifaces mod_info = lookupFM mod_map mod_name @@ -205,7 +212,7 @@ tryLoadInterface doc_str mod_name from in setIfacesRn new_ifaces `thenRn_` returnRn (new_ifaces, Nothing) - }} + }}} ----------------------------------------------------- -- Adding module dependencies from the @@ -697,14 +704,11 @@ lookupFixityRn name -- right away (after all, it's possible that nothing from B will be used). -- When we come across a use of 'f', we need to know its fixity, and it's then, -- and only then, that we load B.hi. That is what's happening here. - = getHomeIfaceTableRn `thenRn` \ hst -> - case lookupFixityEnv hst name of { - Just fixity -> returnRn fixity ; - Nothing -> - + = getHomeIfaceTableRn `thenRn` \ hit -> loadHomeInterface doc name `thenRn` \ ifaces -> - returnRn (lookupFixityEnv (iPIT ifaces) name `orElse` defaultFixity) - } + case lookupTable hit (iPIT ifaces) name of + Just iface -> returnRn (lookupNameEnv (mi_fixities iface) name `orElse` defaultFixity) + Nothing -> returnRn defaultFixity where doc = ptext SLIT("Checking fixity for") <+> ppr name \end{code} diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs index 73712b1..bcb1d9d 100644 --- a/ghc/compiler/stgSyn/CoreToStg.lhs +++ b/ghc/compiler/stgSyn/CoreToStg.lhs @@ -36,7 +36,6 @@ import Type ( isUnLiftedType, isUnboxedTupleType, Type, splitFunTy_maybe, ) import UniqSupply -- all of it, really import BasicTypes ( TopLevelFlag(..), isNotTopLevel ) -import CmdLineOpts ( opt_D_verbose_stg2stg ) import UniqSet ( emptyUniqSet ) import Maybes import Outputable @@ -167,12 +166,10 @@ locations. \begin{code} bOGUS_LVs :: StgLiveVars -bOGUS_LVs | opt_D_verbose_stg2stg = emptyUniqSet - | otherwise =panic "bOGUS_LVs" +bOGUS_LVs = emptyUniqSet bOGUS_FVs :: [Id] -bOGUS_FVs | opt_D_verbose_stg2stg = [] - | otherwise = panic "bOGUS_FVs" +bOGUS_FVs = [] \end{code} \begin{code} diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs index a4a13d0..dac3e4a 100644 --- a/ghc/compiler/typecheck/TcDeriv.lhs +++ b/ghc/compiler/typecheck/TcDeriv.lhs @@ -28,6 +28,7 @@ import RnMonad ( --RnNameSupply, renameSourceCode, thenRn, mapRn, returnRn ) import HscTypes ( DFunId, GlobalSymbolTable, PersistentRenamerState ) +import BasicTypes ( Fixity ) import Bag ( Bag, emptyBag, unionBags, listToBag ) import Class ( classKey, Class ) import ErrUtils ( dumpIfSet_dyn, Message ) @@ -39,7 +40,6 @@ import Maybes ( maybeToBool, catMaybes ) import Module ( Module ) import Name ( Name, isLocallyDefined, getSrcLoc, NamedThing(..) ) import RdrName ( RdrName ) ---import RnMonad ( FixityEnv ) import TyCon ( tyConTyVars, tyConDataCons, tyConDerivings, tyConTheta, maybeTyConSingleCon, isDataTyCon, @@ -258,7 +258,7 @@ tcDeriving prs mod inst_env_in get_fixity local_tycons iBinds = binds, iLoc = getSrcLoc dfun, iPrags = [] } where - (tyvars, theta, tau, clas, tys) = splitDFunTy (idType dfun) + (tyvars, theta, clas, tys) = splitDFunTy (idType dfun) rn_meths meths = rnMethodBinds [] meths `thenRn` \ (meths', _) -> returnRn meths' -- Ignore the free vars returned diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs index f1a747f..f03bb4f 100644 --- a/ghc/compiler/typecheck/TcIfaceSig.lhs +++ b/ghc/compiler/typecheck/TcIfaceSig.lhs @@ -257,9 +257,6 @@ tcCoreExpr (UfNote note expr) UfInlineCall -> returnTc (Note InlineCall expr') UfInlineMe -> returnTc (Note InlineMe expr') UfSCC cc -> returnTc (Note (SCC cc) expr') - -tcCoreNote (UfSCC cc) = returnTc (SCC cc) -tcCoreNote UfInlineCall = returnTc InlineCall \end{code} \begin{code} diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index 245e762..571ebf7 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -11,15 +11,15 @@ module TcInstDcls ( tcInstDecls1, tcInstDecls2, tcAddDeclCtxt ) where import CmdLineOpts ( DynFlag(..), dopt ) -import HsSyn ( HsDecl(..), InstDecl(..), TyClDecl(..), - MonoBinds(..), HsExpr(..), HsLit(..), Sig(..), +import HsSyn ( HsDecl(..), InstDecl(..), TyClDecl(..), InPat(..), + MonoBinds(..), HsExpr(..), HsLit(..), Sig(..), Match(..), andMonoBindList, collectMonoBinders, isClassDecl ) import HsTypes ( HsType (..), HsTyVarBndr(..), toHsTyVar ) -import HsPat ( InPat (..) ) -import HsMatches ( Match (..) ) -import RnHsSyn ( RenamedHsBinds, RenamedInstDecl, RenamedHsDecl, - extractHsTyVars ) +import RnHsSyn ( RenamedHsBinds, RenamedInstDecl, RenamedHsDecl, RenamedMonoBinds, + RenamedTyClDecl, RenamedHsType, + extractHsTyVars, maybeGenericMatch + ) import TcHsSyn ( TcMonoBinds, mkHsConApp ) import TcBinds ( tcSpecSigs ) import TcClassDcl ( tcMethodBind, badMethodErr ) @@ -70,11 +70,10 @@ import Name ( Name, NameEnv, extendNameEnv_C, emptyNameEnv, plusNameEnv_C, nameEnvElts ) import FiniteMap ( mapFM ) import SrcLoc ( SrcLoc ) -import RnHsSyn -- ( RenamedMonoBinds ) import VarSet ( varSetElems ) import UniqFM ( mapUFM ) import Unique ( Uniquable(..) ) -import BasicTypes ( NewOrData(..) ) +import BasicTypes ( NewOrData(..), Fixity ) import ErrUtils ( dumpIfSet_dyn ) import ListSetOps ( Assoc, emptyAssoc, plusAssoc_C, mapAssoc, assocElts, extendAssoc_C, diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs index cd9aaca..a47d783 100644 --- a/ghc/compiler/typecheck/TcModule.lhs +++ b/ghc/compiler/typecheck/TcModule.lhs @@ -44,8 +44,8 @@ import Bag ( isEmptyBag ) import ErrUtils ( printErrorsAndWarnings, dumpIfSet_dyn ) import Id ( idType, idName, idUnfolding ) import Module ( Module, moduleName, plusModuleEnv ) -import Name ( nameOccName, isLocallyDefined, isGlobalName, - toRdrName, nameEnvElts, emptyNameEnv +import Name ( Name, nameOccName, isLocallyDefined, isGlobalName, + toRdrName, nameEnvElts, emptyNameEnv, lookupNameEnv ) import TyCon ( TyCon, isDataTyCon, tyConName, tyConGenInfo ) import OccName ( isSysOcc ) @@ -53,14 +53,14 @@ import TyCon ( TyCon, isClassTyCon ) import Class ( Class ) import PrelNames ( mAIN_Name, mainName ) import UniqSupply ( UniqSupply ) -import Maybes ( maybeToBool ) +import Maybes ( maybeToBool, thenMaybe ) import Util -import BasicTypes ( EP(..) ) +import BasicTypes ( EP(..), Fixity ) import Bag ( Bag, isEmptyBag ) import Outputable -import HscTypes ( PersistentCompilerState(..), HomeSymbolTable, - PackageSymbolTable, DFunId, - TypeEnv, extendTypeEnv, +import HscTypes ( PersistentCompilerState(..), HomeSymbolTable, HomeIfaceTable, + PackageSymbolTable, PackageIfaceTable, DFunId, ModIface(..), + TypeEnv, extendTypeEnv, lookupTable, TyThing(..), groupTyThings ) import FiniteMap ( FiniteMap, delFromFM, lookupWithDefaultFM ) \end{code} @@ -107,10 +107,8 @@ typecheckModule dflags this_mod pcs hst hit pit (HsModule mod_name _ _ _ decls _ -> tcModule pcs hst get_fixity this_mod decls unf_env) get_fixity :: Name -> Maybe Fixity - get_fixity nm - = case lookupFixityEnv hit nm of - Just f -> Just f - Nothing -> lookupFixityEnv pit nm + get_fixity nm = lookupTable hit pit nm `thenMaybe` \ iface -> + lookupNameEnv (mi_fixities iface) nm \end{code} The internal monster: diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs index 0392d34..c44fef2 100644 --- a/ghc/compiler/typecheck/TcTyDecls.lhs +++ b/ghc/compiler/typecheck/TcTyDecls.lhs @@ -25,7 +25,7 @@ import TcMonoType ( tcHsType, tcHsSigType, tcHsBoxedSigType, tcHsTyVars, tcClass ) import TcEnv ( tcExtendTyVarEnv, tcLookupTyCon, tcLookupClass, tcLookupGlobalId, - TyThing(..), TyThingDetails(..) + TyThingDetails(..) ) import TcMonad diff --git a/ghc/compiler/utils/Maybes.lhs b/ghc/compiler/utils/Maybes.lhs index abaf1c1..3f94d34 100644 --- a/ghc/compiler/utils/Maybes.lhs +++ b/ghc/compiler/utils/Maybes.lhs @@ -15,13 +15,10 @@ module Maybes ( expectJust, maybeToBool, - failMaB, - failMaybe, - seqMaybe, - returnMaB, - returnMaybe, - thenMaB, - catMaybes + thenMaybe, seqMaybe, returnMaybe, failMaybe, catMaybes, + + thenMaB, returnMaB, failMaB + ) where #include "HsVersions.h" @@ -104,6 +101,11 @@ seqMaybe :: Maybe a -> Maybe a -> Maybe a seqMaybe (Just x) _ = Just x seqMaybe Nothing my = my +thenMaybe :: Maybe a -> (a -> Maybe b) -> Maybe b +thenMaybe ma mb = case ma of + Just x -> mb x + Nothing -> Nothing + returnMaybe :: a -> Maybe a returnMaybe = Just -- 1.7.10.4