Skip to content
GitLab
Commit a76db2a0 authored by simonpj's avatar simonpj
Browse files

[project @ 2000-10-24 10:36:08 by simonpj] 

Wibbles
parent 6a3f5f6b
Hide whitespace changes
Inline Side-by-side
ghc/compiler/rename/Rename.lhs
View file @ a76db2a0
......@@ -50,8 +50,8 @@ import PrelNames ( mAIN_Name, pREL_MAIN_Name, pRELUDE_Name,
)
import PrelInfo ( fractionalClassKeys, derivingOccurrences, wiredInThingEnv )
import Type ( namesOfType, funTyCon )
import ErrUtils ( printErrorsAndWarnings, dumpIfSet )
import Bag ( isEmptyBag, bagToList )
import ErrUtils ( dumpIfSet )
import Bag ( bagToList )
import FiniteMap ( FiniteMap, eltsFM, fmToList, emptyFM, lookupFM,
addToFM_C, elemFM, addToFM
)
......@@ -77,21 +77,17 @@ renameModule :: DynFlags -> Finder
-> Module -> RdrNameHsModule
-> IO (PersistentCompilerState, Maybe (ModIface, [RenamedHsDecl]))
renameModule dflags finder hit hst old_pcs this_module
this_mod@(HsModule _ _ _ _ _ _ loc)
renameModule dflags finder hit hst old_pcs this_module rdr_module
= -- Initialise the renamer monad
do {
((maybe_rn_stuff, dump_action), (rn_warns_bag, rn_errs_bag), new_pcs)
<- initRn dflags finder hit hst old_pcs this_module loc (rename this_module this_mod) ;
-- Check for warnings
printErrorsAndWarnings (rn_warns_bag, rn_errs_bag) ;
(new_pcs, errors_found, (maybe_rn_stuff, dump_action))
<- initRn dflags finder hit hst old_pcs this_module (rename this_module rdr_module) ;
-- Dump any debugging output
dump_action ;
-- Return results
if not (isEmptyBag rn_errs_bag) then
if errors_found then
return (old_pcs, Nothing)
else
return (new_pcs, maybe_rn_stuff)
......
ghc/compiler/rename/RnIfaces.lhs
View file @ a76db2a0
......@@ -10,13 +10,15 @@ module RnIfaces
getImportedInstDecls, getImportedRules,
lookupFixityRn,
importDecl, ImportDeclResult(..), recordLocalSlurps,
mkImportInfo, getSlurped
mkImportInfo, getSlurped,
recompileRequired
)
where
#include "HsVersions.h"
import CmdLineOpts ( opt_NoPruneDecls, opt_NoPruneTyDecls, opt_IgnoreIfacePragmas )
import CmdLineOpts ( DynFlags, opt_NoPruneDecls, opt_NoPruneTyDecls, opt_IgnoreIfacePragmas )
import HscTypes
import HsSyn ( HsDecl(..), InstDecl(..), HsType(..) )
import HsImpExp ( ImportDecl(..) )
......@@ -300,7 +302,7 @@ mkImportInfo this_mod imports
where
go_for_it exports = (mod_name, has_orphans, is_boot, exports) : so_far
mod_iface = lookupIface hit pit mod_name
mod_iface = lookupTableByModName hit pit mod_name `orElse` panic "mkImportInfo"
mod = mi_module mod_iface
is_lib_module = not (isModuleInThisPackage mod)
version_info = mi_version mod_iface
......@@ -495,14 +497,27 @@ that we know just what instances to bring into scope.
%* *
%********************************************************
@recompileRequired@ is called from the HscMain. It checks whether
a recompilation is required. It needs access to the persistent state,
finder, etc, because it may have to load lots of interface files to
check their versions.
\begin{code}
type RecompileRequired = Bool
upToDate = False -- Recompile not required
outOfDate = True -- Recompile required
recompileRequired :: Module -> Bool -> Maybe ModIface -> RnMG RecompileRequired
recompileRequired mod source_unchanged maybe_iface
= traceRn (text "Considering whether compilation is required for" <+> ppr mod <> colon) `thenRn_`
recompileRequired :: DynFlags -> Finder
-> HomeIfaceTable -> HomeSymbolTable
-> PersistentCompilerState
-> Module
-> Bool -- Source unchanged
-> Maybe ModIface -- Old interface, if any
-> IO (PersistentCompilerState, Bool, RecompileRequired)
-- True <=> errors happened
recompileRequired dflags finder hit hst pcs mod source_unchanged maybe_iface
= initRn dflags finder hit hst pcs mod $
traceRn (text "Considering whether compilation is required for" <+> ppr mod <> colon) `thenRn_`
-- CHECK WHETHER THE SOURCE HAS CHANGED
if not source_unchanged then
......@@ -516,8 +531,7 @@ recompileRequired mod source_unchanged maybe_iface
returnRn outOfDate ;
Just iface -> -- Source code unchanged and no errors yet... carry on
getHomeIfaceTableRn `thenRn` \ hit ->
checkList [checkModUsage hit u | u <- mi_usages iface]
checkList [checkModUsage u | u <- mi_usages iface]
checkList :: [RnMG RecompileRequired] -> RnMG RecompileRequired
checkList [] = returnRn upToDate
......@@ -529,12 +543,12 @@ checkList (check:checks) = check `thenRn` \ recompile ->
\end{code}
\begin{code}
checkModUsage :: HomeIfaceTable -> ImportVersion Name -> RnMG RecompileRequired
checkModUsage :: ImportVersion Name -> RnMG RecompileRequired
-- Given the usage information extracted from the old
-- M.hi file for the module being compiled, figure out
-- whether M needs to be recompiled.
checkModUsage hit (mod_name, _, _, NothingAtAll)
checkModUsage (mod_name, _, _, NothingAtAll)
-- If CurrentModule.hi contains
-- import Foo :: ;
-- then that simply records that Foo lies below CurrentModule in the
......@@ -542,7 +556,7 @@ checkModUsage hit (mod_name, _, _, NothingAtAll)
-- In this case we don't even want to open Foo's interface.
= up_to_date (ptext SLIT("Nothing used from:") <+> ppr mod_name)
checkModUsage hit (mod_name, _, _, whats_imported)
checkModUsage (mod_name, _, _, whats_imported)
= tryLoadInterface doc_str mod_name ImportBySystem `thenRn` \ (ifaces, maybe_err) ->
case maybe_err of {
Just err -> out_of_date (sep [ptext SLIT("Can't find version number for module"),
......@@ -552,6 +566,8 @@ checkModUsage hit (mod_name, _, _, whats_imported)
-- the current module doesn't need that import and it's been deleted
Nothing ->
getHomeIfaceTableRn `thenRn` \ hit ->
let
mod_details = lookupTableByModName hit (iPIT ifaces) mod_name
`orElse` panic "checkModUsage"
......
ghc/compiler/rename/RnMonad.lhs
View file @ a76db2a0
......@@ -44,7 +44,7 @@ import HscTypes ( Finder,
HomeSymbolTable, PackageSymbolTable,
PersistentCompilerState(..), GlobalRdrEnv,
HomeIfaceTable, PackageIfaceTable,
RdrAvailInfo, ModIface )
RdrAvailInfo )
import BasicTypes ( Version, defaultFixity )
import ErrUtils ( addShortErrLocLine, addShortWarnLocLine,
pprBagOfErrors, ErrMsg, WarnMsg, Message
......@@ -59,17 +59,18 @@ import Name ( Name, OccName, NamedThing(..), getSrcLoc,
NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv,
extendNameEnvList
)
import Module ( Module, ModuleName, lookupModuleEnvByName )
import Module ( Module, ModuleName )
import NameSet
import CmdLineOpts ( DynFlags, DynFlag(..), dopt )
import SrcLoc ( SrcLoc, generatedSrcLoc )
import SrcLoc ( SrcLoc, generatedSrcLoc, noSrcLoc )
import Unique ( Unique )
import FiniteMap ( FiniteMap, emptyFM )
import Bag ( Bag, emptyBag, isEmptyBag, snocBag )
import UniqSupply
import Outputable
import PrelNames ( mkUnboundName )
import Maybes ( maybeToBool, seqMaybe, orElse )
import Maybes ( maybeToBool, seqMaybe )
import ErrUtils ( printErrorsAndWarnings )
infixr 9 `thenRn`, `thenRn_`
\end{code}
......@@ -285,28 +286,38 @@ type IsLoaded = Bool
%************************************************************************
\begin{code}
initRn :: DynFlags
-> Finder
-> HomeIfaceTable
-> HomeSymbolTable
initRn :: DynFlags -> Finder
-> HomeIfaceTable -> HomeSymbolTable
-> PersistentCompilerState
-> Module
-> SrcLoc
-> Module
-> RnMG t
-> IO (t, (Bag WarnMsg, Bag ErrMsg), PersistentCompilerState)
-> IO (PersistentCompilerState, Bool, t)
-- True <=> found errors
initRn dflags finder hit hst pcs mod loc do_rn
initRn dflags finder hit hst pcs mod do_rn
= do
let prs = pcs_PRS pcs
let pst = pcs_PST pcs
let ifaces = Ifaces { iPIT = pcs_PIT pcs,
iDecls = prsDecls prs,
iInsts = prsInsts prs,
iRules = prsRules prs,
iImpModInfo = emptyFM,
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 = []
}
let uniqs = prsNS prs
names_var <- newIORef (uniqs, origNames (prsOrig prs),
origIParam (prsOrig prs))
errs_var <- newIORef (emptyBag,emptyBag)
iface_var <- newIORef (initIfaces pcs)
iface_var <- newIORef ifaces
let rn_down = RnDown { rn_mod = mod,
rn_loc = loc,
rn_loc = noSrcLoc,
rn_finder = finder,
rn_dflags = dflags,
......@@ -334,34 +345,15 @@ initRn dflags finder hit hst pcs mod loc do_rn
let new_pcs = pcs { pcs_PIT = iPIT new_ifaces,
pcs_PRS = new_prs }
return (res, (warns, errs), new_pcs)
-- Check for warnings
printErrorsAndWarnings (warns, errs) ;
return (new_pcs, not (isEmptyBag errs), res)
is_done :: HomeSymbolTable -> PackageSymbolTable -> Name -> Bool
-- Returns True iff the name is in either symbol table
is_done hst pst n = maybeToBool (lookupTypeEnv pst n `seqMaybe` lookupTypeEnv hst n)
lookupIface :: HomeIfaceTable -> PackageIfaceTable -> ModuleName -> ModIface
lookupIface hit pit mod = lookupModuleEnvByName hit mod `orElse`
lookupModuleEnvByName pit mod `orElse`
pprPanic "lookupIface" (ppr mod)
initIfaces :: PersistentCompilerState -> Ifaces
initIfaces (PCS { pcs_PIT = pit, pcs_PRS = prs })
= Ifaces { iPIT = pit,
iDecls = prsDecls prs,
iInsts = prsInsts prs,
iRules = prsRules prs,
iImpModInfo = emptyFM,
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 = []
}
initRnMS :: GlobalRdrEnv -> LocalFixityEnv -> 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,
......
ghc/compiler/typecheck/TcDeriv.lhs
View file @ a76db2a0
......@@ -16,7 +16,7 @@ import RnHsSyn ( RenamedHsBinds, RenamedMonoBinds )
import CmdLineOpts ( DynFlag(..), DynFlags )
import TcMonad
import TcEnv ( TcEnv, tcSetInstEnv, getTcGST, newDFunName )
import TcEnv ( TcEnv, tcSetInstEnv, newDFunName )
import TcGenDeriv -- Deriv stuff
import InstEnv ( InstInfo(..), InstEnv,
pprInstInfo, simpleDFunClassTyCon, extendInstEnv )
......@@ -26,33 +26,29 @@ import RnBinds ( rnMethodBinds, rnTopMonoBinds )
import RnEnv ( bindLocatedLocalsRn )
import RnMonad ( --RnNameSupply,
renameSourceCode, thenRn, mapRn, returnRn )
import HscTypes ( DFunId, GlobalSymbolTable, PersistentRenamerState )
import HscTypes ( DFunId, PersistentRenamerState )
import BasicTypes ( Fixity )
import Bag ( Bag, emptyBag, unionBags, listToBag )
import Class ( classKey, Class )
import ErrUtils ( dumpIfSet_dyn, Message )
import MkId ( mkDictFunId )
import Id ( mkVanillaId, idType )
import Id ( idType )
import DataCon ( dataConArgTys, isNullaryDataCon, isExistentialDataCon )
import PrelInfo ( needsDataDeclCtxtClassKeys )
import Maybes ( maybeToBool, catMaybes )
import Module ( Module )
import Name ( Name, isLocallyDefined, getSrcLoc, NamedThing(..) )
import Name ( Name, isLocallyDefined, getSrcLoc )
import RdrName ( RdrName )
import TyCon ( tyConTyVars, tyConDataCons, tyConDerivings,
tyConTheta, maybeTyConSingleCon, isDataTyCon,
isEnumerationTyCon, isAlgTyCon, TyCon
isEnumerationTyCon, TyCon
)
import Type ( TauType, PredType(..), mkTyVarTys, mkTyConApp,
mkSigmaTy, splitDFunTy, mkDictTy,
isUnboxedType, splitAlgTyConApp, classesToPreds
splitDFunTy, isUnboxedType
)
import TysWiredIn ( voidTy )
import Var ( TyVar )
import PrelNames
import Bag ( bagToList )
import Util ( zipWithEqual, sortLt, thenCmp )
import ListSetOps ( removeDups, assoc )
import Outputable
......
ghc/compiler/typecheck/TcInstDcls.lhs
View file @ a76db2a0
......@@ -11,11 +11,10 @@ module TcInstDcls ( tcInstDecls1, tcInstDecls2, tcAddDeclCtxt ) where
import CmdLineOpts ( DynFlag(..), dopt )
import HsSyn ( HsDecl(..), InstDecl(..), TyClDecl(..), InPat(..),
MonoBinds(..), HsExpr(..), HsLit(..), Sig(..), Match(..),
import HsSyn ( HsDecl(..), InstDecl(..), TyClDecl(..),
MonoBinds(..), HsExpr(..), HsLit(..), Sig(..),
andMonoBindList, collectMonoBinders, isClassDecl
)
import HsTypes ( HsType (..), HsTyVarBndr(..), toHsTyVar )
import RnHsSyn ( RenamedHsBinds, RenamedInstDecl, RenamedHsDecl, RenamedMonoBinds,
RenamedTyClDecl, RenamedHsType,
extractHsTyVars, maybeGenericMatch
......@@ -29,25 +28,23 @@ import Inst ( InstOrigin(..),
LIE, emptyLIE, plusLIE, plusLIEs )
import TcDeriv ( tcDeriving )
import TcEnv ( TcEnv, tcExtendGlobalValEnv,
tcExtendTyVarEnvForMeths, TyThing (..),
tcExtendTyVarEnvForMeths,
tcAddImportedIdInfo, tcInstId, tcLookupClass,
newDFunName, tcExtendTyVarEnv
)
import InstEnv ( InstInfo(..), InstEnv, pprInstInfo, classDataCon,
simpleInstInfoTyCon, simpleInstInfoTy, isLocalInst,
extendInstEnv )
import TcMonoType ( tcTyVars, tcHsSigType, tcHsType, kcHsSigType )
import TcMonoType ( tcTyVars, tcHsSigType, kcHsSigType )
import TcSimplify ( tcSimplifyAndCheck )
import TcType ( zonkTcSigTyVars )
import HscTypes ( PersistentCompilerState(..), HomeSymbolTable, DFunId,
ModDetails(..) )
import Bag ( emptyBag, unitBag, unionBags, unionManyBags,
foldBag, Bag, listToBag
)
import Bag ( unionManyBags )
import Class ( Class, DefMeth(..), classBigSig )
import Var ( idName, idType )
import Maybes ( maybeToBool, expectJust )
import Maybes ( maybeToBool )
import MkId ( mkDictFunId )
import Generics ( validGenericInstanceType )
import Module ( Module, foldModuleEnv )
......@@ -58,7 +55,7 @@ import PprType ( pprConstraint, pprPred )
import TyCon ( TyCon, isSynTyCon, tyConDerivings )
import Type ( mkTyVarTys, splitDFunTy, isTyVarTy,
splitTyConApp_maybe, splitDictTy,
splitAlgTyConApp_maybe, classesToPreds, classesOfPreds,
splitAlgTyConApp_maybe,
unUsgTy, tyVarsOfTypes, mkClassPred, mkTyVarTy,
getClassTys_maybe
)
......@@ -66,12 +63,9 @@ import Subst ( mkTopTyVarSubst, substClasses, substTheta )
import VarSet ( mkVarSet, varSetElems )
import TysWiredIn ( genericTyCons, isFFIArgumentTy, isFFIResultTy )
import PrelNames ( cCallableClassKey, cReturnableClassKey, hasKey )
import Name ( Name, NameEnv, extendNameEnv_C, emptyNameEnv,
plusNameEnv_C, nameEnvElts )
import FiniteMap ( mapFM )
import Name ( Name )
import SrcLoc ( SrcLoc )
import VarSet ( varSetElems )
import UniqFM ( mapUFM )
import Unique ( Uniquable(..) )
import BasicTypes ( NewOrData(..), Fixity )
import ErrUtils ( dumpIfSet_dyn )
......@@ -79,7 +73,7 @@ import ListSetOps ( Assoc, emptyAssoc, plusAssoc_C, mapAssoc,
assocElts, extendAssoc_C,
equivClassesByUniq, minusList
)
import List ( intersect, (\\), partition )
import List ( partition )
import Outputable
\end{code}
......
ghc/compiler/typecheck/TcModule.lhs
View file @ a76db2a0
......@@ -21,7 +21,7 @@ import TcHsSyn ( TypecheckedMonoBinds,
)
import TcMonad
import Inst ( emptyLIE, plusLIE )
import Inst ( plusLIE )
import TcBinds ( tcTopBinds )
import TcClassDcl ( tcClassDecls2, mkImplicitClassBinds )
import TcDefaults ( tcDefaults )
......@@ -47,16 +47,13 @@ import Module ( Module, moduleName, plusModuleEnv )
import Name ( Name, nameOccName, isLocallyDefined, isGlobalName,
toRdrName, nameEnvElts, emptyNameEnv, lookupNameEnv
)
import TyCon ( TyCon, isDataTyCon, tyConName, tyConGenInfo )
import TyCon ( tyConGenInfo, isClassTyCon )
import OccName ( isSysOcc )
import TyCon ( TyCon, isClassTyCon )
import Class ( Class )
import PrelNames ( mAIN_Name, mainName )
import UniqSupply ( UniqSupply )
import Maybes ( maybeToBool, thenMaybe )
import Maybes ( thenMaybe )
import Util
import BasicTypes ( EP(..), Fixity )
import Bag ( Bag, isEmptyBag )
import Bag ( isEmptyBag )
import Outputable
import HscTypes ( PersistentCompilerState(..), HomeSymbolTable, HomeIfaceTable,
PackageSymbolTable, PackageIfaceTable, DFunId, ModIface(..),
......@@ -135,7 +132,6 @@ tcModule pcs hst get_fixity this_mod decls unf_env
let
classes = tcEnvClasses env
tycons = tcEnvTyCons env -- INCLUDES tycons derived from classes
local_classes = filter isLocallyDefined classes
local_tycons = [ tc | tc <- tycons,
isLocallyDefined tc,
not (isClassTyCon tc)
......@@ -295,8 +291,8 @@ printTcDump dflags (Just (_,results))
dump_tc results
= vcat [ppr (tc_binds results),
pp_rules (tc_rules results) --,
-- ppr_gen_tycons (tc_tycons results)
pp_rules (tc_rules results),
ppr_gen_tycons [tc | ATyCon tc <- nameEnvElts (tc_env results)]
]
dump_sigs results -- Print type signatures
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment