Commit 0c53bd0e authored by simonmar's avatar simonmar
Browse files

[project @ 2005-06-21 10:44:37 by simonmar]

Relax the restrictions on conflicting packages.  This should address
many of the traps that people have been falling into with the current
package story.

Now, a local module can shadow a module in an exposed package, as long
as the package is not otherwise required by the program.  GHC checks
for conflicts when it knows the dependencies of the module being
compiled.

Also, we now check for module conflicts in exposed packages only when
importing a module: if an import can be satisfied from multiple
packages, that's an error.  It's not possible to prevent GHC from
starting by installing packages now (unless you install another base
package).

It seems to be possible to confuse GHCi by having a local module
shadowing a package module that goes away and comes back again.  I
think it's nearly right, but strange happenings have been observed.

I'll try to merge this into the STABLE branch.
parent 93e2d5bd
......@@ -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
......
......@@ -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"
}
......@@ -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
......
%
% (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-}
......
......@@ -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
......
%
% (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}
......
%
% (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
......
%
% (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
......
%
% (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
......
......@@ -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)
-------------------------------------------------------------------------
--
......
......@@ -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
......
......@@ -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_inf