diff options
27 files changed, 459 insertions, 336 deletions
diff --git a/ghc/compiler/cmm/CLabel.hs b/ghc/compiler/cmm/CLabel.hs index de6ca7adeb..296ad91ba8 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 3ae93ff6b1..e81d34c286 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 e4ca141c9e..f78edda655 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 58a43f489c..e7c08940c5 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 d94cbf03f6..bfb55bf46e 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 459f2c011f..33d72f1608 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 66bc6f5dcc..78a6f78053 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 4160580f92..4f95c9b36a 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 9932613b14..f76fcbdce3 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 67e5973327..b70bd26153 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 423f429ded..48c4ddeda8 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 1aa48656f5..1ea944c2c0 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 b70f8020d8..b1171041c8 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 3d71b89e9d..5c32a291fe 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 2b25bc552b..f8f51da55f 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("<unkonwn file>") - 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 dd8658175d..811f1cb034 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 98c0085c5c..29131b3f5a 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 d5727fe761..3f9338987f 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 240c132abd..1df4e0ff29 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 aac82f3945..0af2ca760a 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 8c6bcf9052..58c62e2de4 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 f43f24104d..e87877cb4c 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 75f6a94eec..f1c50cc8fd 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 8e586b0582..21466a8f2f 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 8e91367410..74484b0a18 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 5fc329f784..86b2fbeaa1 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 308a884915..c0cce28bcf 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 |