diff options
Diffstat (limited to 'compiler/codeGen')
| -rw-r--r-- | compiler/codeGen/CgBindery.lhs | 4 | ||||
| -rw-r--r-- | compiler/codeGen/CgCase.lhs | 4 | ||||
| -rw-r--r-- | compiler/codeGen/CgCon.lhs | 26 | ||||
| -rw-r--r-- | compiler/codeGen/CgExpr.lhs | 20 | ||||
| -rw-r--r-- | compiler/codeGen/CgForeignCall.hs | 3 | ||||
| -rw-r--r-- | compiler/codeGen/CgHeapery.lhs | 8 | ||||
| -rw-r--r-- | compiler/codeGen/CgMonad.lhs | 22 | ||||
| -rw-r--r-- | compiler/codeGen/CgProf.hs | 2 | ||||
| -rw-r--r-- | compiler/codeGen/CgTailCall.lhs | 4 | ||||
| -rw-r--r-- | compiler/codeGen/CgUtils.hs | 12 | ||||
| -rw-r--r-- | compiler/codeGen/ClosureInfo.lhs | 48 | ||||
| -rw-r--r-- | compiler/codeGen/CodeGen.lhs | 55 |
12 files changed, 101 insertions, 107 deletions
diff --git a/compiler/codeGen/CgBindery.lhs b/compiler/codeGen/CgBindery.lhs index f78edda655..96735ef211 100644 --- a/compiler/codeGen/CgBindery.lhs +++ b/compiler/codeGen/CgBindery.lhs @@ -240,8 +240,8 @@ getCgIdInfo id name = idName id in if isExternalName name then do - hmods <- getHomeModules - let ext_lbl = CmmLit (CmmLabel (mkClosureLabel hmods name)) + this_pkg <- getThisPackage + let ext_lbl = CmmLit (CmmLabel (mkClosureLabel this_pkg name)) return (stableIdInfo id ext_lbl (mkLFImported id)) else if isVoidArg (idCgRep id) then diff --git a/compiler/codeGen/CgCase.lhs b/compiler/codeGen/CgCase.lhs index e7c08940c5..7b4861a11d 100644 --- a/compiler/codeGen/CgCase.lhs +++ b/compiler/codeGen/CgCase.lhs @@ -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 - ; hmods <- getHomeModules + ; this_pkg <- getThisPackage ; whenC (not (isDeadBinder bndr)) (do { tmp_reg <- bindNewToTemp bndr - ; stmtC (CmmAssign tmp_reg (tagToClosure hmods tycon tag_amode)) }) + ; stmtC (CmmAssign tmp_reg (tagToClosure this_pkg tycon tag_amode)) }) -- Compile the alts ; (branches, mb_deflt) <- cgAlgAlts NoGC Nothing{-cc_slot-} diff --git a/compiler/codeGen/CgCon.lhs b/compiler/codeGen/CgCon.lhs index 0d8d731029..115439a0fd 100644 --- a/compiler/codeGen/CgCon.lhs +++ b/compiler/codeGen/CgCon.lhs @@ -70,10 +70,10 @@ cgTopRhsCon :: Id -- Name of thing bound to this RHS -> FCode (Id, CgIdInfo) cgTopRhsCon id con args = do { - ; hmods <- getHomeModules + ; this_pkg <- getThisPackage #if mingw32_TARGET_OS -- Windows DLLs have a problem with static cross-DLL refs. - ; ASSERT( not (isDllConApp hmods con args) ) return () + ; ASSERT( not (isDllConApp this_pkg con args) ) return () #endif ; ASSERT( args `lengthIs` dataConRepArity con ) return () @@ -83,9 +83,9 @@ cgTopRhsCon id con args ; let name = idName id lf_info = mkConLFInfo con - closure_label = mkClosureLabel hmods name + closure_label = mkClosureLabel this_pkg name caffy = any stgArgHasCafRefs args - (closure_info, amodes_w_offsets) = layOutStaticConstr hmods con amodes + (closure_info, amodes_w_offsets) = layOutStaticConstr this_pkg con amodes closure_rep = mkStaticClosureFields closure_info dontCareCCS -- Because it's static data @@ -142,9 +142,9 @@ at all. \begin{code} buildDynCon binder cc con [] - = do hmods <- getHomeModules + = do this_pkg <- getThisPackage returnFC (stableIdInfo binder - (mkLblExpr (mkClosureLabel hmods (dataConName con))) + (mkLblExpr (mkClosureLabel this_pkg (dataConName con))) (mkConLFInfo con)) \end{code} @@ -198,9 +198,9 @@ Now the general case. \begin{code} buildDynCon binder ccs con args = do { - ; hmods <- getHomeModules + ; this_pkg <- getThisPackage ; let - (closure_info, amodes_w_offsets) = layOutDynConstr hmods con args + (closure_info, amodes_w_offsets) = layOutDynConstr this_pkg con args ; hp_off <- allocDynClosure closure_info use_cc blame_cc amodes_w_offsets ; returnFC (heapIdInfo binder hp_off lf_info) } @@ -230,10 +230,10 @@ found a $con$. \begin{code} bindConArgs :: DataCon -> [Id] -> Code bindConArgs con args - = do hmods <- getHomeModules + = do this_pkg <- getThisPackage let bind_arg (arg, offset) = bindNewToNode arg offset (mkLFArgument arg) - (_, args_w_offsets) = layOutDynConstr hmods con (addIdReps args) + (_, args_w_offsets) = layOutDynConstr this_pkg con (addIdReps args) -- ASSERT(not (isUnboxedTupleCon con)) return () mapCs bind_arg args_w_offsets @@ -416,7 +416,7 @@ static closure, for a constructor. cgDataCon :: DataCon -> Code cgDataCon data_con = do { -- Don't need any dynamic closure code for zero-arity constructors - hmods <- getHomeModules + this_pkg <- getThisPackage ; let -- To allow the debuggers, interpreters, etc to cope with @@ -424,10 +424,10 @@ cgDataCon data_con -- time), we take care that info-table contains the -- information we need. (static_cl_info, _) = - layOutStaticConstr hmods data_con arg_reps + layOutStaticConstr this_pkg data_con arg_reps (dyn_cl_info, arg_things) = - layOutDynConstr hmods data_con arg_reps + layOutDynConstr this_pkg data_con arg_reps emit_info cl_info ticky_code = do { code_blks <- getCgStmts the_code diff --git a/compiler/codeGen/CgExpr.lhs b/compiler/codeGen/CgExpr.lhs index 33d72f1608..e36b2ae236 100644 --- a/compiler/codeGen/CgExpr.lhs +++ b/compiler/codeGen/CgExpr.lhs @@ -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 - ; hmods <- getHomeModules - ; stmtC (CmmAssign nodeReg (tagToClosure hmods tycon amode')) + ; this_pkg <- getThisPackage + ; stmtC (CmmAssign nodeReg (tagToClosure this_pkg 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 - hmods <- getHomeModules + this_pkg <- getThisPackage cgPrimOp [tag_reg] primop args emptyVarSet - stmtC (CmmAssign nodeReg (tagToClosure hmods tycon (CmmReg tag_reg))) + stmtC (CmmAssign nodeReg (tagToClosure this_pkg 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 hmods <- getHomeModules - mkRhsClosure hmods name cc bi srt fvs upd_flag args body + = do this_pkg <- getThisPackage + mkRhsClosure this_pkg 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 hmods bndr cc bi srt +mkRhsClosure this_pkg bndr cc bi srt [the_fv] -- Just one free var upd_flag -- Updatable thunk [] -- A thunk @@ -328,7 +328,7 @@ mkRhsClosure hmods bndr cc bi srt where lf_info = mkSelectorLFInfo bndr offset_into_int (isUpdatable upd_flag) - (_, params_w_offsets) = layOutDynConstr hmods con (addIdReps params) + (_, params_w_offsets) = layOutDynConstr this_pkg 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 hmods bndr cc bi srt +mkRhsClosure this_pkg bndr cc bi srt fvs upd_flag [] -- No args; a thunk @@ -377,7 +377,7 @@ mkRhsClosure hmods bndr cc bi srt The default case ~~~~~~~~~~~~~~~~ \begin{code} -mkRhsClosure hmods bndr cc bi srt fvs upd_flag args body +mkRhsClosure this_pkg bndr cc bi srt fvs upd_flag args body = cgRhsClosure bndr cc bi srt fvs upd_flag args body \end{code} diff --git a/compiler/codeGen/CgForeignCall.hs b/compiler/codeGen/CgForeignCall.hs index 10f41bdf8b..e66e1b8ead 100644 --- a/compiler/codeGen/CgForeignCall.hs +++ b/compiler/codeGen/CgForeignCall.hs @@ -23,8 +23,7 @@ import StgSyn ( StgLiveVars, StgArg, stgArgType ) import CgProf ( curCCS, curCCSAddr ) import CgBindery ( getVolatileRegs, getArgAmodes ) import CgMonad -import CgUtils ( cmmOffsetW, cmmOffsetB, cmmLoadIndexW, newTemp, - assignTemp ) +import CgUtils ( cmmOffsetW, cmmOffsetB, newTemp ) import Type ( tyConAppTyCon, repType ) import TysPrim import CLabel ( mkForeignLabel, mkRtsCodeLabel ) diff --git a/compiler/codeGen/CgHeapery.lhs b/compiler/codeGen/CgHeapery.lhs index 184af904df..ae6c892b5d 100644 --- a/compiler/codeGen/CgHeapery.lhs +++ b/compiler/codeGen/CgHeapery.lhs @@ -53,7 +53,7 @@ import TyCon ( tyConPrimRep ) import CostCentre ( CostCentreStack ) import Util ( mapAccumL, filterOut ) import Constants ( wORD_SIZE ) -import Packages ( HomeModules ) +import PackageConfig ( PackageId ) import Outputable \end{code} @@ -123,7 +123,7 @@ getHpRelOffset virtual_offset \begin{code} layOutDynConstr, layOutStaticConstr - :: HomeModules + :: PackageId -> DataCon -> [(CgRep,a)] -> (ClosureInfo, @@ -132,8 +132,8 @@ layOutDynConstr, layOutStaticConstr layOutDynConstr = layOutConstr False layOutStaticConstr = layOutConstr True -layOutConstr is_static hmods data_con args - = (mkConInfo hmods is_static data_con tot_wds ptr_wds, +layOutConstr is_static this_pkg data_con args + = (mkConInfo this_pkg is_static data_con tot_wds ptr_wds, things_w_offsets) where (tot_wds, -- #ptr_wds + #nonptr_wds diff --git a/compiler/codeGen/CgMonad.lhs b/compiler/codeGen/CgMonad.lhs index 22462e79e5..1866df4cef 100644 --- a/compiler/codeGen/CgMonad.lhs +++ b/compiler/codeGen/CgMonad.lhs @@ -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, getHomeModules, + getState, setState, getInfoDown, getDynFlags, getThisPackage, -- more localised access to monad state getStkUsage, setStkUsage, @@ -61,8 +61,8 @@ module CgMonad ( import {-# SOURCE #-} CgBindery ( CgBindings, nukeVolatileBinds ) -import DynFlags ( DynFlags ) -import Packages ( HomeModules ) +import DynFlags ( DynFlags(..) ) +import PackageConfig ( PackageId ) import Cmm import CmmUtils ( CmmStmts, isNopStmt ) import CLabel @@ -97,7 +97,6 @@ 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 @@ -105,10 +104,9 @@ data CgInfoDownwards -- information only passed *downwards* by the monad cgd_eob :: EndOfBlockInfo -- Info for stuff to do at end of basic block: } -initCgInfoDown :: DynFlags -> HomeModules -> Module -> CgInfoDownwards -initCgInfoDown dflags hmods mod +initCgInfoDown :: DynFlags -> Module -> CgInfoDownwards +initCgInfoDown dflags mod = MkCgInfoDown { cgd_dflags = dflags, - cgd_hmods = hmods, cgd_mod = mod, cgd_statics = emptyVarEnv, cgd_srt = error "initC: srt", @@ -378,11 +376,11 @@ instance Monad FCode where The Abstract~C is not in the environment so as to improve strictness. \begin{code} -initC :: DynFlags -> HomeModules -> Module -> FCode a -> IO a +initC :: DynFlags -> Module -> FCode a -> IO a -initC dflags hmods mod (FCode code) +initC dflags mod (FCode code) = do { uniqs <- mkSplitUniqSupply 'c' - ; case code (initCgInfoDown dflags hmods mod) (initCgState uniqs) of + ; case code (initCgInfoDown dflags mod) (initCgState uniqs) of (res, _) -> return res } @@ -510,8 +508,8 @@ getInfoDown = FCode $ \info_down state -> (info_down,state) getDynFlags :: FCode DynFlags getDynFlags = liftM cgd_dflags getInfoDown -getHomeModules :: FCode HomeModules -getHomeModules = liftM cgd_hmods getInfoDown +getThisPackage :: FCode PackageId +getThisPackage = liftM thisPackage getDynFlags withInfoDown :: FCode a -> CgInfoDownwards -> FCode a withInfoDown (FCode fcode) info_down = FCode $ \_ state -> fcode info_down state diff --git a/compiler/codeGen/CgProf.hs b/compiler/codeGen/CgProf.hs index eee1083fca..9bbf05b90c 100644 --- a/compiler/codeGen/CgProf.hs +++ b/compiler/codeGen/CgProf.hs @@ -292,7 +292,7 @@ emitCostCentreDecl -> Code emitCostCentreDecl cc = do { label <- mkStringCLit (costCentreUserName cc) - ; modl <- mkStringCLit (moduleString (cc_mod cc)) + ; modl <- mkStringCLit (showSDoc (pprModule (cc_mod cc))) ; let lits = [ zero, -- StgInt ccID, label, -- char *label, diff --git a/compiler/codeGen/CgTailCall.lhs b/compiler/codeGen/CgTailCall.lhs index dd7327b745..56614a87f3 100644 --- a/compiler/codeGen/CgTailCall.lhs +++ b/compiler/codeGen/CgTailCall.lhs @@ -118,9 +118,9 @@ performTailCall fun_info arg_amodes pending_assts opt_node_asst | nodeMustPointToIt lf_info = node_asst | otherwise = noStmts ; EndOfBlockInfo sp _ <- getEndOfBlockInfo - ; hmods <- getHomeModules + ; this_pkg <- getThisPackage - ; case (getCallMethod hmods fun_name lf_info (length arg_amodes)) of + ; case (getCallMethod this_pkg fun_name lf_info (length arg_amodes)) of -- Node must always point to things we enter EnterIt -> do diff --git a/compiler/codeGen/CgUtils.hs b/compiler/codeGen/CgUtils.hs index 2f69927db0..21e6d0850c 100644 --- a/compiler/codeGen/CgUtils.hs +++ b/compiler/codeGen/CgUtils.hs @@ -48,13 +48,12 @@ import MachOp ( MachRep(..), wordRep, MachOp(..), MachHint(..), mo_wordULt, mo_wordUGt, mo_wordUGe, machRepByteWidth ) import ForeignCall ( CCallConv(..) ) import Literal ( Literal(..) ) -import CLabel ( CLabel, mkStringLitLabel ) import Digraph ( SCC(..), stronglyConnComp ) import ListSetOps ( assocDefault ) import Util ( filterOut, sortLe ) import DynFlags ( DynFlags(..), HscTarget(..) ) -import Packages ( HomeModules ) -import FastString ( LitString, FastString, bytesFS ) +import FastString ( LitString, bytesFS ) +import PackageConfig ( PackageId ) import Outputable import Char ( ord ) @@ -213,11 +212,11 @@ addToMemE rep ptr n -- ------------------------------------------------------------------------- -tagToClosure :: HomeModules -> TyCon -> CmmExpr -> CmmExpr -tagToClosure hmods tycon tag +tagToClosure :: PackageId -> TyCon -> CmmExpr -> CmmExpr +tagToClosure this_pkg tycon tag = CmmLoad (cmmOffsetExprW closure_tbl tag) wordRep where closure_tbl = CmmLit (CmmLabel lbl) - lbl = mkClosureTableLabel hmods (tyConName tycon) + lbl = mkClosureTableLabel this_pkg (tyConName tycon) ------------------------------------------------------------------------- -- @@ -488,7 +487,6 @@ mk_switch tag_expr branches mb_deflt lo_tag hi_tag via_C -- a 2-branch switch always turns into an if. small = n_tags <= 4 dense = n_branches > (n_tags `div` 2) - exhaustive = n_tags == n_branches n_branches = length branches -- ignore default slots at each end of the range if there's diff --git a/compiler/codeGen/ClosureInfo.lhs b/compiler/codeGen/ClosureInfo.lhs index 84d9dd95ef..d137d4d3ca 100644 --- a/compiler/codeGen/ClosureInfo.lhs +++ b/compiler/codeGen/ClosureInfo.lhs @@ -61,8 +61,8 @@ import SMRep -- all of it import CLabel -import Constants ( mIN_PAYLOAD_SIZE ) -import Packages ( isDllName, HomeModules ) +import Packages ( isDllName ) +import PackageConfig ( PackageId ) import StaticFlags ( opt_SccProfilingOn, opt_OmitBlackHoling, opt_Parallel, opt_DoTickyProfiling ) import Id ( Id, idType, idArity, idName ) @@ -330,15 +330,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 :: HomeModules +mkConInfo :: PackageId -> Bool -- Is static -> DataCon -> Int -> Int -- Total and pointer words -> ClosureInfo -mkConInfo hmods is_static data_con tot_wds ptr_wds +mkConInfo this_pkg is_static data_con tot_wds ptr_wds = ConInfo { closureSMRep = sm_rep, closureCon = data_con, - closureDllCon = isDllName hmods (dataConName data_con) } + closureDllCon = isDllName this_pkg (dataConName data_con) } where sm_rep = chooseSMRep is_static (mkConLFInfo data_con) tot_wds ptr_wds \end{code} @@ -560,30 +560,30 @@ data CallMethod CLabel -- The code label Int -- Its arity -getCallMethod :: HomeModules +getCallMethod :: PackageId -> Name -- Function being applied -> LambdaFormInfo -- Its info -> Int -- Number of available arguments -> CallMethod -getCallMethod hmods name lf_info n_args +getCallMethod this_pkg 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 hmods name (LFReEntrant _ arity _ _) n_args +getCallMethod this_pkg 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 hmods name) arity + | otherwise = DirectEntry (enterIdLabel this_pkg name) arity -getCallMethod hmods name (LFCon con) n_args +getCallMethod this_pkg name (LFCon con) n_args = ASSERT( n_args == 0 ) ReturnCon con -getCallMethod hmods name (LFThunk _ _ updatable std_form_info is_fun) n_args +getCallMethod this_pkg 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] @@ -598,24 +598,24 @@ getCallMethod hmods 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 hmods name std_form_info updatable) + JumpToIt (thunkEntryLabel this_pkg name std_form_info updatable) -getCallMethod hmods name (LFUnknown True) n_args +getCallMethod this_pkg name (LFUnknown True) n_args = SlowCall -- might be a function -getCallMethod hmods name (LFUnknown False) n_args +getCallMethod this_pkg name (LFUnknown False) n_args = ASSERT2 ( n_args == 0, ppr name <+> ppr n_args ) EnterIt -- Not a function -getCallMethod hmods name (LFBlackHole _) n_args +getCallMethod this_pkg 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 hmods name (LFLetNoEscape 0) n_args +getCallMethod this_pkg name (LFLetNoEscape 0) n_args = JumpToIt (enterReturnPtLabel (nameUnique name)) -getCallMethod hmods name (LFLetNoEscape arity) n_args +getCallMethod this_pkg name (LFLetNoEscape arity) n_args | n_args == arity = DirectEntry (enterReturnPtLabel (nameUnique name)) arity | otherwise = pprPanic "let-no-escape: " (ppr name <+> ppr arity) @@ -845,12 +845,12 @@ closureLabelFromCI _ = panic "closureLabelFromCI" -- thunkEntryLabel is a local help function, not exported. It's used from both -- entryLabelFromCI and getCallMethod. -thunkEntryLabel hmods thunk_id (ApThunk arity) is_updatable +thunkEntryLabel this_pkg thunk_id (ApThunk arity) is_updatable = enterApLabel is_updatable arity -thunkEntryLabel hmods thunk_id (SelectorThunk offset) upd_flag +thunkEntryLabel this_pkg thunk_id (SelectorThunk offset) upd_flag = enterSelectorLabel upd_flag offset -thunkEntryLabel hmods thunk_id _ is_updatable - = enterIdLabel hmods thunk_id +thunkEntryLabel this_pkg thunk_id _ is_updatable + = enterIdLabel this_pkg thunk_id enterApLabel is_updatable arity | tablesNextToCode = mkApInfoTableLabel is_updatable arity @@ -860,9 +860,9 @@ enterSelectorLabel upd_flag offset | tablesNextToCode = mkSelectorInfoLabel upd_flag offset | otherwise = mkSelectorEntryLabel upd_flag offset -enterIdLabel hmods id - | tablesNextToCode = mkInfoTableLabel hmods id - | otherwise = mkEntryLabel hmods id +enterIdLabel this_pkg id + | tablesNextToCode = mkInfoTableLabel this_pkg id + | otherwise = mkEntryLabel this_pkg id enterLocalIdLabel id | tablesNextToCode = mkLocalInfoTableLabel id diff --git a/compiler/codeGen/CodeGen.lhs b/compiler/codeGen/CodeGen.lhs index 48c0cbfbb9..0422a875e1 100644 --- a/compiler/codeGen/CodeGen.lhs +++ b/compiler/codeGen/CodeGen.lhs @@ -38,11 +38,11 @@ import PprCmm ( pprCmms ) import MachOp ( wordRep ) import StgSyn -import PrelNames ( gHC_PRIM, rOOT_MAIN, pREL_TOP_HANDLER ) -import Packages ( HomeModules ) +import PrelNames ( gHC_PRIM, rOOT_MAIN, gHC_TOP_HANDLER ) import DynFlags ( DynFlags(..), DynFlag(..), dopt ) import StaticFlags ( opt_SccProfilingOn ) +import PackageConfig ( PackageId ) import HscTypes ( ForeignStubs(..) ) import CostCentre ( CollectedCCs ) import Id ( Id, idName, setIdName ) @@ -51,16 +51,14 @@ import OccName ( mkLocalOcc ) import TyCon ( TyCon ) import Module ( Module ) import ErrUtils ( dumpIfSet_dyn, showPass ) -import Panic ( assertPanic ) #ifdef DEBUG -import Outputable +import Panic ( assertPanic ) #endif \end{code} \begin{code} codeGen :: DynFlags - -> HomeModules -> Module -> [TyCon] -> ForeignStubs @@ -69,7 +67,7 @@ codeGen :: DynFlags -> [(StgBinding,[(Id,[Id])])] -- Bindings to convert, with SRTs -> IO [Cmm] -- Output -codeGen dflags hmods this_mod data_tycons foreign_stubs imported_mods +codeGen dflags this_mod data_tycons foreign_stubs imported_mods cost_centre_info stg_binds = do { showPass dflags "CodeGen" @@ -79,10 +77,10 @@ codeGen dflags hmods this_mod data_tycons foreign_stubs imported_mods -- Why? -- ; mapM_ (\x -> seq x (return ())) data_tycons - ; code_stuff <- initC dflags hmods this_mod $ do - { cmm_binds <- mapM (getCmm . cgTopBinding dflags hmods) stg_binds + ; code_stuff <- initC dflags this_mod $ do + { cmm_binds <- mapM (getCmm . cgTopBinding dflags) stg_binds ; cmm_tycons <- mapM cgTyCon data_tycons - ; cmm_init <- getCmm (mkModuleInit dflags hmods way cost_centre_info + ; cmm_init <- getCmm (mkModuleInit dflags way cost_centre_info this_mod main_mod foreign_stubs imported_mods) ; return (cmm_binds ++ concat cmm_tycons ++ [cmm_init]) @@ -143,7 +141,6 @@ We initialise the module tree by keeping a work-stack, \begin{code} mkModuleInit :: DynFlags - -> HomeModules -> String -- the "way" -> CollectedCCs -- cost centre info -> Module @@ -151,7 +148,7 @@ mkModuleInit -> ForeignStubs -> [Module] -> Code -mkModuleInit dflags hmods way cost_centre_info this_mod main_mod foreign_stubs imported_mods +mkModuleInit dflags way cost_centre_info this_mod main_mod foreign_stubs imported_mods = do { if opt_SccProfilingOn then do { -- Allocate the static boolean that records if this @@ -184,9 +181,11 @@ mkModuleInit dflags hmods way cost_centre_info this_mod main_mod foreign_stubs i (emitSimpleProc plain_main_init_lbl jump_to_init) } where - plain_init_lbl = mkPlainModuleInitLabel hmods this_mod - real_init_lbl = mkModuleInitLabel hmods this_mod way - plain_main_init_lbl = mkPlainModuleInitLabel hmods rOOT_MAIN + this_pkg = thisPackage dflags + + plain_init_lbl = mkPlainModuleInitLabel this_pkg this_mod + real_init_lbl = mkModuleInitLabel this_pkg this_mod way + plain_main_init_lbl = mkPlainModuleInitLabel this_pkg rOOT_MAIN jump_to_init = stmtC (CmmJump (mkLblExpr real_init_lbl) []) @@ -195,7 +194,7 @@ mkModuleInit dflags hmods way cost_centre_info this_mod main_mod foreign_stubs i -- Main refers to GHC.TopHandler.runIO, so make sure we call the -- init function for GHC.TopHandler. extra_imported_mods - | this_mod == main_mod = [pREL_TOP_HANDLER] + | this_mod == main_mod = [gHC_TOP_HANDLER] | otherwise = [] mod_init_code = do @@ -204,7 +203,7 @@ mkModuleInit dflags hmods way cost_centre_info this_mod main_mod foreign_stubs i -- Now do local stuff ; initCostCentres cost_centre_info - ; mapCs (registerModuleImport hmods way) + ; mapCs (registerModuleImport this_pkg way) (imported_mods++extra_imported_mods) } @@ -214,13 +213,13 @@ mkModuleInit dflags hmods way cost_centre_info this_mod main_mod foreign_stubs i , CmmJump (CmmLoad (cmmRegOffW spReg (-1)) wordRep) [] ] ----------------------- -registerModuleImport :: HomeModules -> String -> Module -> Code -registerModuleImport hmods way mod +registerModuleImport :: PackageId -> String -> Module -> Code +registerModuleImport this_pkg 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 hmods mod way)) ] + , CmmStore (CmmReg spReg) (mkLblExpr (mkModuleInitLabel this_pkg mod way)) ] \end{code} @@ -261,32 +260,32 @@ style, with the increasing static environment being plumbed as a state variable. \begin{code} -cgTopBinding :: DynFlags -> HomeModules -> (StgBinding,[(Id,[Id])]) -> Code -cgTopBinding dflags hmods (StgNonRec id rhs, srts) +cgTopBinding :: DynFlags -> (StgBinding,[(Id,[Id])]) -> Code +cgTopBinding dflags (StgNonRec id rhs, srts) = do { id' <- maybeExternaliseId dflags id - ; mapM_ (mkSRT hmods [id']) srts + ; mapM_ (mkSRT (thisPackage dflags) [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 hmods (StgRec pairs, srts) +cgTopBinding dflags (StgRec pairs, srts) = do { let (bndrs, rhss) = unzip pairs ; bndrs' <- mapFCs (maybeExternaliseId dflags) bndrs ; let pairs' = zip bndrs' rhss - ; mapM_ (mkSRT hmods bndrs') srts + ; mapM_ (mkSRT (thisPackage dflags) bndrs') srts ; _new_binds <- fixC (\ new_binds -> do { addBindsC new_binds ; mapFCs ( \ (b,e) -> cgTopRhs b e ) pairs' }) ; nopC } -mkSRT :: HomeModules -> [Id] -> (Id,[Id]) -> Code -mkSRT hmods these (id,[]) = nopC -mkSRT hmods these (id,ids) +mkSRT :: PackageId -> [Id] -> (Id,[Id]) -> Code +mkSRT this_pkg these (id,[]) = nopC +mkSRT this_pkg these (id,ids) = do { ids <- mapFCs remap ids ; id <- remap id ; emitRODataLits (mkSRTLabel (idName id)) - (map (CmmLabel . mkClosureLabel hmods . idName) ids) + (map (CmmLabel . mkClosureLabel this_pkg . idName) ids) } where -- Sigh, better map all the ids against the environment in |