From: simonmar Date: Tue, 21 Jun 2005 10:44:42 +0000 (+0000) Subject: [project @ 2005-06-21 10:44:37 by simonmar] X-Git-Tag: Initial_conversion_from_CVS_complete~418 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=0c53bd0e1b02dea0bde32cd7eb8ccb5ee2d3719e;p=ghc-hetmet.git [project @ 2005-06-21 10:44:37 by simonmar] Relax the restrictions on conflicting packages. This should address many of the traps that people have been falling into with the current package story. Now, a local module can shadow a module in an exposed package, as long as the package is not otherwise required by the program. GHC checks for conflicts when it knows the dependencies of the module being compiled. Also, we now check for module conflicts in exposed packages only when importing a module: if an import can be satisfied from multiple packages, that's an error. It's not possible to prevent GHC from starting by installing packages now (unless you install another base package). It seems to be possible to confuse GHCi by having a local module shadowing a package module that goes away and comes back again. I think it's nearly right, but strange happenings have been observed. I'll try to merge this into the STABLE branch. --- diff --git a/ghc/compiler/cmm/CLabel.hs b/ghc/compiler/cmm/CLabel.hs index de6ca7a..296ad91 100644 --- a/ghc/compiler/cmm/CLabel.hs +++ b/ghc/compiler/cmm/CLabel.hs @@ -99,7 +99,7 @@ module CLabel ( #include "HsVersions.h" -import DynFlags ( DynFlags ) +import Packages ( HomeModules ) import StaticFlags ( opt_Static, opt_DoTickyProfiling ) import Packages ( isHomeModule, isDllName ) import DataCon ( ConTag ) @@ -287,20 +287,20 @@ mkLocalInfoTableLabel name = IdLabel name InfoTable mkLocalEntryLabel name = IdLabel name Entry mkLocalClosureTableLabel name = IdLabel name ClosureTable -mkClosureLabel dflags name - | isDllName dflags name = DynIdLabel name Closure +mkClosureLabel hmods name + | isDllName hmods name = DynIdLabel name Closure | otherwise = IdLabel name Closure -mkInfoTableLabel dflags name - | isDllName dflags name = DynIdLabel name InfoTable +mkInfoTableLabel hmods name + | isDllName hmods name = DynIdLabel name InfoTable | otherwise = IdLabel name InfoTable -mkEntryLabel dflags name - | isDllName dflags name = DynIdLabel name Entry +mkEntryLabel hmods name + | isDllName hmods name = DynIdLabel name Entry | otherwise = IdLabel name Entry -mkClosureTableLabel dflags name - | isDllName dflags name = DynIdLabel name ClosureTable +mkClosureTableLabel hmods name + | isDllName hmods name = DynIdLabel name ClosureTable | otherwise = IdLabel name ClosureTable mkLocalConInfoTableLabel con = IdLabel con ConInfoTable @@ -314,12 +314,12 @@ mkConInfoTableLabel name True = DynIdLabel name ConInfoTable mkStaticInfoTableLabel name False = IdLabel name StaticInfoTable mkStaticInfoTableLabel name True = DynIdLabel name StaticInfoTable -mkConEntryLabel dflags name - | isDllName dflags name = DynIdLabel name ConEntry +mkConEntryLabel hmods name + | isDllName hmods name = DynIdLabel name ConEntry | otherwise = IdLabel name ConEntry -mkStaticConEntryLabel dflags name - | isDllName dflags name = DynIdLabel name StaticConEntry +mkStaticConEntryLabel hmods name + | isDllName hmods name = DynIdLabel name StaticConEntry | otherwise = IdLabel name StaticConEntry @@ -331,13 +331,13 @@ mkDefaultLabel uniq = CaseLabel uniq CaseDefault mkStringLitLabel = StringLitLabel mkAsmTempLabel = AsmTempLabel -mkModuleInitLabel :: DynFlags -> Module -> String -> CLabel -mkModuleInitLabel dflags mod way - = ModuleInitLabel mod way $! (not (isHomeModule dflags mod)) +mkModuleInitLabel :: HomeModules -> Module -> String -> CLabel +mkModuleInitLabel hmods mod way + = ModuleInitLabel mod way $! (not (isHomeModule hmods mod)) -mkPlainModuleInitLabel :: DynFlags -> Module -> CLabel -mkPlainModuleInitLabel dflags mod - = PlainModuleInitLabel mod $! (not (isHomeModule dflags mod)) +mkPlainModuleInitLabel :: HomeModules -> Module -> CLabel +mkPlainModuleInitLabel hmods mod + = PlainModuleInitLabel mod $! (not (isHomeModule hmods mod)) -- Some fixed runtime system labels diff --git a/ghc/compiler/cmm/CmmParse.y b/ghc/compiler/cmm/CmmParse.y index 3ae93ff..e81d34c 100644 --- a/ghc/compiler/cmm/CmmParse.y +++ b/ghc/compiler/cmm/CmmParse.y @@ -38,6 +38,7 @@ import Unique import UniqFM import SrcLoc import DynFlags ( DynFlags, DynFlag(..) ) +import Packages ( HomeModules ) import StaticFlags ( opt_SccProfilingOn ) import ErrUtils ( printError, dumpIfSet_dyn, showPass ) import StringBuffer ( hGetStringBuffer ) @@ -861,8 +862,8 @@ initEnv = listToUFM [ CmmLit (CmmInt (fromIntegral stdInfoTableSizeB) wordRep) ) ] -parseCmmFile :: DynFlags -> FilePath -> IO (Maybe Cmm) -parseCmmFile dflags filename = do +parseCmmFile :: DynFlags -> HomeModules -> FilePath -> IO (Maybe Cmm) +parseCmmFile dflags hmods filename = do showPass dflags "ParseCmm" buf <- hGetStringBuffer filename let @@ -873,10 +874,9 @@ parseCmmFile dflags filename = do case unP cmmParse init_state of PFailed span err -> do printError span err; return Nothing POk _ code -> do - cmm <- initC dflags no_module (getCmm (unEC code initEnv [] >> return ())) + cmm <- initC dflags hmods no_module (getCmm (unEC code initEnv [] >> return ())) dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (pprCmms [cmm]) return (Just cmm) where no_module = panic "parseCmmFile: no module" - } diff --git a/ghc/compiler/codeGen/CgBindery.lhs b/ghc/compiler/codeGen/CgBindery.lhs index e4ca141..f78edda 100644 --- a/ghc/compiler/codeGen/CgBindery.lhs +++ b/ghc/compiler/codeGen/CgBindery.lhs @@ -240,8 +240,8 @@ getCgIdInfo id name = idName id in if isExternalName name then do - dflags <- getDynFlags - let ext_lbl = CmmLit (CmmLabel (mkClosureLabel dflags name)) + hmods <- getHomeModules + let ext_lbl = CmmLit (CmmLabel (mkClosureLabel hmods name)) return (stableIdInfo id ext_lbl (mkLFImported id)) else if isVoidArg (idCgRep id) then diff --git a/ghc/compiler/codeGen/CgCase.lhs b/ghc/compiler/codeGen/CgCase.lhs index 58a43f4..e7c0894 100644 --- a/ghc/compiler/codeGen/CgCase.lhs +++ b/ghc/compiler/codeGen/CgCase.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CgCase.lhs,v 1.74 2005/03/31 10:16:34 simonmar Exp $ +% $Id: CgCase.lhs,v 1.75 2005/06/21 10:44:41 simonmar Exp $ % %******************************************************** %* * @@ -336,10 +336,10 @@ cgInlinePrimOp primop args bndr (AlgAlt tycon) live_in_alts alts -- Bind the default binder if necessary -- (avoiding it avoids the assignment) -- The deadness info is set by StgVarInfo - ; dflags <- getDynFlags + ; hmods <- getHomeModules ; whenC (not (isDeadBinder bndr)) (do { tmp_reg <- bindNewToTemp bndr - ; stmtC (CmmAssign tmp_reg (tagToClosure dflags tycon tag_amode)) }) + ; stmtC (CmmAssign tmp_reg (tagToClosure hmods tycon tag_amode)) }) -- Compile the alts ; (branches, mb_deflt) <- cgAlgAlts NoGC Nothing{-cc_slot-} diff --git a/ghc/compiler/codeGen/CgCon.lhs b/ghc/compiler/codeGen/CgCon.lhs index d94cbf0..bfb55bf 100644 --- a/ghc/compiler/codeGen/CgCon.lhs +++ b/ghc/compiler/codeGen/CgCon.lhs @@ -71,10 +71,10 @@ cgTopRhsCon :: Id -- Name of thing bound to this RHS -> FCode (Id, CgIdInfo) cgTopRhsCon id con args = do { - ; dflags <- getDynFlags + ; hmods <- getHomeModules #if mingw32_TARGET_OS -- Windows DLLs have a problem with static cross-DLL refs. - ; ASSERT( not (isDllConApp dflags con args) ) return () + ; ASSERT( not (isDllConApp hmods con args) ) return () #endif ; ASSERT( args `lengthIs` dataConRepArity con ) return () @@ -84,9 +84,9 @@ cgTopRhsCon id con args ; let name = idName id lf_info = mkConLFInfo con - closure_label = mkClosureLabel dflags name + closure_label = mkClosureLabel hmods name caffy = any stgArgHasCafRefs args - (closure_info, amodes_w_offsets) = layOutStaticConstr dflags con amodes + (closure_info, amodes_w_offsets) = layOutStaticConstr hmods con amodes closure_rep = mkStaticClosureFields closure_info dontCareCCS -- Because it's static data @@ -143,9 +143,9 @@ at all. \begin{code} buildDynCon binder cc con [] - = do dflags <- getDynFlags + = do hmods <- getHomeModules returnFC (stableIdInfo binder - (mkLblExpr (mkClosureLabel dflags (dataConName con))) + (mkLblExpr (mkClosureLabel hmods (dataConName con))) (mkConLFInfo con)) \end{code} @@ -199,9 +199,9 @@ Now the general case. \begin{code} buildDynCon binder ccs con args = do { - ; dflags <- getDynFlags + ; hmods <- getHomeModules ; let - (closure_info, amodes_w_offsets) = layOutDynConstr dflags con args + (closure_info, amodes_w_offsets) = layOutDynConstr hmods con args ; hp_off <- allocDynClosure closure_info use_cc blame_cc amodes_w_offsets ; returnFC (heapIdInfo binder hp_off lf_info) } @@ -231,10 +231,10 @@ found a $con$. \begin{code} bindConArgs :: DataCon -> [Id] -> Code bindConArgs con args - = do dflags <- getDynFlags + = do hmods <- getHomeModules let bind_arg (arg, offset) = bindNewToNode arg offset (mkLFArgument arg) - (_, args_w_offsets) = layOutDynConstr dflags con (addIdReps args) + (_, args_w_offsets) = layOutDynConstr hmods con (addIdReps args) -- ASSERT(not (isUnboxedTupleCon con)) return () mapCs bind_arg args_w_offsets @@ -417,7 +417,7 @@ static closure, for a constructor. cgDataCon :: DataCon -> Code cgDataCon data_con = do { -- Don't need any dynamic closure code for zero-arity constructors - dflags <- getDynFlags + hmods <- getHomeModules ; let -- To allow the debuggers, interpreters, etc to cope with @@ -425,10 +425,10 @@ cgDataCon data_con -- time), we take care that info-table contains the -- information we need. (static_cl_info, _) = - layOutStaticConstr dflags data_con arg_reps + layOutStaticConstr hmods data_con arg_reps (dyn_cl_info, arg_things) = - layOutDynConstr dflags data_con arg_reps + layOutDynConstr hmods data_con arg_reps emit_info cl_info ticky_code = do { code_blks <- getCgStmts the_code diff --git a/ghc/compiler/codeGen/CgExpr.lhs b/ghc/compiler/codeGen/CgExpr.lhs index 459f2c0..33d72f1 100644 --- a/ghc/compiler/codeGen/CgExpr.lhs +++ b/ghc/compiler/codeGen/CgExpr.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CgExpr.lhs,v 1.61 2004/11/26 16:20:07 simonmar Exp $ +% $Id: CgExpr.lhs,v 1.62 2005/06/21 10:44:41 simonmar Exp $ % %******************************************************** %* * @@ -152,8 +152,8 @@ cgExpr (StgOpApp (StgPrimOp TagToEnumOp) [arg] res_ty) do { (_,amode) <- getArgAmode arg ; amode' <- assignTemp amode -- We're going to use it twice, -- so save in a temp if non-trivial - ; dflags <- getDynFlags - ; stmtC (CmmAssign nodeReg (tagToClosure dflags tycon amode')) + ; hmods <- getHomeModules + ; stmtC (CmmAssign nodeReg (tagToClosure hmods tycon amode')) ; performReturn (emitAlgReturnCode tycon amode') } where -- If you're reading this code in the attempt to figure @@ -185,9 +185,9 @@ cgExpr x@(StgOpApp op@(StgPrimOp primop) args res_ty) | ReturnsAlg tycon <- result_info, isEnumerationTyCon tycon -- c.f. cgExpr (...TagToEnumOp...) = do tag_reg <- newTemp wordRep - dflags <- getDynFlags + hmods <- getHomeModules cgPrimOp [tag_reg] primop args emptyVarSet - stmtC (CmmAssign nodeReg (tagToClosure dflags tycon (CmmReg tag_reg))) + stmtC (CmmAssign nodeReg (tagToClosure hmods tycon (CmmReg tag_reg))) performReturn (emitAlgReturnCode tycon (CmmReg tag_reg)) where result_info = getPrimOpResultInfo primop @@ -282,8 +282,8 @@ cgRhs name (StgRhsCon maybe_cc con args) ; returnFC (name, idinfo) } cgRhs name (StgRhsClosure cc bi fvs upd_flag srt args body) - = do dflags <- getDynFlags - mkRhsClosure dflags name cc bi srt fvs upd_flag args body + = do hmods <- getHomeModules + mkRhsClosure hmods name cc bi srt fvs upd_flag args body \end{code} mkRhsClosure looks for two special forms of the right-hand side: @@ -306,7 +306,7 @@ form: \begin{code} -mkRhsClosure dflags bndr cc bi srt +mkRhsClosure hmods bndr cc bi srt [the_fv] -- Just one free var upd_flag -- Updatable thunk [] -- A thunk @@ -328,7 +328,7 @@ mkRhsClosure dflags bndr cc bi srt where lf_info = mkSelectorLFInfo bndr offset_into_int (isUpdatable upd_flag) - (_, params_w_offsets) = layOutDynConstr dflags con (addIdReps params) + (_, params_w_offsets) = layOutDynConstr hmods con (addIdReps params) -- Just want the layout maybe_offset = assocMaybe params_w_offsets selectee Just the_offset = maybe_offset @@ -352,7 +352,7 @@ We only generate an Ap thunk if all the free variables are pointers, for semi-obvious reasons. \begin{code} -mkRhsClosure dflags bndr cc bi srt +mkRhsClosure hmods bndr cc bi srt fvs upd_flag [] -- No args; a thunk @@ -377,7 +377,7 @@ mkRhsClosure dflags bndr cc bi srt The default case ~~~~~~~~~~~~~~~~ \begin{code} -mkRhsClosure dflags bndr cc bi srt fvs upd_flag args body +mkRhsClosure hmods bndr cc bi srt fvs upd_flag args body = cgRhsClosure bndr cc bi srt fvs upd_flag args body \end{code} diff --git a/ghc/compiler/codeGen/CgHeapery.lhs b/ghc/compiler/codeGen/CgHeapery.lhs index 66bc6f5..78a6f78 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.46 2005/04/21 15:28:20 simonmar Exp $ +% $Id: CgHeapery.lhs,v 1.47 2005/06/21 10:44:41 simonmar Exp $ % \section[CgHeapery]{Heap management functions} @@ -54,11 +54,9 @@ import TyCon ( tyConPrimRep ) import CostCentre ( CostCentreStack ) import Util ( mapAccumL, filterOut ) import Constants ( wORD_SIZE ) -import DynFlags ( DynFlags ) +import Packages ( HomeModules ) import Outputable -import GLAEXTS - \end{code} @@ -126,7 +124,7 @@ getHpRelOffset virtual_offset \begin{code} layOutDynConstr, layOutStaticConstr - :: DynFlags + :: HomeModules -> DataCon -> [(CgRep,a)] -> (ClosureInfo, @@ -135,8 +133,8 @@ layOutDynConstr, layOutStaticConstr layOutDynConstr = layOutConstr False layOutStaticConstr = layOutConstr True -layOutConstr is_static dflags data_con args - = (mkConInfo dflags is_static data_con tot_wds ptr_wds, +layOutConstr is_static hmods data_con args + = (mkConInfo hmods is_static data_con tot_wds ptr_wds, things_w_offsets) where (tot_wds, -- #ptr_wds + #nonptr_wds diff --git a/ghc/compiler/codeGen/CgMonad.lhs b/ghc/compiler/codeGen/CgMonad.lhs index 4160580..4f95c9b 100644 --- a/ghc/compiler/codeGen/CgMonad.lhs +++ b/ghc/compiler/codeGen/CgMonad.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CgMonad.lhs,v 1.44 2005/03/18 13:37:44 simonmar Exp $ +% $Id: CgMonad.lhs,v 1.45 2005/06/21 10:44:41 simonmar Exp $ % \section[CgMonad]{The code generation monad} @@ -47,7 +47,7 @@ module CgMonad ( Sequel(..), -- ToDo: unabstract? -- ideally we wouldn't export these, but some other modules access internal state - getState, setState, getInfoDown, getDynFlags, + getState, setState, getInfoDown, getDynFlags, getHomeModules, -- more localised access to monad state getStkUsage, setStkUsage, @@ -61,7 +61,8 @@ module CgMonad ( import {-# SOURCE #-} CgBindery ( CgBindings, nukeVolatileBinds ) -import DynFlags ( DynFlags ) +import DynFlags ( DynFlags ) +import Packages ( HomeModules ) import Cmm import CmmUtils ( CmmStmts, isNopStmt ) import CLabel @@ -96,6 +97,7 @@ along. data CgInfoDownwards -- information only passed *downwards* by the monad = MkCgInfoDown { cgd_dflags :: DynFlags, + cgd_hmods :: HomeModules, -- Packages we depend on cgd_mod :: Module, -- Module being compiled cgd_statics :: CgBindings, -- [Id -> info] : static environment cgd_srt :: CLabel, -- label of the current SRT @@ -103,9 +105,10 @@ data CgInfoDownwards -- information only passed *downwards* by the monad cgd_eob :: EndOfBlockInfo -- Info for stuff to do at end of basic block: } -initCgInfoDown :: DynFlags -> Module -> CgInfoDownwards -initCgInfoDown dflags mod +initCgInfoDown :: DynFlags -> HomeModules -> Module -> CgInfoDownwards +initCgInfoDown dflags hmods mod = MkCgInfoDown { cgd_dflags = dflags, + cgd_hmods = hmods, cgd_mod = mod, cgd_statics = emptyVarEnv, cgd_srt = error "initC: srt", @@ -375,11 +378,11 @@ instance Monad FCode where The Abstract~C is not in the environment so as to improve strictness. \begin{code} -initC :: DynFlags -> Module -> FCode a -> IO a +initC :: DynFlags -> HomeModules -> Module -> FCode a -> IO a -initC dflags mod (FCode code) +initC dflags hmods mod (FCode code) = do { uniqs <- mkSplitUniqSupply 'c' - ; case code (initCgInfoDown dflags mod) (initCgState uniqs) of + ; case code (initCgInfoDown dflags hmods mod) (initCgState uniqs) of (res, _) -> return res } @@ -507,6 +510,9 @@ getInfoDown = FCode $ \info_down state -> (info_down,state) getDynFlags :: FCode DynFlags getDynFlags = liftM cgd_dflags getInfoDown +getHomeModules :: FCode HomeModules +getHomeModules = liftM cgd_hmods getInfoDown + withInfoDown :: FCode a -> CgInfoDownwards -> FCode a withInfoDown (FCode fcode) info_down = FCode $ \_ state -> fcode info_down state diff --git a/ghc/compiler/codeGen/CgTailCall.lhs b/ghc/compiler/codeGen/CgTailCall.lhs index 9932613..f76fcbd 100644 --- a/ghc/compiler/codeGen/CgTailCall.lhs +++ b/ghc/compiler/codeGen/CgTailCall.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CgTailCall.lhs,v 1.42 2005/03/31 10:16:34 simonmar Exp $ +% $Id: CgTailCall.lhs,v 1.43 2005/06/21 10:44:41 simonmar Exp $ % %******************************************************** %* * @@ -118,9 +118,9 @@ performTailCall fun_info arg_amodes pending_assts opt_node_asst | nodeMustPointToIt lf_info = node_asst | otherwise = noStmts ; EndOfBlockInfo sp _ <- getEndOfBlockInfo - ; dflags <- getDynFlags + ; hmods <- getHomeModules - ; case (getCallMethod dflags fun_name lf_info (length arg_amodes)) of + ; case (getCallMethod hmods fun_name lf_info (length arg_amodes)) of -- Node must always point to things we enter EnterIt -> do diff --git a/ghc/compiler/codeGen/CgUtils.hs b/ghc/compiler/codeGen/CgUtils.hs index 67e5973..b70bd26 100644 --- a/ghc/compiler/codeGen/CgUtils.hs +++ b/ghc/compiler/codeGen/CgUtils.hs @@ -52,7 +52,8 @@ import CLabel ( CLabel, mkStringLitLabel ) import Digraph ( SCC(..), stronglyConnComp ) import ListSetOps ( assocDefault ) import Util ( filterOut, sortLe ) -import DynFlags ( DynFlags(..), HscTarget(..) ) +import DynFlags ( DynFlags(..), HscTarget(..) ) +import Packages ( HomeModules ) import FastString ( LitString, FastString, unpackFS ) import Outputable @@ -210,11 +211,11 @@ addToMemE rep ptr n -- ------------------------------------------------------------------------- -tagToClosure :: DynFlags -> TyCon -> CmmExpr -> CmmExpr -tagToClosure dflags tycon tag +tagToClosure :: HomeModules -> TyCon -> CmmExpr -> CmmExpr +tagToClosure hmods tycon tag = CmmLoad (cmmOffsetExprW closure_tbl tag) wordRep where closure_tbl = CmmLit (CmmLabel lbl) - lbl = mkClosureTableLabel dflags (tyConName tycon) + lbl = mkClosureTableLabel hmods (tyConName tycon) ------------------------------------------------------------------------- -- diff --git a/ghc/compiler/codeGen/ClosureInfo.lhs b/ghc/compiler/codeGen/ClosureInfo.lhs index 423f429..48c4dde 100644 --- a/ghc/compiler/codeGen/ClosureInfo.lhs +++ b/ghc/compiler/codeGen/ClosureInfo.lhs @@ -62,8 +62,7 @@ import SMRep -- all of it import CLabel import Constants ( mIN_UPD_SIZE, mIN_SIZE_NonUpdHeapObject ) -import Packages ( isDllName ) -import DynFlags ( DynFlags ) +import Packages ( isDllName, HomeModules ) import StaticFlags ( opt_SccProfilingOn, opt_OmitBlackHoling, opt_Parallel, opt_DoTickyProfiling, opt_SMP ) @@ -332,15 +331,15 @@ mkClosureInfo is_static id lf_info tot_wds ptr_wds srt_info descr name = idName id sm_rep = chooseSMRep is_static lf_info tot_wds ptr_wds -mkConInfo :: DynFlags +mkConInfo :: HomeModules -> Bool -- Is static -> DataCon -> Int -> Int -- Total and pointer words -> ClosureInfo -mkConInfo dflags is_static data_con tot_wds ptr_wds +mkConInfo hmods is_static data_con tot_wds ptr_wds = ConInfo { closureSMRep = sm_rep, closureCon = data_con, - closureDllCon = isDllName dflags (dataConName data_con) } + closureDllCon = isDllName hmods (dataConName data_con) } where sm_rep = chooseSMRep is_static (mkConLFInfo data_con) tot_wds ptr_wds \end{code} @@ -572,30 +571,30 @@ data CallMethod CLabel -- The code label Int -- Its arity -getCallMethod :: DynFlags +getCallMethod :: HomeModules -> Name -- Function being applied -> LambdaFormInfo -- Its info -> Int -- Number of available arguments -> CallMethod -getCallMethod dflags name lf_info n_args +getCallMethod hmods name lf_info n_args | nodeMustPointToIt lf_info && opt_Parallel = -- If we're parallel, then we must always enter via node. -- The reason is that the closure may have been -- fetched since we allocated it. EnterIt -getCallMethod dflags name (LFReEntrant _ arity _ _) n_args +getCallMethod hmods name (LFReEntrant _ arity _ _) n_args | n_args == 0 = ASSERT( arity /= 0 ) ReturnIt -- No args at all | n_args < arity = SlowCall -- Not enough args - | otherwise = DirectEntry (enterIdLabel dflags name) arity + | otherwise = DirectEntry (enterIdLabel hmods name) arity -getCallMethod dflags name (LFCon con) n_args +getCallMethod hmods name (LFCon con) n_args = ASSERT( n_args == 0 ) ReturnCon con -getCallMethod dflags name (LFThunk _ _ updatable std_form_info is_fun) n_args +getCallMethod hmods name (LFThunk _ _ updatable std_form_info is_fun) n_args | is_fun -- Must always "call" a function-typed = SlowCall -- thing, cannot just enter it [in eval/apply, the entry code -- is the fast-entry code] @@ -608,24 +607,24 @@ getCallMethod dflags name (LFThunk _ _ updatable std_form_info is_fun) n_args | otherwise -- Jump direct to code for single-entry thunks = ASSERT( n_args == 0 ) - JumpToIt (thunkEntryLabel dflags name std_form_info updatable) + JumpToIt (thunkEntryLabel hmods name std_form_info updatable) -getCallMethod dflags name (LFUnknown True) n_args +getCallMethod hmods name (LFUnknown True) n_args = SlowCall -- might be a function -getCallMethod dflags name (LFUnknown False) n_args +getCallMethod hmods name (LFUnknown False) n_args = ASSERT2 ( n_args == 0, ppr name <+> ppr n_args ) EnterIt -- Not a function -getCallMethod dflags name (LFBlackHole _) n_args +getCallMethod hmods name (LFBlackHole _) n_args = SlowCall -- Presumably the black hole has by now -- been updated, but we don't know with -- what, so we slow call it -getCallMethod dflags name (LFLetNoEscape 0) n_args +getCallMethod hmods name (LFLetNoEscape 0) n_args = JumpToIt (enterReturnPtLabel (nameUnique name)) -getCallMethod dflags name (LFLetNoEscape arity) n_args +getCallMethod hmods name (LFLetNoEscape arity) n_args | n_args == arity = DirectEntry (enterReturnPtLabel (nameUnique name)) arity | otherwise = pprPanic "let-no-escape: " (ppr name <+> ppr arity) @@ -855,12 +854,12 @@ closureLabelFromCI _ = panic "closureLabelFromCI" -- thunkEntryLabel is a local help function, not exported. It's used from both -- entryLabelFromCI and getCallMethod. -thunkEntryLabel dflags thunk_id (ApThunk arity) is_updatable +thunkEntryLabel hmods thunk_id (ApThunk arity) is_updatable = enterApLabel is_updatable arity -thunkEntryLabel dflags thunk_id (SelectorThunk offset) upd_flag +thunkEntryLabel hmods thunk_id (SelectorThunk offset) upd_flag = enterSelectorLabel upd_flag offset -thunkEntryLabel dflags thunk_id _ is_updatable - = enterIdLabel dflags thunk_id +thunkEntryLabel hmods thunk_id _ is_updatable + = enterIdLabel hmods thunk_id enterApLabel is_updatable arity | tablesNextToCode = mkApInfoTableLabel is_updatable arity @@ -870,9 +869,9 @@ enterSelectorLabel upd_flag offset | tablesNextToCode = mkSelectorInfoLabel upd_flag offset | otherwise = mkSelectorEntryLabel upd_flag offset -enterIdLabel dflags id - | tablesNextToCode = mkInfoTableLabel dflags id - | otherwise = mkEntryLabel dflags id +enterIdLabel hmods id + | tablesNextToCode = mkInfoTableLabel hmods id + | otherwise = mkEntryLabel hmods id enterLocalIdLabel id | tablesNextToCode = mkLocalInfoTableLabel id diff --git a/ghc/compiler/codeGen/CodeGen.lhs b/ghc/compiler/codeGen/CodeGen.lhs index 1aa4865..1ea944c 100644 --- a/ghc/compiler/codeGen/CodeGen.lhs +++ b/ghc/compiler/codeGen/CodeGen.lhs @@ -29,7 +29,7 @@ import CgBindery ( CgIdInfo, addBindC, addBindsC, getCgIdInfo, cgIdInfoId ) import CgClosure ( cgTopRhsClosure ) import CgCon ( cgTopRhsCon, cgTyCon ) -import CgUtils ( cmmRegOffW, emitRODataLits, cmmNeWord, emitRtsCall ) +import CgUtils ( cmmRegOffW, emitRODataLits, cmmNeWord ) import CLabel import Cmm @@ -39,6 +39,7 @@ import MachOp ( wordRep, MachHint(..) ) import StgSyn import PrelNames ( gHC_PRIM, rOOT_MAIN, mAIN, pREL_TOP_HANDLER ) +import Packages ( HomeModules ) import DynFlags ( DynFlags(..), DynFlag(..), dopt ) import StaticFlags ( opt_SccProfilingOn ) @@ -59,6 +60,7 @@ import Outputable \begin{code} codeGen :: DynFlags + -> HomeModules -> Module -> [TyCon] -> ForeignStubs @@ -67,7 +69,7 @@ codeGen :: DynFlags -> [(StgBinding,[(Id,[Id])])] -- Bindings to convert, with SRTs -> IO [Cmm] -- Output -codeGen dflags this_mod data_tycons foreign_stubs imported_mods +codeGen dflags hmods this_mod data_tycons foreign_stubs imported_mods cost_centre_info stg_binds = do { showPass dflags "CodeGen" @@ -77,10 +79,10 @@ codeGen dflags this_mod data_tycons foreign_stubs imported_mods -- Why? -- ; mapM_ (\x -> seq x (return ())) data_tycons - ; code_stuff <- initC dflags this_mod $ do - { cmm_binds <- mapM (getCmm . cgTopBinding dflags) stg_binds + ; code_stuff <- initC dflags hmods this_mod $ do + { cmm_binds <- mapM (getCmm . cgTopBinding dflags hmods) stg_binds ; cmm_tycons <- mapM cgTyCon data_tycons - ; cmm_init <- getCmm (mkModuleInit dflags way cost_centre_info + ; cmm_init <- getCmm (mkModuleInit dflags hmods way cost_centre_info this_mod mb_main_mod foreign_stubs imported_mods) ; return (cmm_binds ++ concat cmm_tycons ++ [cmm_init]) @@ -141,6 +143,7 @@ We initialise the module tree by keeping a work-stack, \begin{code} mkModuleInit :: DynFlags + -> HomeModules -> String -- the "way" -> CollectedCCs -- cost centre info -> Module @@ -148,7 +151,7 @@ mkModuleInit -> ForeignStubs -> [Module] -> Code -mkModuleInit dflags way cost_centre_info this_mod mb_main_mod foreign_stubs imported_mods +mkModuleInit dflags hmods way cost_centre_info this_mod mb_main_mod foreign_stubs imported_mods = do { if opt_SccProfilingOn then do { -- Allocate the static boolean that records if this @@ -181,9 +184,9 @@ mkModuleInit dflags way cost_centre_info this_mod mb_main_mod foreign_stubs impo (emitSimpleProc plain_main_init_lbl jump_to_init) } where - plain_init_lbl = mkPlainModuleInitLabel dflags this_mod - real_init_lbl = mkModuleInitLabel dflags this_mod way - plain_main_init_lbl = mkPlainModuleInitLabel dflags rOOT_MAIN + plain_init_lbl = mkPlainModuleInitLabel hmods this_mod + real_init_lbl = mkModuleInitLabel hmods this_mod way + plain_main_init_lbl = mkPlainModuleInitLabel hmods rOOT_MAIN jump_to_init = stmtC (CmmJump (mkLblExpr real_init_lbl) []) @@ -205,7 +208,7 @@ mkModuleInit dflags way cost_centre_info this_mod mb_main_mod foreign_stubs impo -- Now do local stuff ; initCostCentres cost_centre_info - ; mapCs (registerModuleImport dflags way) + ; mapCs (registerModuleImport hmods way) (imported_mods++extra_imported_mods) } @@ -215,13 +218,13 @@ mkModuleInit dflags way cost_centre_info this_mod mb_main_mod foreign_stubs impo , CmmJump (CmmLoad (cmmRegOffW spReg (-1)) wordRep) [] ] ----------------------- -registerModuleImport :: DynFlags -> String -> Module -> Code -registerModuleImport dflags way mod +registerModuleImport :: HomeModules -> String -> Module -> Code +registerModuleImport hmods way mod | mod == gHC_PRIM = nopC | otherwise -- Push the init procedure onto the work stack = stmtsC [ CmmAssign spReg (cmmRegOffW spReg (-1)) - , CmmStore (CmmReg spReg) (mkLblExpr (mkModuleInitLabel dflags mod way)) ] + , CmmStore (CmmReg spReg) (mkLblExpr (mkModuleInitLabel hmods mod way)) ] \end{code} @@ -262,32 +265,32 @@ style, with the increasing static environment being plumbed as a state variable. \begin{code} -cgTopBinding :: DynFlags -> (StgBinding,[(Id,[Id])]) -> Code -cgTopBinding dflags (StgNonRec id rhs, srts) +cgTopBinding :: DynFlags -> HomeModules -> (StgBinding,[(Id,[Id])]) -> Code +cgTopBinding dflags hmods (StgNonRec id rhs, srts) = do { id' <- maybeExternaliseId dflags id - ; mapM_ (mkSRT dflags [id']) srts + ; mapM_ (mkSRT hmods [id']) srts ; (id,info) <- cgTopRhs id' rhs ; addBindC id info -- Add the *un-externalised* Id to the envt, -- so we find it when we look up occurrences } -cgTopBinding dflags (StgRec pairs, srts) +cgTopBinding dflags hmods (StgRec pairs, srts) = do { let (bndrs, rhss) = unzip pairs ; bndrs' <- mapFCs (maybeExternaliseId dflags) bndrs ; let pairs' = zip bndrs' rhss - ; mapM_ (mkSRT dflags bndrs') srts + ; mapM_ (mkSRT hmods bndrs') srts ; _new_binds <- fixC (\ new_binds -> do { addBindsC new_binds ; mapFCs ( \ (b,e) -> cgTopRhs b e ) pairs' }) ; nopC } -mkSRT :: DynFlags -> [Id] -> (Id,[Id]) -> Code -mkSRT dflags these (id,[]) = nopC -mkSRT dflags these (id,ids) +mkSRT :: HomeModules -> [Id] -> (Id,[Id]) -> Code +mkSRT hmods these (id,[]) = nopC +mkSRT hmods these (id,ids) = do { ids <- mapFCs remap ids ; id <- remap id ; emitRODataLits (mkSRTLabel (idName id)) - (map (CmmLabel . mkClosureLabel dflags . idName) ids) + (map (CmmLabel . mkClosureLabel hmods . idName) ids) } where -- Sigh, better map all the ids against the environment in diff --git a/ghc/compiler/deSugar/Desugar.lhs b/ghc/compiler/deSugar/Desugar.lhs index b70f802..b117104 100644 --- a/ghc/compiler/deSugar/Desugar.lhs +++ b/ghc/compiler/deSugar/Desugar.lhs @@ -64,6 +64,7 @@ deSugar hsc_env tcg_src = hsc_src, tcg_type_env = type_env, tcg_imports = imports, + tcg_home_mods = home_mods, tcg_exports = exports, tcg_dus = dus, tcg_inst_uses = dfun_uses_var, @@ -132,7 +133,7 @@ deSugar hsc_env dir_imp_mods = imp_mods imports - ; usages <- mkUsageInfo hsc_env dir_imp_mods dep_mods used_names + ; usages <- mkUsageInfo hsc_env home_mods dir_imp_mods dep_mods used_names ; let -- Modules don't compare lexicographically usually, @@ -152,6 +153,7 @@ deSugar hsc_env mg_boot = isHsBoot hsc_src, mg_exports = exports, mg_deps = deps, + mg_home_mods = home_mods, mg_usages = usages, mg_dir_imps = [m | (m,_,_) <- moduleEnvElts dir_imp_mods], mg_rdr_env = rdr_env, diff --git a/ghc/compiler/iface/MkIface.lhs b/ghc/compiler/iface/MkIface.lhs index 3d71b89..5c32a29 100644 --- a/ghc/compiler/iface/MkIface.lhs +++ b/ghc/compiler/iface/MkIface.lhs @@ -200,6 +200,7 @@ import HscTypes ( ModIface(..), ModDetails(..), ) +import Packages ( HomeModules ) import DynFlags ( GhcMode(..), DynFlags(..), DynFlag(..), dopt ) import StaticFlags ( opt_HiVersion ) import Name ( Name, nameModule, nameOccName, nameParent, @@ -259,6 +260,7 @@ mkIface hsc_env maybe_old_iface mg_boot = is_boot, mg_usages = usages, mg_deps = deps, + mg_home_mods = home_mods, mg_rdr_env = rdr_env, mg_fix_env = fix_env, mg_deprecs = src_deprecs }) @@ -273,7 +275,7 @@ mkIface hsc_env maybe_old_iface -- to expose in the interface = do { eps <- hscEPS hsc_env - ; let { ext_nm_rhs = mkExtNameFn hsc_env eps this_mod + ; let { ext_nm_rhs = mkExtNameFn hsc_env home_mods eps this_mod ; ext_nm_lhs = mkLhsNameFn this_mod ; decls = [ tyThingToIfaceDecl ext_nm_rhs thing @@ -350,11 +352,10 @@ writeIfaceFile hsc_env location new_iface no_change_at_all ----------------------------- -mkExtNameFn :: HscEnv -> ExternalPackageState -> Module -> Name -> IfaceExtName -mkExtNameFn hsc_env eps this_mod +mkExtNameFn :: HscEnv -> HomeModules -> ExternalPackageState -> Module -> Name -> IfaceExtName +mkExtNameFn hsc_env hmods eps this_mod = ext_nm where - dflags = hsc_dflags hsc_env hpt = hsc_HPT hsc_env pit = eps_PIT eps @@ -363,7 +364,7 @@ mkExtNameFn hsc_env eps this_mod Nothing -> LocalTop occ Just par -> LocalTopSub occ (nameOccName par) | isWiredInName name = ExtPkg mod occ - | isHomeModule dflags mod = HomePkg mod occ vers + | isHomeModule hmods mod = HomePkg mod occ vers | otherwise = ExtPkg mod occ where mod = nameModule name @@ -639,19 +640,20 @@ bump_unless False v = bumpVersion v \begin{code} mkUsageInfo :: HscEnv + -> HomeModules -> ModuleEnv (Module, Maybe Bool, SrcSpan) -> [(Module, IsBootInterface)] -> NameSet -> IO [Usage] -mkUsageInfo hsc_env dir_imp_mods dep_mods used_names +mkUsageInfo hsc_env hmods dir_imp_mods dep_mods used_names = do { eps <- hscEPS hsc_env - ; let usages = mk_usage_info (eps_PIT eps) hsc_env + ; let usages = mk_usage_info (eps_PIT eps) hsc_env hmods dir_imp_mods dep_mods used_names ; usages `seqList` return usages } -- seq the list of Usages returned: occasionally these -- don't get evaluated for a while and we can end up hanging on to -- the entire collection of Ifaces. -mk_usage_info pit hsc_env dir_imp_mods dep_mods proto_used_names +mk_usage_info pit hsc_env hmods dir_imp_mods dep_mods proto_used_names = mapCatMaybes mkUsage dep_mods -- ToDo: do we need to sort into canonical order? where @@ -688,7 +690,7 @@ mk_usage_info pit hsc_env dir_imp_mods dep_mods proto_used_names mkUsage :: (Module, Bool) -> Maybe Usage mkUsage (mod_name, _) | isNothing maybe_iface -- We can't depend on it if we didn't - || not (isHomeModule dflags mod) -- even open the interface! + || not (isHomeModule hmods mod) -- even open the interface! || (null used_occs && not all_imported && not orphan_mod) diff --git a/ghc/compiler/main/Finder.lhs b/ghc/compiler/main/Finder.lhs index 2b25bc5..f8f51da 100644 --- a/ghc/compiler/main/Finder.lhs +++ b/ghc/compiler/main/Finder.lhs @@ -12,6 +12,7 @@ module Finder ( mkHomeModLocation, -- :: ModuleName -> FilePath -> IO ModLocation mkHomeModLocation2, -- :: ModuleName -> FilePath -> String -> IO ModLocation addHomeModuleToFinder, -- :: HscEnv -> Module -> ModLocation -> IO () + uncacheModule, -- :: HscEnv -> Module -> IO () findObjectLinkableMaybe, findObjectLinkable, @@ -22,7 +23,7 @@ module Finder ( #include "HsVersions.h" import Module -import UniqFM ( filterUFM ) +import UniqFM ( filterUFM, delFromUFM ) import HscTypes import Packages import FastString @@ -36,7 +37,6 @@ import Data.List import System.Directory import System.IO import Control.Monad -import Maybes ( MaybeErr(..) ) import Data.Maybe ( isNothing ) import Time ( ClockTime ) @@ -52,7 +52,7 @@ type BaseName = String -- Basename of file -- source, interface, and object files for that module live. -- It does *not* know which particular package a module lives in. Use --- Packages.moduleToPackageConfig for that. +-- Packages.lookupModuleInAllPackages for that. -- ----------------------------------------------------------------------------- -- The finder's cache @@ -69,6 +69,11 @@ addToFinderCache finder_cache mod_name entry = do fm <- readIORef finder_cache writeIORef finder_cache $! extendModuleEnv fm mod_name entry +removeFromFinderCache :: IORef FinderCache -> Module -> IO () +removeFromFinderCache finder_cache mod_name = do + fm <- readIORef finder_cache + writeIORef finder_cache $! delFromUFM fm mod_name + lookupFinderCache :: IORef FinderCache -> Module -> IO (Maybe FinderCacheEntry) lookupFinderCache finder_cache mod_name = do fm <- readIORef finder_cache @@ -90,8 +95,8 @@ lookupFinderCache finder_cache mod_name = do data FindResult = Found ModLocation PackageIdH -- the module was found - | FoundMultiple ModLocation PackageId - -- *error*: both a home module and a package module + | FoundMultiple [PackageId] + -- *error*: both in multiple packages | PackageHidden PackageId -- for an explicit source import: the package containing the module is -- not exposed. @@ -108,10 +113,10 @@ findPackageModule :: HscEnv -> Module -> Bool -> IO FindResult findPackageModule = findModule' False -type LocalFindResult = MaybeErr [FilePath] FinderCacheEntry - -- LocalFindResult is used for internal functions which - -- return a more informative type; it's munged into - -- the external FindResult by 'cached' +data LocalFindResult + = Ok FinderCacheEntry + | CantFindAmongst [FilePath] + | MultiplePackages [PackageId] findModule' :: Bool -> HscEnv -> Module -> Bool -> IO FindResult findModule' home_allowed hsc_env name explicit @@ -147,52 +152,31 @@ findModule' home_allowed hsc_env name explicit | not home_allowed = do j <- findPackageModule' dflags name case j of - Failed paths -> return (NotFound paths) - Succeeded entry -> found_new entry + Ok entry -> found_new entry + MultiplePackages pkgs -> return (FoundMultiple pkgs) + CantFindAmongst paths -> return (NotFound paths) - | home_allowed && explicit = do - -- for an explict home import, we try looking for - -- both a package module and a home module, and report - -- a FoundMultiple if we find both. + | otherwise = do j <- findHomeModule' dflags name case j of - Failed home_files -> do + Ok entry -> found_new entry + MultiplePackages pkgs -> return (FoundMultiple pkgs) + CantFindAmongst home_files -> do r <- findPackageModule' dflags name case r of - Failed pkg_files -> + CantFindAmongst pkg_files -> return (NotFound (home_files ++ pkg_files)) - Succeeded entry -> + MultiplePackages pkgs -> + return (FoundMultiple pkgs) + Ok entry -> found_new entry - Succeeded entry@(loc,_) -> do - r <- findPackageModule' dflags name - case r of - Failed pkg_files -> found_new entry - Succeeded (_,Just (pkg,_)) -> - return (FoundMultiple loc (packageConfigId pkg)) - Succeeded _ -> - panic "findModule: shouldn't happen" - - -- implicit home imports: check for package modules first, - -- because that's the quickest (doesn't involve filesystem - -- operations). - | home_allowed && not explicit = do - r <- findPackageModule' dflags name - case r of - Failed pkg_files -> do - j <- findHomeModule' dflags name - case j of - Failed home_files -> - return (NotFound (home_files ++ pkg_files)) - Succeeded entry -> - found_new entry - Succeeded entry -> - found_new entry - addHomeModuleToFinder :: HscEnv -> Module -> ModLocation -> IO () addHomeModuleToFinder hsc_env mod loc = addToFinderCache (hsc_FC hsc_env) mod (loc, Nothing) +uncacheModule :: HscEnv -> Module -> IO () +uncacheModule hsc_env mod = removeFromFinderCache (hsc_FC hsc_env) mod -- ----------------------------------------------------------------------------- -- The internal workers @@ -222,9 +206,10 @@ findHomeModule' dflags mod = do findPackageModule' :: DynFlags -> Module -> IO LocalFindResult findPackageModule' dflags mod - = case moduleToPackageConfig dflags mod of - Nothing -> return (Failed []) - Just pkg_info -> findPackageIface dflags mod pkg_info + = case lookupModuleInAllPackages dflags mod of + [] -> return (CantFindAmongst []) + [pkg_info] -> findPackageIface dflags mod pkg_info + many -> return (MultiplePackages (map (mkPackageId.package.fst) many)) findPackageIface :: DynFlags -> Module -> (PackageConfig,Bool) -> IO LocalFindResult findPackageIface dflags mod pkg_info@(pkg_conf, _) = do @@ -291,11 +276,11 @@ searchPathExts paths mod exts file = base `joinFileExt` ext ] - search [] = return (Failed (map fst to_search)) + search [] = return (CantFindAmongst (map fst to_search)) search ((file, mk_result) : rest) = do b <- doesFileExist file if b - then do { res <- mk_result; return (Succeeded res) } + then do { res <- mk_result; return (Ok res) } else search rest mkHomeModLocationSearched :: DynFlags -> Module -> FileExt @@ -450,13 +435,10 @@ dots_to_slashes = map (\c -> if c == '.' then '/' else c) -- Error messages cantFindError :: DynFlags -> Module -> FindResult -> SDoc -cantFindError dflags mod_name (FoundMultiple loc pkg) +cantFindError dflags mod_name (FoundMultiple pkgs) = hang (ptext SLIT("Cannot import") <+> quotes (ppr mod_name) <> colon) 2 ( - sep [ptext SLIT("it was found in both") <+> - (case ml_hs_file loc of Nothing -> ptext SLIT("") - Just f -> text f), - ptext SLIT("and package") <+> ppr pkg <> char '.'] $$ - ptext SLIT("Possible fix: -ignore-package") <+> ppr pkg + sep [ptext SLIT("it was found in multiple packages:"), + hsep (map (text.packageIdString) pkgs)] ) cantFindError dflags mod_name find_result = hang (ptext SLIT("Could not find module") <+> quotes (ppr mod_name) <> colon) @@ -481,5 +463,5 @@ cantFindError dflags mod_name find_result -> hang (ptext SLIT("locations searched:")) 2 (vcat (map text files)) - Found _ _ -> panic "cantFindErr" + _ -> panic "cantFindErr" \end{code} diff --git a/ghc/compiler/main/GHC.hs b/ghc/compiler/main/GHC.hs index dd86581..811f1cb 100644 --- a/ghc/compiler/main/GHC.hs +++ b/ghc/compiler/main/GHC.hs @@ -172,7 +172,7 @@ import VarEnv ( emptyTidyEnv ) import GHC.Exts ( unsafeCoerce# ) #endif -import Packages ( initPackages, isHomeModule ) +import Packages ( PackageIdH(..), initPackages ) import NameSet ( NameSet, nameSetToList, elemNameSet ) import RdrName ( GlobalRdrEnv, GlobalRdrElt(..), RdrName, globalRdrEnvElts ) @@ -228,6 +228,7 @@ import FastString ( mkFastString ) import Directory ( getModificationTime, doesFileExist ) import Maybe ( isJust, isNothing, fromJust ) import Maybes ( orElse, expectJust, mapCatMaybes ) +import qualified Maybes (MaybeErr(..)) import List ( partition, nub ) import qualified List import Monad ( unless, when ) @@ -1360,6 +1361,10 @@ summariseFile hsc_env old_summaries file mb_phase maybe_buf src_timestamp <- case maybe_buf of Just (_,t) -> return t Nothing -> getModificationTime file + -- The file exists; we checked in getRootSummary above. + -- If it gets removed subsequently, then this + -- getModificationTime may fail, but that's the right + -- behaviour. if ms_hs_date old_summary == src_timestamp then do -- update the object-file timestamp @@ -1389,6 +1394,7 @@ summariseFile hsc_env old_summaries file mb_phase maybe_buf src_timestamp <- case maybe_buf of Just (_,t) -> return t Nothing -> getModificationTime file + -- getMofificationTime may fail obj_timestamp <- modificationTimeIfExists (ml_obj_file location) @@ -1427,21 +1433,41 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) maybe_buf exc let location = ms_location old_summary src_fn = expectJust "summariseModule" (ml_hs_file location) - -- return the cached summary if the source didn't change - src_timestamp <- case maybe_buf of - Just (_,t) -> return t - Nothing -> getModificationTime src_fn + -- check the modification time on the source file, and + -- return the cached summary if it hasn't changed. If the + -- file has disappeared, we need to call the Finder again. + case maybe_buf of + Just (_,t) -> check_timestamp old_summary location src_fn t + Nothing -> do + m <- IO.try (getModificationTime src_fn) + case m of + Right t -> check_timestamp old_summary location src_fn t + Left e | isDoesNotExistError e -> find_it + | otherwise -> ioError e + + | otherwise = find_it + where + dflags = hsc_dflags hsc_env - if ms_hs_date old_summary == src_timestamp - then do -- update the object-file timestamp - obj_timestamp <- getObjTimestamp location is_boot - return (Just old_summary{ ms_obj_date = obj_timestamp }) - else - -- source changed: re-summarise - new_summary location src_fn maybe_buf src_timestamp + hsc_src = if is_boot then HsBootFile else HsSrcFile - | otherwise - = do found <- findModule hsc_env wanted_mod True {-explicit-} + check_timestamp old_summary location src_fn src_timestamp + | ms_hs_date old_summary == src_timestamp = do + -- update the object-file timestamp + obj_timestamp <- getObjTimestamp location is_boot + return (Just old_summary{ ms_obj_date = obj_timestamp }) + | otherwise = + -- source changed: find and re-summarise. We call the finder + -- again, because the user may have moved the source file. + new_summary location src_fn src_timestamp + + find_it = do + -- Don't use the Finder's cache this time. If the module was + -- previously a package module, it may have now appeared on the + -- search path, so we want to consider it to be a home module. If + -- the module was previously a home module, it may have moved. + uncacheModule hsc_env wanted_mod + found <- findModule hsc_env wanted_mod True {-explicit-} case found of Found location pkg | not (isHomePackage pkg) -> return Nothing @@ -1450,10 +1476,6 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) maybe_buf exc -- Home package err -> noModError dflags loc wanted_mod err -- Not found - where - dflags = hsc_dflags hsc_env - - hsc_src = if is_boot then HsBootFile else HsSrcFile just_found location = do -- Adjust location to point to the hs-boot source file, @@ -1467,10 +1489,10 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) maybe_buf exc maybe_t <- modificationTimeIfExists src_fn case maybe_t of Nothing -> noHsFileErr loc src_fn - Just t -> new_summary location' src_fn Nothing t + Just t -> new_summary location' src_fn t - new_summary location src_fn maybe_bug src_timestamp + new_summary location src_fn src_timestamp = do -- Preprocess the source file and get its imports -- The dflags' contains the OPTIONS pragmas @@ -1610,13 +1632,13 @@ getModuleInfo s mdl = withSession s $ \hsc_env -> do if mdl `elem` map ms_mod mg then getHomeModuleInfo hsc_env mdl else do - if isHomeModule (hsc_dflags hsc_env) mdl + {- if isHomeModule (hsc_dflags hsc_env) mdl then return Nothing - else getPackageModuleInfo hsc_env mdl + else -} getPackageModuleInfo hsc_env mdl -- getPackageModuleInfo will attempt to find the interface, so -- we don't want to call it for a home module, just in case there -- was a problem loading the module and the interface doesn't - -- exist... hence the isHomeModule test here. + -- exist... hence the isHomeModule test here. (ToDo: reinstate) getPackageModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo) getPackageModuleInfo hsc_env mdl = do @@ -1755,7 +1777,8 @@ setContext (Session ref) toplevs exports = do let all_env = foldr plusGlobalRdrEnv export_env toplev_envs writeIORef ref hsc_env{ hsc_IC = old_ic { ic_toplev_scope = toplevs, ic_exports = exports, - ic_rn_gbl_env = all_env } } + ic_rn_gbl_env = all_env }} + -- Make a GlobalRdrEnv based on the exports of the modules only. mkExportEnv :: HscEnv -> [Module] -> IO GlobalRdrEnv diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index 98c0085..29131b3 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -60,6 +60,7 @@ import TidyPgm ( tidyProgram, mkBootModDetails ) import CorePrep ( corePrepPgm ) import CoreToStg ( coreToStg ) import TyCon ( isDataTyCon ) +import Packages ( mkHomeModules ) import Name ( Name, NamedThing(..) ) import SimplStg ( stg2stg ) import CodeGen ( codeGen ) @@ -474,6 +475,7 @@ hscCodeGen dflags cg_tycons = tycons, cg_dir_imps = dir_imps, cg_foreign = foreign_stubs, + cg_home_mods = home_mods, cg_dep_pkgs = dependencies } = do { let { data_tycons = filter isDataTyCon tycons } ; @@ -507,12 +509,13 @@ hscCodeGen dflags do ----------------- Convert to STG ------------------ (stg_binds, cost_centre_info) <- {-# SCC "CoreToStg" #-} - myCoreToStg dflags this_mod prepd_binds + myCoreToStg dflags home_mods this_mod prepd_binds ------------------ Code generation ------------------ abstractC <- {-# SCC "CodeGen" #-} - codeGen dflags this_mod data_tycons foreign_stubs - dir_imps cost_centre_info stg_binds + codeGen dflags home_mods this_mod data_tycons + foreign_stubs dir_imps cost_centre_info + stg_binds ------------------ Code output ----------------------- (stub_h_exists, stub_c_exists) @@ -525,7 +528,7 @@ hscCodeGen dflags hscCmmFile :: DynFlags -> FilePath -> IO Bool hscCmmFile dflags filename = do - maybe_cmm <- parseCmmFile dflags filename + maybe_cmm <- parseCmmFile dflags (mkHomeModules []) filename case maybe_cmm of Nothing -> return False Just cmm -> do @@ -565,13 +568,13 @@ myParseModule dflags src_filename maybe_src_buf }} -myCoreToStg dflags this_mod prepd_binds +myCoreToStg dflags pkg_deps this_mod prepd_binds = do stg_binds <- {-# SCC "Core2Stg" #-} coreToStg dflags prepd_binds (stg_binds2, cost_centre_info) <- {-# SCC "Core2Stg" #-} - stg2stg dflags this_mod stg_binds + stg2stg dflags pkg_deps this_mod stg_binds return (stg_binds2, cost_centre_info) \end{code} diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs index d5727fe..3f93389 100644 --- a/ghc/compiler/main/HscTypes.lhs +++ b/ghc/compiler/main/HscTypes.lhs @@ -84,7 +84,7 @@ import Type ( TyThing(..) ) import Class ( Class, classSelIds, classTyCon ) import TyCon ( TyCon, tyConSelIds, tyConDataCons ) import DataCon ( dataConImplicitIds ) -import Packages ( PackageIdH, PackageId, PackageConfig ) +import Packages ( PackageIdH, PackageId, PackageConfig, HomeModules ) import DynFlags ( DynFlags(..), isOneShot ) import DriverPhases ( HscSource(..), isHsBoot, hscSourceString, Phase ) import BasicTypes ( Version, initialVersion, IPName, @@ -397,6 +397,7 @@ data ModGuts mg_boot :: IsBootInterface, -- Whether it's an hs-boot module mg_exports :: !NameSet, -- What it exports mg_deps :: !Dependencies, -- What is below it, directly or otherwise + mg_home_mods :: !HomeModules, -- For calling isHomeModule etc. mg_dir_imps :: ![Module], -- Directly-imported modules; used to -- generate initialisation code mg_usages :: ![Usage], -- Version info for what it needed @@ -428,20 +429,25 @@ data CgGuts = CgGuts { cg_module :: !Module, - cg_tycons :: [TyCon], -- Algebraic data types (including ones that started life - -- as classes); generate constructors and info tables - -- Includes newtypes, just for the benefit of External Core + cg_tycons :: [TyCon], + -- Algebraic data types (including ones that started + -- life as classes); generate constructors and info + -- tables Includes newtypes, just for the benefit of + -- External Core - cg_binds :: [CoreBind], -- The tidied main bindings, including previously-implicit - -- bindings for record and class selectors, and - -- data construtor wrappers. - -- But *not* data constructor workers; reason: we - -- we regard them as part of the code-gen of tycons + cg_binds :: [CoreBind], + -- The tidied main bindings, including + -- previously-implicit bindings for record and class + -- selectors, and data construtor wrappers. But *not* + -- data constructor workers; reason: we we regard them + -- as part of the code-gen of tycons - cg_dir_imps :: ![Module], -- Directly-imported modules; used to generate - -- initialisation code + cg_dir_imps :: ![Module], + -- Directly-imported modules; used to generate + -- initialisation code cg_foreign :: !ForeignStubs, + cg_home_mods :: !HomeModules, -- for calling isHomeModule etc. cg_dep_pkgs :: ![PackageId] -- Used to generate #includes for C code gen } diff --git a/ghc/compiler/main/Packages.lhs b/ghc/compiler/main/Packages.lhs index 240c132..1df4e0f 100644 --- a/ghc/compiler/main/Packages.lhs +++ b/ghc/compiler/main/Packages.lhs @@ -15,9 +15,11 @@ module Packages ( PackageIdH(..), isHomePackage, PackageState(..), initPackages, - moduleToPackageConfig, getPackageDetails, - isHomeModule, + checkForPackageConflicts, + lookupModuleInAllPackages, + + HomeModules, mkHomeModules, isHomeModule, -- * Inspecting the set of packages in scope getPackageIncludePath, @@ -43,11 +45,12 @@ import DynFlags ( dopt, DynFlag(..), DynFlags(..), PackageFlag(..) ) import StaticFlags ( opt_Static ) import Config ( cProjectVersion ) import Name ( Name, nameModule_maybe ) -import Module ( Module, mkModule ) import UniqFM +import Module +import FiniteMap import UniqSet import Util -import Maybes ( expectJust ) +import Maybes ( expectJust, MaybeErr(..) ) import Panic import Outputable @@ -62,7 +65,7 @@ import Distribution.Package import Distribution.Version import Data.Maybe ( isNothing ) import System.Directory ( doesFileExist ) -import Control.Monad ( when, foldM ) +import Control.Monad ( foldM ) import Data.List ( nub, partition ) #ifdef mingw32_TARGET_OS @@ -70,9 +73,8 @@ import Data.List ( isPrefixOf ) #endif import FastString -import DATA_IOREF import EXCEPTION ( throwDyn ) -import ErrUtils ( debugTraceMsg, putMsg ) +import ErrUtils ( debugTraceMsg, putMsg, Message ) -- --------------------------------------------------------------------------- -- The Package state @@ -140,7 +142,7 @@ data PackageState = PackageState { -- mapping derived from the package databases and -- command-line package flags. - moduleToPkgConf :: UniqFM (PackageConfig,Bool), + moduleToPkgConfAll :: ModuleEnv [(PackageConfig,Bool)], -- Maps Module to (pkgconf,exposed), where pkgconf is the -- PackageConfig for the package containing the module, and -- exposed is True if the package exposes that module. @@ -266,7 +268,7 @@ mungePackagePaths top_dir ps = map munge_pkg ps -- settings and populate the package state. mkPackageState :: DynFlags -> PackageConfigMap -> IO PackageState -mkPackageState dflags pkg_db = do +mkPackageState dflags orig_pkg_db = do -- -- Modify the package database according to the command-line flags -- (-package, -hide-package, -ignore-package, -hide-all-packages). @@ -307,7 +309,7 @@ mkPackageState dflags pkg_db = do = str == showPackageId (package p) || str == pkgName (package p) -- - (pkgs1,explicit) <- procflags (eltsUFM pkg_db) emptyUniqSet flags + (pkgs1,explicit) <- procflags (eltsUFM orig_pkg_db) emptyUniqSet flags -- let elimDanglingDeps pkgs = @@ -362,35 +364,15 @@ mkPackageState dflags pkg_db = do -- Discover any conflicts at the same time, and factor in the new exposed -- status of each package. -- - let - extend_modmap modmap pkgname = do - let - pkg = expectJust "mkPackageState" (lookupPackage pkg_db pkgname) - exposed_mods = map mkModule (exposedModules pkg) - hidden_mods = map mkModule (hiddenModules pkg) - all_mods = exposed_mods ++ hidden_mods - -- - -- check for overlaps - -- - let - overlaps = [ (m,pkg) | m <- all_mods, - Just (pkg,_) <- [lookupUFM modmap m] ] - -- - when (not (null overlaps)) $ overlappingError pkg overlaps - -- - return (addListToUFM modmap - [(m, (pkg, m `elem` exposed_mods)) - | m <- all_mods]) - -- - mod_map <- foldM extend_modmap emptyUFM dep_exposed - - return PackageState{ explicitPackages = dep_explicit, - pkgIdMap = pkg_db, - moduleToPkgConf = mod_map, - basePackageId = basePackageId, - rtsPackageId = rtsPackageId, - haskell98PackageId = haskell98PackageId, - thPackageId = thPackageId + let mod_map = mkModuleMap orig_pkg_db dep_exposed + + return PackageState{ explicitPackages = dep_explicit, + pkgIdMap = orig_pkg_db, + moduleToPkgConfAll = mod_map, + basePackageId = basePackageId, + rtsPackageId = rtsPackageId, + haskell98PackageId = haskell98PackageId, + thPackageId = thPackageId } -- done! @@ -400,16 +382,6 @@ haskell98PackageName = FSLIT("haskell98") thPackageName = FSLIT("template-haskell") -- Template Haskell libraries in here -overlappingError pkg overlaps - = throwDyn (CmdLineError (showSDoc (vcat (map msg overlaps)))) - where - this_pkg = text (showPackageId (package pkg)) - msg (mod,other_pkg) = - text "Error: module '" <> ppr mod - <> text "' is exposed by package " - <> this_pkg <> text " and package " - <> text (showPackageId (package other_pkg)) - multiplePackagesErr str ps = throwDyn (CmdLineError (showSDoc ( text "Error; multiple packages match" <+> @@ -417,6 +389,90 @@ multiplePackagesErr str ps = sep (punctuate comma (map (text.showPackageId.package) ps)) ))) +mkModuleMap + :: PackageConfigMap + -> [PackageId] + -> ModuleEnv [(PackageConfig, Bool)] +mkModuleMap pkg_db pkgs = foldr extend_modmap emptyUFM pkgs + where + extend_modmap pkgname modmap = + addListToUFM_C (++) modmap + [(m, [(pkg, m `elem` exposed_mods)]) | m <- all_mods] + where + pkg = expectJust "mkModuleMap" (lookupPackage pkg_db pkgname) + exposed_mods = map mkModule (exposedModules pkg) + hidden_mods = map mkModule (hiddenModules pkg) + all_mods = exposed_mods ++ hidden_mods + +-- ----------------------------------------------------------------------------- +-- Check for conflicts in the program. + +-- | A conflict arises if the program contains two modules with the same +-- name, which can arise if the program depends on multiple packages that +-- expose the same module, or if the program depends on a package that +-- contains a module also present in the program (the "home package"). +-- +checkForPackageConflicts + :: DynFlags + -> [Module] -- modules in the home package + -> [PackageId] -- packages on which the program depends + -> MaybeErr Message () + +checkForPackageConflicts dflags mods pkgs = do + let + state = pkgState dflags + pkg_db = pkgIdMap state + -- + dep_pkgs <- closeDepsErr pkg_db pkgs + + let + extend_modmap pkgname modmap = + addListToFM_C (++) modmap + [(m, [(pkg, m `elem` exposed_mods)]) | m <- all_mods] + where + pkg = expectJust "checkForPackageConflicts" + (lookupPackage pkg_db pkgname) + exposed_mods = map mkModule (exposedModules pkg) + hidden_mods = map mkModule (hiddenModules pkg) + all_mods = exposed_mods ++ hidden_mods + + mod_map = foldr extend_modmap emptyFM pkgs + mod_map_list :: [(Module,[(PackageConfig,Bool)])] + mod_map_list = fmToList mod_map + + overlaps = [ (m, map fst ps) | (m,ps@(_:_:_)) <- mod_map_list ] + -- + if not (null overlaps) + then Failed (pkgOverlapError overlaps) + else do + + let + overlap_mods = [ (mod,pkg) + | mod <- mods, + Just ((pkg,_):_) <- [lookupFM mod_map mod] ] + -- will be only one package here + if not (null overlap_mods) + then Failed (modOverlapError overlap_mods) + else do + + return () + +pkgOverlapError overlaps = vcat (map msg overlaps) + where + msg (mod,pkgs) = + text "conflict: module" <+> quotes (ppr mod) + <+> ptext SLIT("is present in multiple packages:") + <+> hsep (punctuate comma (map (text.showPackageId.package) pkgs)) + +modOverlapError overlaps = vcat (map msg overlaps) + where + msg (mod,pkg) = fsep [ + text "conflict: module", + quotes (ppr mod), + ptext SLIT("belongs to the current program/library"), + ptext SLIT("and also to package"), + text (showPackageId (package pkg)) ] + -- ----------------------------------------------------------------------------- -- Extracting information from the packages in scope @@ -513,15 +569,14 @@ getPackageFrameworks dflags pkgs = do -- ----------------------------------------------------------------------------- -- Package Utils --- Takes a Module, and if the module is in a package returns --- (pkgconf,exposed) where pkgconf is the PackageConfig for that package, +-- | Takes a Module, and if the module is in a package returns +-- @(pkgconf,exposed)@ where pkgconf is the PackageConfig for that package, -- and exposed is True if the package exposes the module. -moduleToPackageConfig :: DynFlags -> Module -> Maybe (PackageConfig,Bool) -moduleToPackageConfig dflags m = - lookupUFM (moduleToPkgConf (pkgState dflags)) m - -isHomeModule :: DynFlags -> Module -> Bool -isHomeModule dflags mod = isNothing (moduleToPackageConfig dflags mod) +lookupModuleInAllPackages :: DynFlags -> Module -> [(PackageConfig,Bool)] +lookupModuleInAllPackages dflags m = + case lookupModuleEnv (moduleToPkgConfAll (pkgState dflags)) m of + Nothing -> [] + Just ps -> ps getExplicitPackagesAnd :: DynFlags -> [PackageId] -> IO [PackageConfig] getExplicitPackagesAnd dflags pkgids = @@ -530,44 +585,60 @@ getExplicitPackagesAnd dflags pkgids = pkg_map = pkgIdMap state expl = explicitPackages state in do - all_pkgs <- foldM (add_package pkg_map) expl pkgids + all_pkgs <- throwErr (foldM (add_package pkg_map) expl pkgids) return (map (getPackageDetails state) all_pkgs) -- Takes a list of packages, and returns the list with dependencies included, -- in reverse dependency order (a package appears before those it depends on). closeDeps :: PackageConfigMap -> [PackageId] -> IO [PackageId] -closeDeps pkg_map ps = foldM (add_package pkg_map) [] ps +closeDeps pkg_map ps = throwErr (closeDepsErr pkg_map ps) + +throwErr :: MaybeErr Message a -> IO a +throwErr m = case m of + Failed e -> throwDyn (CmdLineError (showSDoc e)) + Succeeded r -> return r + +closeDepsErr :: PackageConfigMap -> [PackageId] + -> MaybeErr Message [PackageId] +closeDepsErr pkg_map ps = foldM (add_package pkg_map) [] ps -- internal helper -add_package :: PackageConfigMap -> [PackageId] -> PackageId -> IO [PackageId] +add_package :: PackageConfigMap -> [PackageId] -> PackageId + -> MaybeErr Message [PackageId] add_package pkg_db ps p | p `elem` ps = return ps -- Check if we've already added this package | otherwise = case lookupPackage pkg_db p of - Nothing -> missingPackageErr (packageIdString p) + Nothing -> Failed (missingPackageErr (packageIdString p)) Just pkg -> do -- Add the package's dependents also let deps = map mkPackageId (depends pkg) ps' <- foldM (add_package pkg_db) ps deps return (p : ps') -missingPackageErr p = throwDyn (CmdLineError ("unknown package: " ++ p)) +missingPackageErr p = throwDyn (CmdLineError (showSDoc (missingPackageMsg p))) +missingPackageMsg p = ptext SLIT("unknown package:") <> text p -- ----------------------------------------------------------------------------- +-- The home module set + +newtype HomeModules = HomeModules ModuleSet + +mkHomeModules :: [Module] -> HomeModules +mkHomeModules = HomeModules . mkModuleSet + +isHomeModule :: HomeModules -> Module -> Bool +isHomeModule (HomeModules set) mod = elemModuleSet mod set + -- Determining whether a Name refers to something in another package or not. -- Cross-package references need to be handled differently when dynamically- -- linked libraries are involved. -isDllName :: DynFlags -> Name -> Bool -isDllName dflags name +isDllName :: HomeModules -> Name -> Bool +isDllName pdeps name | opt_Static = False - | otherwise = - case nameModule_maybe name of - Nothing -> False -- no, it is not even an external name - Just mod -> - case lookupUFM (moduleToPkgConf (pkgState dflags)) mod of - Just _ -> True -- yes, its a package module - Nothing -> False -- no, must be a home module + | Just mod <- nameModule_maybe name = not (isHomeModule pdeps mod) + | otherwise = False -- no, it is not even an external name -- ----------------------------------------------------------------------------- -- Displaying packages diff --git a/ghc/compiler/main/TidyPgm.lhs b/ghc/compiler/main/TidyPgm.lhs index aac82f3..0af2ca7 100644 --- a/ghc/compiler/main/TidyPgm.lhs +++ b/ghc/compiler/main/TidyPgm.lhs @@ -237,6 +237,7 @@ tidyProgram hsc_env mg_binds = binds, mg_rules = imp_rules, mg_dir_imps = dir_imps, mg_deps = deps, + mg_home_mods = home_mods, mg_foreign = foreign_stubs }) = do { let dflags = hsc_dflags hsc_env @@ -282,6 +283,7 @@ tidyProgram hsc_env cg_binds = implicit_binds ++ tidy_binds, cg_dir_imps = dir_imps, cg_foreign = foreign_stubs, + cg_home_mods = home_mods, cg_dep_pkgs = dep_pkgs deps }, ModDetails { md_types = tidy_type_env, diff --git a/ghc/compiler/profiling/SCCfinal.lhs b/ghc/compiler/profiling/SCCfinal.lhs index 8c6bcf9..58c62e2 100644 --- a/ghc/compiler/profiling/SCCfinal.lhs +++ b/ghc/compiler/profiling/SCCfinal.lhs @@ -29,7 +29,7 @@ module SCCfinal ( stgMassageForProfiling ) where import StgSyn -import DynFlags ( DynFlags ) +import Packages ( HomeModules ) import StaticFlags ( opt_AutoSccsOnIndividualCafs ) import CostCentre -- lots of things import Id ( Id ) @@ -45,13 +45,13 @@ infixr 9 `thenMM`, `thenMM_` \begin{code} stgMassageForProfiling - :: DynFlags + :: HomeModules -> Module -- module name -> UniqSupply -- unique supply -> [StgBinding] -- input -> (CollectedCCs, [StgBinding]) -stgMassageForProfiling dflags mod_name us stg_binds +stgMassageForProfiling pdeps mod_name us stg_binds = let ((local_ccs, extern_ccs, cc_stacks), stg_binds2) @@ -102,7 +102,7 @@ stgMassageForProfiling dflags mod_name us stg_binds do_top_rhs :: Id -> StgRhs -> MassageM StgRhs do_top_rhs binder (StgRhsClosure _ bi fv u srt [] (StgSCC cc (StgConApp con args))) - | not (isSccCountCostCentre cc) && not (isDllConApp dflags con args) + | not (isSccCountCostCentre cc) && not (isDllConApp pdeps con args) -- Trivial _scc_ around nothing but static data -- Eliminate _scc_ ... and turn into StgRhsCon diff --git a/ghc/compiler/simplStg/SimplStg.lhs b/ghc/compiler/simplStg/SimplStg.lhs index f43f241..e87877c 100644 --- a/ghc/compiler/simplStg/SimplStg.lhs +++ b/ghc/compiler/simplStg/SimplStg.lhs @@ -16,6 +16,7 @@ import StgLint ( lintStgBindings ) import StgStats ( showStgStats ) import SRT ( computeSRTs ) +import Packages ( HomeModules ) import DynFlags ( DynFlags(..), DynFlag(..), dopt, StgToDo(..), getStgToDo ) import Id ( Id ) @@ -27,12 +28,13 @@ import Outputable \begin{code} stg2stg :: DynFlags -- includes spec of what stg-to-stg passes to do + -> HomeModules -> Module -- module name (profiling only) -> [StgBinding] -- input... -> IO ( [(StgBinding,[(Id,[Id])])] -- output program... , CollectedCCs) -- cost centre information (declared and used) -stg2stg dflags module_name binds +stg2stg dflags pkg_deps module_name binds = do { showPass dflags "Stg2Stg" ; us <- mkSplitUniqSupply 'g' @@ -72,7 +74,7 @@ stg2stg dflags module_name binds {-# SCC "ProfMassage" #-} let (collected_CCs, binds3) - = stgMassageForProfiling dflags module_name us1 binds + = stgMassageForProfiling pkg_deps module_name us1 binds in end_pass us2 "ProfMassage" collected_CCs binds3 diff --git a/ghc/compiler/stgSyn/StgSyn.lhs b/ghc/compiler/stgSyn/StgSyn.lhs index 75f6a94..f1c50cc 100644 --- a/ghc/compiler/stgSyn/StgSyn.lhs +++ b/ghc/compiler/stgSyn/StgSyn.lhs @@ -66,6 +66,7 @@ import UniqSet ( isEmptyUniqSet, uniqSetToList, UniqSet ) import Unique ( Unique ) import Bitmap import DynFlags ( DynFlags ) +import Packages ( HomeModules ) import StaticFlags ( opt_SccProfilingOn ) \end{code} @@ -105,18 +106,18 @@ data GenStgArg occ isStgTypeArg (StgTypeArg _) = True isStgTypeArg other = False -isDllArg :: DynFlags -> StgArg -> Bool +isDllArg :: HomeModules -> StgArg -> Bool -- Does this argument refer to something in a different DLL? -isDllArg dflags (StgTypeArg v) = False -isDllArg dflags (StgVarArg v) = isDllName dflags (idName v) -isDllArg dflags (StgLitArg lit) = False +isDllArg hmods (StgTypeArg v) = False +isDllArg hmods (StgVarArg v) = isDllName hmods (idName v) +isDllArg hmods (StgLitArg lit) = False -isDllConApp :: DynFlags -> DataCon -> [StgArg] -> Bool +isDllConApp :: HomeModules -> DataCon -> [StgArg] -> Bool -- Does this constructor application refer to -- anything in a different DLL? -- If so, we can't allocate it statically -isDllConApp dflags con args - = isDllName dflags (dataConName con) || any (isDllArg dflags) args +isDllConApp hmods con args + = isDllName hmods (dataConName con) || any (isDllArg hmods) args stgArgType :: StgArg -> Type -- Very half baked becase we have lost the type arguments diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs index 8e586b0..21466a8 100644 --- a/ghc/compiler/typecheck/Inst.lhs +++ b/ghc/compiler/typecheck/Inst.lhs @@ -771,11 +771,11 @@ lookupPred pred@(ClassP clas tys) lookupPred ip_pred = return Nothing record_dfun_usage dfun_id - = do { dflags <- getDOpts + = do { gbl <- getGblEnv ; let dfun_name = idName dfun_id dfun_mod = nameModule dfun_name ; if isInternalName dfun_name || -- Internal name => defined in this module - not (isHomeModule dflags dfun_mod) + not (isHomeModule (tcg_home_mods gbl) dfun_mod) then return () -- internal, or in another package else do { tcg_env <- getGblEnv ; updMutVar (tcg_inst_uses tcg_env) diff --git a/ghc/compiler/typecheck/TcRnDriver.lhs b/ghc/compiler/typecheck/TcRnDriver.lhs index 8e91367..74484b0 100644 --- a/ghc/compiler/typecheck/TcRnDriver.lhs +++ b/ghc/compiler/typecheck/TcRnDriver.lhs @@ -26,8 +26,7 @@ import {-# SOURCE #-} TcSplice ( tcSpliceDecls ) import DynFlags ( DynFlag(..), DynFlags(..), dopt, GhcMode(..) ) import StaticFlags ( opt_PprStyle_Debug ) -import Packages ( moduleToPackageConfig, mkPackageId, package, - isHomeModule ) +import Packages ( checkForPackageConflicts, mkHomeModules ) import HsSyn ( HsModule(..), HsExtCore(..), HsGroup(..), LHsDecl, SpliceDecl(..), HsBind(..), LHsBinds, emptyGroup, appendGroups, @@ -125,6 +124,7 @@ import SrcLoc ( unLoc, noSrcSpan ) #endif import FastString ( mkFastString ) +import Maybes ( MaybeErr(..) ) import Util ( sortLe ) import Bag ( unionBags, snocBag, emptyBag, unitBag, unionManyBags ) @@ -159,8 +159,6 @@ tcRnModule hsc_env hsc_src save_rn_decls initTc hsc_env hsc_src this_mod $ setSrcSpan loc $ do { - checkForPackageModule (hsc_dflags hsc_env) this_mod; - -- Deal with imports; sets tcg_rdr_env, tcg_imports (rdr_env, imports) <- rnImports import_decls ; @@ -182,6 +180,8 @@ tcRnModule hsc_env hsc_src save_rn_decls -- and any other incrementally-performed imports updateEps_ (\eps -> eps { eps_is_boot = dep_mods }) ; + checkConflicts imports this_mod $ do { + -- Update the gbl env updGblEnv ( \ gbl -> gbl { tcg_rdr_env = rdr_env, @@ -241,23 +241,27 @@ tcRnModule hsc_env hsc_src save_rn_decls -- Dump output and return tcDump final_env ; return final_env - }}}} - --- This is really a sanity check that the user has given -package-name --- if necessary. -package-name is only necessary when the package database --- already contains the current package, because then we can't tell --- whether a given module is in the current package or not, without knowing --- the name of the current package. -checkForPackageModule dflags this_mod - | not (isHomeModule dflags this_mod), - Just (pkg,_) <- moduleToPackageConfig dflags this_mod = - let - ppr_pkg = ppr (mkPackageId (package pkg)) - in - addErr (ptext SLIT("Module") <+> quotes (ppr this_mod) <+> - ptext SLIT("is a member of package") <+> ppr_pkg <> char '.' $$ - ptext SLIT("To compile this module, please use -ignore-package") <+> ppr_pkg <> char '.') - | otherwise = return () + }}}}} + + +-- The program is not allowed to contain two modules with the same +-- name, and we check for that here. It could happen if the home package +-- contains a module that is also present in an external package, for example. +checkConflicts imports this_mod and_then = do + dflags <- getDOpts + let + dep_mods = this_mod : map fst (moduleEnvElts (imp_dep_mods imports)) + -- don't forget to include the current module! + + mb_dep_pkgs = checkForPackageConflicts + dflags dep_mods (imp_dep_pkgs imports) + -- + case mb_dep_pkgs of + Failed msg -> + do addErr msg; failM + Succeeded _ -> + updGblEnv (\gbl -> gbl{ tcg_home_mods = mkHomeModules dep_mods }) + and_then \end{code} @@ -316,6 +320,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) mg_usages = [], -- ToDo: compute usage mg_dir_imps = [], -- ?? mg_deps = noDependencies, -- ?? + mg_home_mods = mkHomeModules [], -- ?? wrong!! mg_exports = my_exports, mg_types = final_type_env, mg_insts = tcg_insts tcg_env, diff --git a/ghc/compiler/typecheck/TcRnMonad.lhs b/ghc/compiler/typecheck/TcRnMonad.lhs index 5fc329f..86b2fbe 100644 --- a/ghc/compiler/typecheck/TcRnMonad.lhs +++ b/ghc/compiler/typecheck/TcRnMonad.lhs @@ -12,7 +12,8 @@ import IOEnv -- Re-export all import HsSyn ( emptyLHsBinds ) import HscTypes ( HscEnv(..), ModGuts(..), ModIface(..), - TyThing, TypeEnv, emptyTypeEnv, HscSource(..), isHsBoot, + TyThing, TypeEnv, emptyTypeEnv, HscSource(..), + isHsBoot, ModSummary(..), ExternalPackageState(..), HomePackageTable, Deprecs(..), FixityEnv, FixItem, lookupType, unQualInScope ) @@ -29,6 +30,7 @@ import VarEnv ( TidyEnv, emptyTidyEnv, emptyVarEnv ) import ErrUtils ( Message, Messages, emptyMessages, errorsFound, mkWarnMsg, printErrorsAndWarnings, pprBagOfErrors, mkLocMessage, mkLongErrMsg ) +import Packages ( mkHomeModules ) import SrcLoc ( mkGeneralSrcSpan, isGoodSrcSpan, SrcSpan, Located(..) ) import NameEnv ( emptyNameEnv ) import NameSet ( NameSet, emptyDUs, emptyNameSet, unionNameSets, addOneToNameSet ) @@ -92,6 +94,7 @@ initTc hsc_env hsc_src mod do_this tcg_th_used = th_var, tcg_exports = emptyNameSet, tcg_imports = init_imports, + tcg_home_mods = home_mods, tcg_dus = emptyDUs, tcg_rn_decls = Nothing, tcg_binds = emptyLHsBinds, @@ -133,7 +136,17 @@ initTc hsc_env hsc_src mod do_this return (msgs, final_res) } where - init_imports = emptyImportAvails { imp_env = unitModuleEnv mod emptyNameSet } + home_mods = mkHomeModules (map ms_mod (hsc_mod_graph hsc_env)) + -- A guess at the home modules. This will be correct in + -- --make and GHCi modes, but in one-shot mode we need to + -- fix it up after we know the real dependencies of the current + -- module (see tcRnModule). + -- Setting it here is necessary for the typechecker entry points + -- other than tcRnModule: tcRnGetInfo, for example. These are + -- all called via the GHC module, so hsc_mod_graph will contain + -- something sensible. + + init_imports = emptyImportAvails {imp_env = unitModuleEnv mod emptyNameSet} -- Initialise tcg_imports with an empty set of bindings for -- this module, so that if we see 'module M' in the export -- list, and there are no bindings in M, we don't bleat diff --git a/ghc/compiler/typecheck/TcRnTypes.lhs b/ghc/compiler/typecheck/TcRnTypes.lhs index 308a884..c0cce28 100644 --- a/ghc/compiler/typecheck/TcRnTypes.lhs +++ b/ghc/compiler/typecheck/TcRnTypes.lhs @@ -47,7 +47,7 @@ import HscTypes ( FixityEnv, HscEnv, TypeEnv, TyThing, GenAvailInfo(..), AvailInfo, HscSource(..), availName, IsBootInterface, Deprecations ) -import Packages ( PackageId ) +import Packages ( PackageId, HomeModules ) import Type ( Type, TvSubstEnv, pprParendType, pprTyThingCategory ) import TcType ( TcTyVarSet, TcType, TcTauType, TcThetaType, SkolemInfo, TcPredType, TcKind, tcCmpPred, tcCmpType, tcCmpTypes, pprSkolInfo ) @@ -162,6 +162,10 @@ data TcGblEnv -- from where, including things bound -- in this module + tcg_home_mods :: HomeModules, + -- Calculated from ImportAvails, allows us to + -- call Packages.isHomeModule + tcg_dus :: DefUses, -- What is defined in this module and what is used. -- The latter is used to generate -- (a) version tracking; no need to recompile if these