diff options
Diffstat (limited to 'compiler/codeGen')
| -rw-r--r-- | compiler/codeGen/CgBindery.lhs | 3 | ||||
| -rw-r--r-- | compiler/codeGen/CgCase.lhs | 2 | ||||
| -rw-r--r-- | compiler/codeGen/CgCon.lhs | 23 | ||||
| -rw-r--r-- | compiler/codeGen/CgExpr.lhs | 17 | ||||
| -rw-r--r-- | compiler/codeGen/CgHeapery.lhs | 7 | ||||
| -rw-r--r-- | compiler/codeGen/CgTailCall.lhs | 2 | ||||
| -rw-r--r-- | compiler/codeGen/CgUtils.hs | 6 | ||||
| -rw-r--r-- | compiler/codeGen/ClosureInfo.lhs | 57 | ||||
| -rw-r--r-- | compiler/codeGen/CodeGen.lhs | 35 |
9 files changed, 68 insertions, 84 deletions
diff --git a/compiler/codeGen/CgBindery.lhs b/compiler/codeGen/CgBindery.lhs index 7447222d45..0306867d71 100644 --- a/compiler/codeGen/CgBindery.lhs +++ b/compiler/codeGen/CgBindery.lhs @@ -280,8 +280,7 @@ getCgIdInfo id name = idName id in if isExternalName name then do - this_pkg <- getThisPackage - let ext_lbl = CmmLit (CmmLabel (mkClosureLabel this_pkg name)) + let ext_lbl = CmmLit (CmmLabel (mkClosureLabel 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 11a3c3e1d8..149b8560ce 100644 --- a/compiler/codeGen/CgCase.lhs +++ b/compiler/codeGen/CgCase.lhs @@ -316,7 +316,7 @@ cgInlinePrimOp primop args bndr (AlgAlt tycon) live_in_alts alts (do { tmp_reg <- bindNewToTemp bndr ; stmtC (CmmAssign (CmmLocal tmp_reg) - (tagToClosure this_pkg tycon tag_amode)) }) + (tagToClosure 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 91d7098f3e..ae2c259fd1 100644 --- a/compiler/codeGen/CgCon.lhs +++ b/compiler/codeGen/CgCon.lhs @@ -63,9 +63,9 @@ cgTopRhsCon :: Id -- Name of thing bound to this RHS -> FCode (Id, CgIdInfo) cgTopRhsCon id con args = do { - ; this_pkg <- getThisPackage #if mingw32_TARGET_OS -- Windows DLLs have a problem with static cross-DLL refs. + ; this_pkg <- getThisPackage ; ASSERT( not (isDllConApp this_pkg con args) ) return () #endif ; ASSERT( args `lengthIs` dataConRepArity con ) return () @@ -76,9 +76,9 @@ cgTopRhsCon id con args ; let name = idName id lf_info = mkConLFInfo con - closure_label = mkClosureLabel this_pkg name + closure_label = mkClosureLabel name caffy = any stgArgHasCafRefs args - (closure_info, amodes_w_offsets) = layOutStaticConstr this_pkg con amodes + (closure_info, amodes_w_offsets) = layOutStaticConstr con amodes closure_rep = mkStaticClosureFields closure_info dontCareCCS -- Because it's static data @@ -135,9 +135,8 @@ at all. \begin{code} buildDynCon binder cc con [] - = do this_pkg <- getThisPackage - returnFC (taggedStableIdInfo binder - (mkLblExpr (mkClosureLabel this_pkg (dataConName con))) + = returnFC (taggedStableIdInfo binder + (mkLblExpr (mkClosureLabel (dataConName con))) (mkConLFInfo con) con) \end{code} @@ -192,9 +191,8 @@ Now the general case. \begin{code} buildDynCon binder ccs con args = do { - ; this_pkg <- getThisPackage ; let - (closure_info, amodes_w_offsets) = layOutDynConstr this_pkg con args + (closure_info, amodes_w_offsets) = layOutDynConstr con args ; hp_off <- allocDynClosure closure_info use_cc blame_cc amodes_w_offsets ; returnFC (taggedHeapIdInfo binder hp_off lf_info con) } @@ -224,12 +222,12 @@ found a $con$. \begin{code} bindConArgs :: DataCon -> [Id] -> Code bindConArgs con args - = do this_pkg <- getThisPackage + = do let -- The binding below forces the masking out of the tag bits -- when accessing the constructor field. bind_arg (arg, offset) = bindNewToUntagNode arg offset (mkLFArgument arg) (tagForCon con) - (_, args_w_offsets) = layOutDynConstr this_pkg con (addIdReps args) + (_, args_w_offsets) = layOutDynConstr con (addIdReps args) -- ASSERT(not (isUnboxedTupleCon con)) return () mapCs bind_arg args_w_offsets @@ -413,7 +411,6 @@ static closure, for a constructor. cgDataCon :: DataCon -> Code cgDataCon data_con = do { -- Don't need any dynamic closure code for zero-arity constructors - this_pkg <- getThisPackage ; let -- To allow the debuggers, interpreters, etc to cope with @@ -421,10 +418,10 @@ cgDataCon data_con -- time), we take care that info-table contains the -- information we need. (static_cl_info, _) = - layOutStaticConstr this_pkg data_con arg_reps + layOutStaticConstr data_con arg_reps (dyn_cl_info, arg_things) = - layOutDynConstr this_pkg data_con arg_reps + layOutDynConstr 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 a71493a28b..b243e21eeb 100644 --- a/compiler/codeGen/CgExpr.lhs +++ b/compiler/codeGen/CgExpr.lhs @@ -146,8 +146,7 @@ cgExpr (StgOpApp (StgPrimOp TagToEnumOp) [arg] res_ty) else assignNonPtrTemp amode -- We're going to use it twice, -- so save in a temp if non-trivial - ; this_pkg <- getThisPackage - ; stmtC (CmmAssign nodeReg (tagToClosure this_pkg tycon amode')) + ; stmtC (CmmAssign nodeReg (tagToClosure tycon amode')) ; performReturn emitReturnInstr } where -- If you're reading this code in the attempt to figure @@ -183,10 +182,9 @@ cgExpr x@(StgOpApp op@(StgPrimOp primop) args res_ty) = do tag_reg <- if isFollowableArg (typeCgRep res_ty) then newPtrTemp wordRep else newNonPtrTemp wordRep - this_pkg <- getThisPackage cgPrimOp [tag_reg] primop args emptyVarSet stmtC (CmmAssign nodeReg - (tagToClosure this_pkg tycon + (tagToClosure tycon (CmmReg (CmmLocal tag_reg)))) performReturn emitReturnInstr where @@ -292,8 +290,7 @@ cgRhs name (StgRhsCon maybe_cc con args) ; returnFC (name, idinfo) } cgRhs name (StgRhsClosure cc bi fvs upd_flag srt args body) - = do this_pkg <- getThisPackage - setSRT srt $ mkRhsClosure this_pkg name cc bi fvs upd_flag args body + = setSRT srt $ mkRhsClosure name cc bi fvs upd_flag args body \end{code} mkRhsClosure looks for two special forms of the right-hand side: @@ -316,7 +313,7 @@ form: \begin{code} -mkRhsClosure this_pkg bndr cc bi +mkRhsClosure bndr cc bi [the_fv] -- Just one free var upd_flag -- Updatable thunk [] -- A thunk @@ -338,7 +335,7 @@ mkRhsClosure this_pkg bndr cc bi where lf_info = mkSelectorLFInfo bndr offset_into_int (isUpdatable upd_flag) - (_, params_w_offsets) = layOutDynConstr this_pkg con (addIdReps params) + (_, params_w_offsets) = layOutDynConstr con (addIdReps params) -- Just want the layout maybe_offset = assocMaybe params_w_offsets selectee Just the_offset = maybe_offset @@ -362,7 +359,7 @@ We only generate an Ap thunk if all the free variables are pointers, for semi-obvious reasons. \begin{code} -mkRhsClosure this_pkg bndr cc bi +mkRhsClosure bndr cc bi fvs upd_flag [] -- No args; a thunk @@ -387,7 +384,7 @@ mkRhsClosure this_pkg bndr cc bi The default case ~~~~~~~~~~~~~~~~ \begin{code} -mkRhsClosure this_pkg bndr cc bi fvs upd_flag args body +mkRhsClosure bndr cc bi fvs upd_flag args body = cgRhsClosure bndr cc bi fvs upd_flag args body \end{code} diff --git a/compiler/codeGen/CgHeapery.lhs b/compiler/codeGen/CgHeapery.lhs index b89452e1de..dfa49ebb47 100644 --- a/compiler/codeGen/CgHeapery.lhs +++ b/compiler/codeGen/CgHeapery.lhs @@ -114,8 +114,7 @@ getHpRelOffset virtual_offset \begin{code} layOutDynConstr, layOutStaticConstr - :: PackageId - -> DataCon + :: DataCon -> [(CgRep,a)] -> (ClosureInfo, [(a,VirtualHpOffset)]) @@ -123,8 +122,8 @@ layOutDynConstr, layOutStaticConstr layOutDynConstr = layOutConstr False layOutStaticConstr = layOutConstr True -layOutConstr is_static this_pkg data_con args - = (mkConInfo this_pkg is_static data_con tot_wds ptr_wds, +layOutConstr is_static data_con args + = (mkConInfo is_static data_con tot_wds ptr_wds, things_w_offsets) where (tot_wds, -- #ptr_wds + #nonptr_wds diff --git a/compiler/codeGen/CgTailCall.lhs b/compiler/codeGen/CgTailCall.lhs index 952702674f..e25e794d58 100644 --- a/compiler/codeGen/CgTailCall.lhs +++ b/compiler/codeGen/CgTailCall.lhs @@ -110,7 +110,7 @@ performTailCall fun_info arg_amodes pending_assts ; EndOfBlockInfo sp _ <- getEndOfBlockInfo ; this_pkg <- getThisPackage - ; case (getCallMethod this_pkg fun_name lf_info (length arg_amodes)) of + ; case (getCallMethod 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 8d3578e1ef..19f5eabb2f 100644 --- a/compiler/codeGen/CgUtils.hs +++ b/compiler/codeGen/CgUtils.hs @@ -281,11 +281,11 @@ addToMemE rep ptr n -- ------------------------------------------------------------------------- -tagToClosure :: PackageId -> TyCon -> CmmExpr -> CmmExpr -tagToClosure this_pkg tycon tag +tagToClosure :: TyCon -> CmmExpr -> CmmExpr +tagToClosure tycon tag = CmmLoad (cmmOffsetExprW closure_tbl tag) wordRep where closure_tbl = CmmLit (CmmLabel lbl) - lbl = mkClosureTableLabel this_pkg (tyConName tycon) + lbl = mkClosureTableLabel (tyConName tycon) ------------------------------------------------------------------------- -- diff --git a/compiler/codeGen/ClosureInfo.lhs b/compiler/codeGen/ClosureInfo.lhs index d537a7b3d9..6ff2d5f947 100644 --- a/compiler/codeGen/ClosureInfo.lhs +++ b/compiler/codeGen/ClosureInfo.lhs @@ -117,8 +117,7 @@ data ClosureInfo -- the constructor's info table), and they don't have an SRT. | ConInfo { closureCon :: !DataCon, - closureSMRep :: !SMRep, - closureDllCon :: !Bool -- is in a separate DLL + closureSMRep :: !SMRep } -- C_SRT is what StgSyn.SRT gets translated to... @@ -341,15 +340,13 @@ 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 :: PackageId - -> Bool -- Is static +mkConInfo :: Bool -- Is static -> DataCon -> Int -> Int -- Total and pointer words -> ClosureInfo -mkConInfo this_pkg is_static data_con tot_wds ptr_wds +mkConInfo is_static data_con tot_wds ptr_wds = ConInfo { closureSMRep = sm_rep, - closureCon = data_con, - closureDllCon = isDllName this_pkg (dataConName data_con) } + closureCon = data_con } where sm_rep = chooseSMRep is_static (mkConLFInfo data_con) tot_wds ptr_wds \end{code} @@ -571,30 +568,29 @@ data CallMethod CLabel -- The code label Int -- Its arity -getCallMethod :: PackageId - -> Name -- Function being applied +getCallMethod :: Name -- Function being applied -> LambdaFormInfo -- Its info -> Int -- Number of available arguments -> CallMethod -getCallMethod this_pkg name lf_info n_args +getCallMethod 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 this_pkg name (LFReEntrant _ arity _ _) n_args +getCallMethod 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 this_pkg name) arity + | otherwise = DirectEntry (enterIdLabel name) arity -getCallMethod this_pkg name (LFCon con) n_args +getCallMethod name (LFCon con) n_args = ASSERT( n_args == 0 ) ReturnCon con -getCallMethod this_pkg name (LFThunk _ _ updatable std_form_info is_fun) n_args +getCallMethod name (LFThunk _ _ updatable std_form_info is_fun) n_args | is_fun -- *Might* be a function, so we must "call" it (which is always safe) = SlowCall -- We cannot just enter it [in eval/apply, the entry code -- is the fast-entry code] @@ -616,24 +612,24 @@ getCallMethod this_pkg 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 this_pkg name std_form_info updatable) + JumpToIt (thunkEntryLabel name std_form_info updatable) -getCallMethod this_pkg name (LFUnknown True) n_args +getCallMethod name (LFUnknown True) n_args = SlowCall -- might be a function -getCallMethod this_pkg name (LFUnknown False) n_args +getCallMethod name (LFUnknown False) n_args = ASSERT2 ( n_args == 0, ppr name <+> ppr n_args ) EnterIt -- Not a function -getCallMethod this_pkg name (LFBlackHole _) n_args +getCallMethod 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 this_pkg name (LFLetNoEscape 0) n_args +getCallMethod name (LFLetNoEscape 0) n_args = JumpToIt (enterReturnPtLabel (nameUnique name)) -getCallMethod this_pkg name (LFLetNoEscape arity) n_args +getCallMethod name (LFLetNoEscape arity) n_args | n_args == arity = DirectEntry (enterReturnPtLabel (nameUnique name)) arity | otherwise = pprPanic "let-no-escape: " (ppr name <+> ppr arity) @@ -871,10 +867,9 @@ infoTableLabelFromCI (ClosureInfo { closureName = name, other -> panic "infoTableLabelFromCI" infoTableLabelFromCI (ConInfo { closureCon = con, - closureSMRep = rep, - closureDllCon = dll }) - | isStaticRep rep = mkStaticInfoTableLabel name dll - | otherwise = mkConInfoTableLabel name dll + closureSMRep = rep }) + | isStaticRep rep = mkStaticInfoTableLabel name + | otherwise = mkConInfoTableLabel name where name = dataConName con @@ -885,12 +880,12 @@ closureLabelFromCI _ = panic "closureLabelFromCI" -- thunkEntryLabel is a local help function, not exported. It's used from both -- entryLabelFromCI and getCallMethod. -thunkEntryLabel this_pkg thunk_id (ApThunk arity) is_updatable +thunkEntryLabel thunk_id (ApThunk arity) is_updatable = enterApLabel is_updatable arity -thunkEntryLabel this_pkg thunk_id (SelectorThunk offset) upd_flag +thunkEntryLabel thunk_id (SelectorThunk offset) upd_flag = enterSelectorLabel upd_flag offset -thunkEntryLabel this_pkg thunk_id _ is_updatable - = enterIdLabel this_pkg thunk_id +thunkEntryLabel thunk_id _ is_updatable + = enterIdLabel thunk_id enterApLabel is_updatable arity | tablesNextToCode = mkApInfoTableLabel is_updatable arity @@ -900,9 +895,9 @@ enterSelectorLabel upd_flag offset | tablesNextToCode = mkSelectorInfoLabel upd_flag offset | otherwise = mkSelectorEntryLabel upd_flag offset -enterIdLabel this_pkg id - | tablesNextToCode = mkInfoTableLabel this_pkg id - | otherwise = mkEntryLabel this_pkg id +enterIdLabel id + | tablesNextToCode = mkInfoTableLabel id + | otherwise = mkEntryLabel id enterLocalIdLabel id | tablesNextToCode = mkLocalInfoTableLabel id diff --git a/compiler/codeGen/CodeGen.lhs b/compiler/codeGen/CodeGen.lhs index 863d29e2e2..64ee9e4c4b 100644 --- a/compiler/codeGen/CodeGen.lhs +++ b/compiler/codeGen/CodeGen.lhs @@ -77,7 +77,7 @@ codeGen dflags this_mod data_tycons foreign_stubs imported_mods ; 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 way cost_centre_info + ; cmm_init <- getCmm (mkModuleInit way cost_centre_info this_mod main_mod foreign_stubs imported_mods hpc_info) ; return (cmm_binds ++ concat cmm_tycons ++ [cmm_init]) @@ -137,8 +137,7 @@ We initialise the module tree by keeping a work-stack, \begin{code} mkModuleInit - :: DynFlags - -> String -- the "way" + :: String -- the "way" -> CollectedCCs -- cost centre info -> Module -> Module -- name of the Main module @@ -146,7 +145,7 @@ mkModuleInit -> [Module] -> HpcInfo -> Code -mkModuleInit dflags way cost_centre_info this_mod main_mod foreign_stubs imported_mods hpc_info +mkModuleInit way cost_centre_info this_mod main_mod foreign_stubs imported_mods hpc_info = do { -- Allocate the static boolean that records if this -- module has been registered already emitData Data [CmmDataLabel moduleRegdLabel, @@ -187,11 +186,9 @@ mkModuleInit dflags way cost_centre_info this_mod main_mod foreign_stubs importe (emitSimpleProc plain_main_init_lbl rec_descent_init) } where - 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 + plain_init_lbl = mkPlainModuleInitLabel this_mod + real_init_lbl = mkModuleInitLabel this_mod way + plain_main_init_lbl = mkPlainModuleInitLabel rOOT_MAIN jump_to_init = stmtC (CmmJump (mkLblExpr real_init_lbl) []) @@ -213,7 +210,7 @@ mkModuleInit dflags way cost_centre_info this_mod main_mod foreign_stubs importe ; whenC (opt_Hpc) $ initHpc this_mod hpc_info - ; mapCs (registerModuleImport this_pkg way) + ; mapCs (registerModuleImport way) (imported_mods++extra_imported_mods) } @@ -229,13 +226,13 @@ mkModuleInit dflags way cost_centre_info this_mod main_mod foreign_stubs importe else ret_code ----------------------- -registerModuleImport :: PackageId -> String -> Module -> Code -registerModuleImport this_pkg way mod +registerModuleImport :: String -> Module -> Code +registerModuleImport 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 this_pkg mod way)) ] + , CmmStore (CmmReg spReg) (mkLblExpr (mkModuleInitLabel mod way)) ] \end{code} @@ -279,7 +276,7 @@ variable. cgTopBinding :: DynFlags -> (StgBinding,[(Id,[Id])]) -> Code cgTopBinding dflags (StgNonRec id rhs, srts) = do { id' <- maybeExternaliseId dflags id - ; mapM_ (mkSRT (thisPackage dflags) [id']) srts + ; mapM_ (mkSRT [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 @@ -289,19 +286,19 @@ cgTopBinding dflags (StgRec pairs, srts) = do { let (bndrs, rhss) = unzip pairs ; bndrs' <- mapFCs (maybeExternaliseId dflags) bndrs ; let pairs' = zip bndrs' rhss - ; mapM_ (mkSRT (thisPackage dflags) bndrs') srts + ; mapM_ (mkSRT bndrs') srts ; _new_binds <- fixC (\ new_binds -> do { addBindsC new_binds ; mapFCs ( \ (b,e) -> cgTopRhs b e ) pairs' }) ; nopC } -mkSRT :: PackageId -> [Id] -> (Id,[Id]) -> Code -mkSRT this_pkg these (id,[]) = nopC -mkSRT this_pkg these (id,ids) +mkSRT :: [Id] -> (Id,[Id]) -> Code +mkSRT these (id,[]) = nopC +mkSRT these (id,ids) = do { ids <- mapFCs remap ids ; id <- remap id ; emitRODataLits (mkSRTLabel (idName id)) - (map (CmmLabel . mkClosureLabel this_pkg . idName) ids) + (map (CmmLabel . mkClosureLabel . idName) ids) } where -- Sigh, better map all the ids against the environment in |