#include "HsVersions.h"
-import DynFlags ( DynFlags )
+import Packages ( HomeModules )
import StaticFlags ( opt_Static, opt_DoTickyProfiling )
import Packages ( isHomeModule, isDllName )
import DataCon ( ConTag )
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
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
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
import UniqFM
import SrcLoc
import DynFlags ( DynFlags, DynFlag(..) )
+import Packages ( HomeModules )
import StaticFlags ( opt_SccProfilingOn )
import ErrUtils ( printError, dumpIfSet_dyn, showPass )
import StringBuffer ( hGetStringBuffer )
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
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"
-
}
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
%
% (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 $
%
%********************************************************
%* *
-- 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-}
-> 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 ()
; 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
\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}
\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) }
\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
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
-- 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
%
% (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 $
%
%********************************************************
%* *
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
| 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
; 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:
\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
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
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
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}
%
% (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}
import CostCentre ( CostCentreStack )
import Util ( mapAccumL, filterOut )
import Constants ( wORD_SIZE )
-import DynFlags ( DynFlags )
+import Packages ( HomeModules )
import Outputable
-import GLAEXTS
-
\end{code}
\begin{code}
layOutDynConstr, layOutStaticConstr
- :: DynFlags
+ :: HomeModules
-> DataCon
-> [(CgRep,a)]
-> (ClosureInfo,
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
%
% (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}
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,
import {-# SOURCE #-} CgBindery ( CgBindings, nukeVolatileBinds )
-import DynFlags ( DynFlags )
+import DynFlags ( DynFlags )
+import Packages ( HomeModules )
import Cmm
import CmmUtils ( CmmStmts, isNopStmt )
import CLabel
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
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",
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
}
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
%
% (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 $
%
%********************************************************
%* *
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
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
--
-------------------------------------------------------------------------
-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)
-------------------------------------------------------------------------
--
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 )
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}
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]
| 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)
-- 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
| 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
cgIdInfoId )
import CgClosure ( cgTopRhsClosure )
import CgCon ( cgTopRhsCon, cgTyCon )
-import CgUtils ( cmmRegOffW, emitRODataLits, cmmNeWord, emitRtsCall )
+import CgUtils ( cmmRegOffW, emitRODataLits, cmmNeWord )
import CLabel
import Cmm
import StgSyn
import PrelNames ( gHC_PRIM, rOOT_MAIN, mAIN, pREL_TOP_HANDLER )
+import Packages ( HomeModules )
import DynFlags ( DynFlags(..), DynFlag(..), dopt )
import StaticFlags ( opt_SccProfilingOn )
\begin{code}
codeGen :: DynFlags
+ -> HomeModules
-> Module
-> [TyCon]
-> ForeignStubs
-> [(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"
-- 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])
\begin{code}
mkModuleInit
:: DynFlags
+ -> HomeModules
-> String -- the "way"
-> CollectedCCs -- cost centre info
-> Module
-> 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
(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) [])
-- Now do local stuff
; initCostCentres cost_centre_info
- ; mapCs (registerModuleImport dflags way)
+ ; mapCs (registerModuleImport hmods way)
(imported_mods++extra_imported_mods)
}
, 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}
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
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,
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,
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,
)
+import Packages ( HomeModules )
import DynFlags ( GhcMode(..), DynFlags(..), DynFlag(..), dopt )
import StaticFlags ( opt_HiVersion )
import Name ( Name, nameModule, nameOccName, nameParent,
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 })
-- 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
-----------------------------
-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
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
\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
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)
mkHomeModLocation, -- :: ModuleName -> FilePath -> IO ModLocation
mkHomeModLocation2, -- :: ModuleName -> FilePath -> String -> IO ModLocation
addHomeModuleToFinder, -- :: HscEnv -> Module -> ModLocation -> IO ()
+ uncacheModule, -- :: HscEnv -> Module -> IO ()
findObjectLinkableMaybe,
findObjectLinkable,
#include "HsVersions.h"
import Module
-import UniqFM ( filterUFM )
+import UniqFM ( filterUFM, delFromUFM )
import HscTypes
import Packages
import FastString
import System.Directory
import System.IO
import Control.Monad
-import Maybes ( MaybeErr(..) )
import Data.Maybe ( isNothing )
import Time ( ClockTime )
-- 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
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
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.
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
| 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
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
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
-- 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)
-> hang (ptext SLIT("locations searched:"))
2 (vcat (map text files))
- Found _ _ -> panic "cantFindErr"
+ _ -> panic "cantFindErr"
\end{code}
import GHC.Exts ( unsafeCoerce# )
#endif
-import Packages ( initPackages, isHomeModule )
+import Packages ( PackageIdH(..), initPackages )
import NameSet ( NameSet, nameSetToList, elemNameSet )
import RdrName ( GlobalRdrEnv, GlobalRdrElt(..), RdrName,
globalRdrEnvElts )
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 )
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
src_timestamp <- case maybe_buf of
Just (_,t) -> return t
Nothing -> getModificationTime file
+ -- getMofificationTime may fail
obj_timestamp <- modificationTimeIfExists (ml_obj_file location)
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
-- 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,
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
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
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
import CorePrep ( corePrepPgm )
import CoreToStg ( coreToStg )
import TyCon ( isDataTyCon )
+import Packages ( mkHomeModules )
import Name ( Name, NamedThing(..) )
import SimplStg ( stg2stg )
import CodeGen ( codeGen )
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 } ;
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)
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
}}
-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}
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,
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
= 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
}
PackageIdH(..), isHomePackage,
PackageState(..),
initPackages,
- moduleToPackageConfig,
getPackageDetails,
- isHomeModule,
+ checkForPackageConflicts,
+ lookupModuleInAllPackages,
+
+ HomeModules, mkHomeModules, isHomeModule,
-- * Inspecting the set of packages in scope
getPackageIncludePath,
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
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
#endif
import FastString
-import DATA_IOREF
import EXCEPTION ( throwDyn )
-import ErrUtils ( debugTraceMsg, putMsg )
+import ErrUtils ( debugTraceMsg, putMsg, Message )
-- ---------------------------------------------------------------------------
-- The Package state
-- 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.
-- 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).
= 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 =
-- 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!
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" <+>
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
-- -----------------------------------------------------------------------------
-- 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 =
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
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
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,
import StgSyn
-import DynFlags ( DynFlags )
+import Packages ( HomeModules )
import StaticFlags ( opt_AutoSccsOnIndividualCafs )
import CostCentre -- lots of things
import Id ( Id )
\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)
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
import StgStats ( showStgStats )
import SRT ( computeSRTs )
+import Packages ( HomeModules )
import DynFlags ( DynFlags(..), DynFlag(..), dopt, StgToDo(..),
getStgToDo )
import Id ( Id )
\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'
{-# 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
import Unique ( Unique )
import Bitmap
import DynFlags ( DynFlags )
+import Packages ( HomeModules )
import StaticFlags ( opt_SccProfilingOn )
\end{code}
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
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)
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,
#endif
import FastString ( mkFastString )
+import Maybes ( MaybeErr(..) )
import Util ( sortLe )
import Bag ( unionBags, snocBag, emptyBag, unitBag, unionManyBags )
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 ;
-- 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,
-- 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}
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,
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 )
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 )
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,
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
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 )
-- 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
projects / ghc-hetmet.git / commitdiff