From 81b2276ff9434d97aff683218c34c86479a8d868 Mon Sep 17 00:00:00 2001 From: Clemens Fruhwirth Date: Tue, 31 Jul 2007 09:59:53 +0000 Subject: [PATCH] Change the strategy to determine dynamic data access Instead of attaching the information whether a Label is going to be accessed dynamically or not (distinction between IdLabel/DynLabel and additional flags in ModuleInitLabel and PlainModuleInitLabel), we hand dflags through the CmmOpt monad and the NatM monad. Before calling labelDynamic in PositionIndependentCode, we extract thisPackage from dflags and supply the current package to labelDynamic, so it can take this information into account instead of extracting it from the labels itself. This simplifies a lot of code in codeGen that just hands through this_pkg. --- compiler/cmm/CLabel.hs | 101 ++++++++----------------- compiler/cmm/PprC.hs | 6 +- compiler/codeGen/CgBindery.lhs | 3 +- compiler/codeGen/CgCase.lhs | 2 +- compiler/codeGen/CgCon.lhs | 23 +++--- compiler/codeGen/CgExpr.lhs | 17 ++--- compiler/codeGen/CgHeapery.lhs | 7 +- compiler/codeGen/CgTailCall.lhs | 2 +- compiler/codeGen/CgUtils.hs | 6 +- compiler/codeGen/ClosureInfo.lhs | 57 +++++++------- compiler/codeGen/CodeGen.lhs | 35 ++++----- compiler/nativeGen/AsmCodeGen.lhs | 43 ++++++----- compiler/nativeGen/MachCodeGen.hs | 29 ++++--- compiler/nativeGen/NCGMonad.hs | 28 ++++--- compiler/nativeGen/PositionIndependentCode.hs | 48 ++++++------ 15 files changed, 187 insertions(+), 220 deletions(-) diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs index 48e576f..a67e587 100644 --- a/compiler/cmm/CLabel.hs +++ b/compiler/cmm/CLabel.hs @@ -117,6 +117,7 @@ import Config import CostCentre import Outputable import FastString +import DynFlags -- ----------------------------------------------------------------------------- -- The CLabel type @@ -148,10 +149,6 @@ data CLabel Name -- definition of a particular Id or Con IdLabelInfo - | DynIdLabel -- like IdLabel, but in a separate package, - Name -- and might therefore need a dynamic - IdLabelInfo -- reference. - | CaseLabel -- A family of labels related to a particular -- case expression. {-# UNPACK #-} !Unique -- Unique says which case expression @@ -166,7 +163,6 @@ data CLabel | ModuleInitLabel Module -- the module name String -- its "way" - Bool -- True <=> is in a different package -- at some point we might want some kind of version number in -- the module init label, to guard against compiling modules in -- the wrong order. We can't use the interface file version however, @@ -175,7 +171,6 @@ data CLabel | PlainModuleInitLabel -- without the vesrion & way info Module - Bool -- True <=> is in a different package | ModuleRegdLabel @@ -299,40 +294,19 @@ mkLocalInfoTableLabel name = IdLabel name InfoTable mkLocalEntryLabel name = IdLabel name Entry mkLocalClosureTableLabel name = IdLabel name ClosureTable -mkClosureLabel this_pkg name - | isDllName this_pkg name = DynIdLabel name Closure - | otherwise = IdLabel name Closure - -mkInfoTableLabel this_pkg name - | isDllName this_pkg name = DynIdLabel name InfoTable - | otherwise = IdLabel name InfoTable - -mkEntryLabel this_pkg name - | isDllName this_pkg name = DynIdLabel name Entry - | otherwise = IdLabel name Entry - -mkClosureTableLabel this_pkg name - | isDllName this_pkg name = DynIdLabel name ClosureTable - | otherwise = IdLabel name ClosureTable - -mkLocalConInfoTableLabel con = IdLabel con ConInfoTable -mkLocalConEntryLabel con = IdLabel con ConEntry -mkLocalStaticInfoTableLabel con = IdLabel con StaticInfoTable -mkLocalStaticConEntryLabel con = IdLabel con StaticConEntry - -mkConInfoTableLabel name False = IdLabel name ConInfoTable -mkConInfoTableLabel name True = DynIdLabel name ConInfoTable - -mkStaticInfoTableLabel name False = IdLabel name StaticInfoTable -mkStaticInfoTableLabel name True = DynIdLabel name StaticInfoTable - -mkConEntryLabel this_pkg name - | isDllName this_pkg name = DynIdLabel name ConEntry - | otherwise = IdLabel name ConEntry +mkClosureLabel name = IdLabel name Closure +mkInfoTableLabel name = IdLabel name InfoTable +mkEntryLabel name = IdLabel name Entry +mkClosureTableLabel name = IdLabel name ClosureTable +mkLocalConInfoTableLabel con = IdLabel con ConInfoTable +mkLocalConEntryLabel con = IdLabel con ConEntry +mkLocalStaticInfoTableLabel con = IdLabel con StaticInfoTable +mkLocalStaticConEntryLabel con = IdLabel con StaticConEntry +mkConInfoTableLabel name = IdLabel name ConInfoTable +mkStaticInfoTableLabel name = IdLabel name StaticInfoTable -mkStaticConEntryLabel this_pkg name - | isDllName this_pkg name = DynIdLabel name StaticConEntry - | otherwise = IdLabel name StaticConEntry +mkConEntryLabel name = IdLabel name ConEntry +mkStaticConEntryLabel name = IdLabel name StaticConEntry mkLargeSRTLabel uniq = LargeSRTLabel uniq mkBitmapLabel uniq = LargeBitmapLabel uniq @@ -345,13 +319,11 @@ mkDefaultLabel uniq = CaseLabel uniq CaseDefault mkStringLitLabel = StringLitLabel mkAsmTempLabel = AsmTempLabel -mkModuleInitLabel :: PackageId -> Module -> String -> CLabel -mkModuleInitLabel this_pkg mod way - = ModuleInitLabel mod way $! modulePackageId mod /= this_pkg +mkModuleInitLabel :: Module -> String -> CLabel +mkModuleInitLabel mod way = ModuleInitLabel mod way -mkPlainModuleInitLabel :: PackageId -> Module -> CLabel -mkPlainModuleInitLabel this_pkg mod - = PlainModuleInitLabel mod $! modulePackageId mod /= this_pkg +mkPlainModuleInitLabel :: Module -> CLabel +mkPlainModuleInitLabel mod = PlainModuleInitLabel mod -- Some fixed runtime system labels @@ -438,9 +410,6 @@ infoLblToEntryLbl :: CLabel -> CLabel infoLblToEntryLbl (IdLabel n InfoTable) = IdLabel n Entry infoLblToEntryLbl (IdLabel n ConInfoTable) = IdLabel n ConEntry infoLblToEntryLbl (IdLabel n StaticInfoTable) = IdLabel n StaticConEntry -infoLblToEntryLbl (DynIdLabel n InfoTable) = DynIdLabel n Entry -infoLblToEntryLbl (DynIdLabel n ConInfoTable) = DynIdLabel n ConEntry -infoLblToEntryLbl (DynIdLabel n StaticInfoTable) = DynIdLabel n StaticConEntry infoLblToEntryLbl (CaseLabel n CaseReturnInfo) = CaseLabel n CaseReturnPt infoLblToEntryLbl (RtsLabel (RtsInfo s)) = RtsLabel (RtsEntry s) infoLblToEntryLbl (RtsLabel (RtsRetInfo s)) = RtsLabel (RtsRet s) @@ -452,9 +421,6 @@ entryLblToInfoLbl :: CLabel -> CLabel entryLblToInfoLbl (IdLabel n Entry) = IdLabel n InfoTable entryLblToInfoLbl (IdLabel n ConEntry) = IdLabel n ConInfoTable entryLblToInfoLbl (IdLabel n StaticConEntry) = IdLabel n StaticInfoTable -entryLblToInfoLbl (DynIdLabel n Entry) = DynIdLabel n InfoTable -entryLblToInfoLbl (DynIdLabel n ConEntry) = DynIdLabel n ConInfoTable -entryLblToInfoLbl (DynIdLabel n StaticConEntry) = DynIdLabel n StaticInfoTable entryLblToInfoLbl (CaseLabel n CaseReturnPt) = CaseLabel n CaseReturnInfo entryLblToInfoLbl (RtsLabel (RtsEntry s)) = RtsLabel (RtsInfo s) entryLblToInfoLbl (RtsLabel (RtsRet s)) = RtsLabel (RtsRetInfo s) @@ -473,10 +439,9 @@ needsCDecl (IdLabel _ SRT) = False needsCDecl (LargeSRTLabel _) = False needsCDecl (LargeBitmapLabel _) = False needsCDecl (IdLabel _ _) = True -needsCDecl (DynIdLabel _ _) = True needsCDecl (CaseLabel _ _) = True -needsCDecl (ModuleInitLabel _ _ _) = True -needsCDecl (PlainModuleInitLabel _ _) = True +needsCDecl (ModuleInitLabel _ _) = True +needsCDecl (PlainModuleInitLabel _) = True needsCDecl ModuleRegdLabel = False needsCDecl (StringLitLabel _) = False @@ -509,13 +474,12 @@ externallyVisibleCLabel :: CLabel -> Bool -- not C "static" externallyVisibleCLabel (CaseLabel _ _) = False externallyVisibleCLabel (StringLitLabel _) = False externallyVisibleCLabel (AsmTempLabel _) = False -externallyVisibleCLabel (ModuleInitLabel _ _ _)= True -externallyVisibleCLabel (PlainModuleInitLabel _ _)= True +externallyVisibleCLabel (ModuleInitLabel _ _) = True +externallyVisibleCLabel (PlainModuleInitLabel _)= True externallyVisibleCLabel ModuleRegdLabel = False externallyVisibleCLabel (RtsLabel _) = True externallyVisibleCLabel (ForeignLabel _ _ _) = True externallyVisibleCLabel (IdLabel name _) = isExternalName name -externallyVisibleCLabel (DynIdLabel name _) = isExternalName name externallyVisibleCLabel (CC_Label _) = True externallyVisibleCLabel (CCS_Label _) = True externallyVisibleCLabel (DynamicLinkerLabel _ _) = False @@ -551,13 +515,12 @@ labelType (RtsLabel (RtsRetFS _)) = CodeLabel labelType (RtsLabel (RtsApFast _)) = CodeLabel labelType (CaseLabel _ CaseReturnInfo) = DataLabel labelType (CaseLabel _ _) = CodeLabel -labelType (ModuleInitLabel _ _ _) = CodeLabel -labelType (PlainModuleInitLabel _ _) = CodeLabel +labelType (ModuleInitLabel _ _) = CodeLabel +labelType (PlainModuleInitLabel _) = CodeLabel labelType (LargeSRTLabel _) = DataLabel labelType (LargeBitmapLabel _) = DataLabel labelType (IdLabel _ info) = idInfoLabelType info -labelType (DynIdLabel _ info) = idInfoLabelType info labelType _ = DataLabel idInfoLabelType info = @@ -580,12 +543,11 @@ idInfoLabelType info = -- @labelDynamic@ returns @True@ if the label is located -- in a DLL, be it a data reference or not. -labelDynamic :: CLabel -> Bool -labelDynamic lbl = +labelDynamic :: PackageId -> CLabel -> Bool +labelDynamic this_pkg lbl = case lbl of - RtsLabel _ -> not opt_Static -- i.e., is the RTS in a DLL or not? - IdLabel n k -> False - DynIdLabel n k -> True + RtsLabel _ -> not opt_Static && (this_pkg /= rtsPackageId) -- i.e., is the RTS in a DLL or not? + IdLabel n k -> isDllName this_pkg n #if mingw32_TARGET_OS ForeignLabel _ _ d -> d #else @@ -593,8 +555,8 @@ labelDynamic lbl = -- so we claim that all foreign imports come from dynamic libraries ForeignLabel _ _ _ -> True #endif - ModuleInitLabel m _ dyn -> not opt_Static && dyn - PlainModuleInitLabel m dyn -> not opt_Static && dyn + ModuleInitLabel m _ -> not opt_Static && this_pkg /= (modulePackageId m) + PlainModuleInitLabel m -> not opt_Static && this_pkg /= (modulePackageId m) -- Note that DynamicLinkerLabels do NOT require dynamic linking themselves. _ -> False @@ -782,15 +744,14 @@ pprCLbl (ForeignLabel str _ _) = ftext str pprCLbl (IdLabel name flavor) = ppr name <> ppIdFlavor flavor -pprCLbl (DynIdLabel name flavor) = ppr name <> ppIdFlavor flavor pprCLbl (CC_Label cc) = ppr cc pprCLbl (CCS_Label ccs) = ppr ccs -pprCLbl (ModuleInitLabel mod way _) +pprCLbl (ModuleInitLabel mod way) = ptext SLIT("__stginit_") <> ppr mod <> char '_' <> text way -pprCLbl (PlainModuleInitLabel mod _) +pprCLbl (PlainModuleInitLabel mod) = ptext SLIT("__stginit_") <> ppr mod pprCLbl (HpcTicksLabel mod) diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs index 6032dc2..77b8a8f 100644 --- a/compiler/cmm/PprC.hs +++ b/compiler/cmm/PprC.hs @@ -795,12 +795,8 @@ pprExternDecl in_srt lbl | not (needsCDecl lbl) = empty | otherwise = hcat [ visibility, label_type (labelType lbl), - lparen, dyn_wrapper (pprCLabel lbl), text ");" ] + lparen, pprCLabel lbl, text ");" ] where - dyn_wrapper d - | in_srt && labelDynamic lbl = text "DLL_IMPORT_DATA_VAR" <> parens d - | otherwise = d - label_type CodeLabel = ptext SLIT("F_") label_type DataLabel = ptext SLIT("I_") diff --git a/compiler/codeGen/CgBindery.lhs b/compiler/codeGen/CgBindery.lhs index 7447222..0306867 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 11a3c3e..149b856 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 91d7098..ae2c259 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 a71493a..b243e21 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 b89452e..dfa49eb 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 9527026..e25e794 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 8d3578e..19f5eab 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 d537a7b..6ff2d5f 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 863d29e..64ee9e4 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 diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs index 1cbdb7b..3036a7a 100644 --- a/compiler/nativeGen/AsmCodeGen.lhs +++ b/compiler/nativeGen/AsmCodeGen.lhs @@ -201,12 +201,12 @@ cmmNativeGen dflags cmm = {-# SCC "fixAssigns" #-} fixAssignsTop cmm `thenUs` \ fixed_cmm -> {-# SCC "genericOpt" #-} - cmmToCmm fixed_cmm `bind` \ (cmm, imports) -> + cmmToCmm dflags fixed_cmm `bind` \ (cmm, imports) -> (if dopt Opt_D_dump_opt_cmm dflags -- space leak avoidance then cmm else CmmData Text []) `bind` \ ppr_cmm -> {-# SCC "genMachCode" #-} - genMachCode cmm `thenUs` \ (pre_regalloc, lastMinuteImports) -> + genMachCode dflags cmm `thenUs` \ (pre_regalloc, lastMinuteImports) -> {-# SCC "regAlloc" #-} mapUs regAlloc pre_regalloc `thenUs` \ with_regs -> {-# SCC "shortcutBranches" #-} @@ -390,11 +390,11 @@ apply_mapping ufm (CmmProc info lbl params blocks) -- Switching between the two monads whilst carrying along the same -- Unique supply breaks abstraction. Is that bad? -genMachCode :: RawCmmTop -> UniqSM ([NatCmmTop], [CLabel]) +genMachCode :: DynFlags -> RawCmmTop -> UniqSM ([NatCmmTop], [CLabel]) -genMachCode cmm_top +genMachCode dflags cmm_top = do { initial_us <- getUs - ; let initial_st = mkNatM_State initial_us 0 + ; let initial_st = mkNatM_State initial_us 0 dflags (new_tops, final_st) = initNat initial_st (cmmTopCodeGen cmm_top) final_delta = natm_delta final_st final_imports = natm_imports final_st @@ -468,28 +468,31 @@ Ideas for other things we could do (ToDo): temp assignments, and certain assigns to mem...) -} -cmmToCmm :: RawCmmTop -> (RawCmmTop, [CLabel]) -cmmToCmm top@(CmmData _ _) = (top, []) -cmmToCmm (CmmProc info lbl params blocks) = runCmmOpt $ do +cmmToCmm :: DynFlags -> RawCmmTop -> (RawCmmTop, [CLabel]) +cmmToCmm _ top@(CmmData _ _) = (top, []) +cmmToCmm dflags (CmmProc info lbl params blocks) = runCmmOpt dflags $ do blocks' <- mapM cmmBlockConFold (cmmMiniInline blocks) return $ CmmProc info lbl params blocks' -newtype CmmOptM a = CmmOptM ([CLabel] -> (# a, [CLabel] #)) +newtype CmmOptM a = CmmOptM (([CLabel], DynFlags) -> (# a, [CLabel] #)) instance Monad CmmOptM where - return x = CmmOptM $ \imports -> (# x,imports #) + return x = CmmOptM $ \(imports, _) -> (# x,imports #) (CmmOptM f) >>= g = - CmmOptM $ \imports -> - case f imports of + CmmOptM $ \(imports, dflags) -> + case f (imports, dflags) of (# x, imports' #) -> case g x of - CmmOptM g' -> g' imports' + CmmOptM g' -> g' (imports', dflags) addImportCmmOpt :: CLabel -> CmmOptM () -addImportCmmOpt lbl = CmmOptM $ \imports -> (# (), lbl:imports #) +addImportCmmOpt lbl = CmmOptM $ \(imports, dflags) -> (# (), lbl:imports #) -runCmmOpt :: CmmOptM a -> (a, [CLabel]) -runCmmOpt (CmmOptM f) = case f [] of +getDynFlagsCmmOpt :: CmmOptM DynFlags +getDynFlagsCmmOpt = CmmOptM $ \(imports, dflags) -> (# dflags, imports #) + +runCmmOpt :: DynFlags -> CmmOptM a -> (a, [CLabel]) +runCmmOpt dflags (CmmOptM f) = case f ([], dflags) of (# result, imports #) -> (result, imports) cmmBlockConFold :: CmmBasicBlock -> CmmOptM CmmBasicBlock @@ -556,9 +559,13 @@ cmmExprConFold referenceKind expr return $ cmmMachOpFold mop args' CmmLit (CmmLabel lbl) - -> cmmMakeDynamicReference addImportCmmOpt referenceKind lbl + -> do + dflags <- getDynFlagsCmmOpt + cmmMakeDynamicReference dflags addImportCmmOpt referenceKind lbl CmmLit (CmmLabelOff lbl off) - -> do dynRef <- cmmMakeDynamicReference addImportCmmOpt referenceKind lbl + -> do + dflags <- getDynFlagsCmmOpt + dynRef <- cmmMakeDynamicReference dflags addImportCmmOpt referenceKind lbl return $ cmmMachOpFold (MO_Add wordRep) [ dynRef, (CmmLit $ CmmInt (fromIntegral off) wordRep) diff --git a/compiler/nativeGen/MachCodeGen.hs b/compiler/nativeGen/MachCodeGen.hs index cc94074..d07803d 100644 --- a/compiler/nativeGen/MachCodeGen.hs +++ b/compiler/nativeGen/MachCodeGen.hs @@ -42,8 +42,10 @@ import FastTypes ( isFastTrue ) import Constants ( wORD_SIZE ) #ifdef DEBUG +import Outputable ( assertPanic ) import Debug.Trace ( trace ) #endif +import Debug.Trace ( trace ) import Control.Monad ( mapAndUnzipM ) import Data.Maybe ( fromJust ) @@ -784,7 +786,8 @@ getRegister leaf getRegister (CmmLit (CmmFloat f F32)) = do lbl <- getNewLabelNat - dynRef <- cmmMakeDynamicReference addImportNat DataReference lbl + dflags <- getDynFlagsNat + dynRef <- cmmMakeDynamicReference dflags addImportNat DataReference lbl Amode addr addr_code <- getAmode dynRef let code dst = LDATA ReadOnlyData @@ -807,7 +810,8 @@ getRegister (CmmLit (CmmFloat d F64)) | otherwise = do lbl <- getNewLabelNat - dynRef <- cmmMakeDynamicReference addImportNat DataReference lbl + dflags <- getDynFlagsNat + dynRef <- cmmMakeDynamicReference dflags addImportNat DataReference lbl Amode addr addr_code <- getAmode dynRef let code dst = LDATA ReadOnlyData @@ -1727,7 +1731,8 @@ getRegister (CmmLit (CmmInt i rep)) getRegister (CmmLit (CmmFloat f frep)) = do lbl <- getNewLabelNat - dynRef <- cmmMakeDynamicReference addImportNat DataReference lbl + dflags <- getDynFlagsNat + dynRef <- cmmMakeDynamicReference dflags addImportNat DataReference lbl Amode addr addr_code <- getAmode dynRef let code dst = LDATA ReadOnlyData [CmmDataLabel lbl, @@ -3195,7 +3200,8 @@ outOfLineFloatOp :: CallishMachOp -> CmmFormal -> CmmActuals -> NatM InstrBlock outOfLineFloatOp mop res args = do - targetExpr <- cmmMakeDynamicReference addImportNat CallReference lbl + dflags <- getDynFlagsNat + targetExpr <- cmmMakeDynamicReference dflags addImportNat CallReference lbl let target = CmmForeignCall targetExpr CCallConv if localRegRep res == F64 @@ -3551,7 +3557,8 @@ genCCall target dest_regs argsAndHints = do ) outOfLineFloatOp mop = do - mopExpr <- cmmMakeDynamicReference addImportNat CallReference $ + dflags <- getDynFlagsNat + mopExpr <- cmmMakeDynamicReference dflags addImportNat CallReference $ mkForeignLabel functionName Nothing True let mopLabelOrExpr = case mopExpr of CmmLit (CmmLabel lbl) -> Left lbl @@ -3806,7 +3813,8 @@ genCCall target dest_regs argsAndHints outOfLineFloatOp mop = do - mopExpr <- cmmMakeDynamicReference addImportNat CallReference $ + dflags <- getDynFlagsNat + mopExpr <- cmmMakeDynamicReference dflags addImportNat CallReference $ mkForeignLabel functionName Nothing True let mopLabelOrExpr = case mopExpr of CmmLit (CmmLabel lbl) -> Left lbl @@ -3866,7 +3874,8 @@ genSwitch expr ids = do (reg,e_code) <- getSomeReg expr lbl <- getNewLabelNat - dynRef <- cmmMakeDynamicReference addImportNat DataReference lbl + dflags <- getDynFlagsNat + dynRef <- cmmMakeDynamicReference dflags addImportNat DataReference lbl (tableReg,t_code) <- getSomeReg $ dynRef let jumpTable = map jumpTableEntryRel ids @@ -3920,7 +3929,8 @@ genSwitch expr ids (reg,e_code) <- getSomeReg expr tmp <- getNewRegNat I32 lbl <- getNewLabelNat - dynRef <- cmmMakeDynamicReference addImportNat DataReference lbl + dflags <- getDynFlagsNat + dynRef <- cmmMakeDynamicReference dflags addImportNat DataReference lbl (tableReg,t_code) <- getSomeReg $ dynRef let jumpTable = map jumpTableEntryRel ids @@ -4761,7 +4771,8 @@ coerceInt2FP fromRep toRep x = do lbl <- getNewLabelNat itmp <- getNewRegNat I32 ftmp <- getNewRegNat F64 - dynRef <- cmmMakeDynamicReference addImportNat DataReference lbl + dflags <- getDynFlagsNat + dynRef <- cmmMakeDynamicReference dflags addImportNat DataReference lbl Amode addr addr_code <- getAmode dynRef let code' dst = code `appOL` maybe_exts `appOL` toOL [ diff --git a/compiler/nativeGen/NCGMonad.hs b/compiler/nativeGen/NCGMonad.hs index 8fdcd44..02491d1 100644 --- a/compiler/nativeGen/NCGMonad.hs +++ b/compiler/nativeGen/NCGMonad.hs @@ -13,7 +13,7 @@ module NCGMonad ( initNat, addImportNat, getUniqueNat, mapAccumLNat, setDeltaNat, getDeltaNat, getBlockIdNat, getNewLabelNat, getNewRegNat, getNewRegPairNat, - getPicBaseMaybeNat, getPicBaseNat + getPicBaseMaybeNat, getPicBaseNat, getDynFlagsNat ) where #include "HsVersions.h" @@ -24,21 +24,22 @@ import MachRegs import MachOp ( MachRep ) import UniqSupply import Unique ( Unique ) - +import DynFlags data NatM_State = NatM_State { natm_us :: UniqSupply, natm_delta :: Int, natm_imports :: [(CLabel)], - natm_pic :: Maybe Reg + natm_pic :: Maybe Reg, + natm_dflags :: DynFlags } newtype NatM result = NatM (NatM_State -> (result, NatM_State)) unNat (NatM a) = a -mkNatM_State :: UniqSupply -> Int -> NatM_State -mkNatM_State us delta = NatM_State us delta [] Nothing +mkNatM_State :: UniqSupply -> Int -> DynFlags -> NatM_State +mkNatM_State us delta dflags = NatM_State us delta [] Nothing dflags initNat :: NatM_State -> NatM a -> (a, NatM_State) initNat init_st m = case unNat m init_st of { (r,st) -> (r,st) } @@ -68,20 +69,25 @@ mapAccumLNat f b (x:xs) return (b__3, x__2:xs__2) getUniqueNat :: NatM Unique -getUniqueNat = NatM $ \ (NatM_State us delta imports pic) -> +getUniqueNat = NatM $ \ (NatM_State us delta imports pic dflags) -> case splitUniqSupply us of - (us1,us2) -> (uniqFromSupply us1, (NatM_State us2 delta imports pic)) + (us1,us2) -> (uniqFromSupply us1, (NatM_State us2 delta imports pic dflags)) + + +getDynFlagsNat :: NatM DynFlags +getDynFlagsNat = NatM $ \ (NatM_State us delta imports pic dflags) -> + (dflags, (NatM_State us delta imports pic dflags)) getDeltaNat :: NatM Int getDeltaNat = NatM $ \ st -> (natm_delta st, st) setDeltaNat :: Int -> NatM () -setDeltaNat delta = NatM $ \ (NatM_State us _ imports pic) -> - ((), NatM_State us delta imports pic) +setDeltaNat delta = NatM $ \ (NatM_State us _ imports pic dflags) -> + ((), NatM_State us delta imports pic dflags) addImportNat :: CLabel -> NatM () -addImportNat imp = NatM $ \ (NatM_State us delta imports pic) -> - ((), NatM_State us delta (imp:imports) pic) +addImportNat imp = NatM $ \ (NatM_State us delta imports pic dflags) -> + ((), NatM_State us delta (imp:imports) pic dflags) getBlockIdNat :: NatM BlockId getBlockIdNat = do u <- getUniqueNat; return (BlockId u) diff --git a/compiler/nativeGen/PositionIndependentCode.hs b/compiler/nativeGen/PositionIndependentCode.hs index 2571b5c..1411bbc 100644 --- a/compiler/nativeGen/PositionIndependentCode.hs +++ b/compiler/nativeGen/PositionIndependentCode.hs @@ -68,6 +68,7 @@ import Pretty import qualified Outputable import Panic ( panic ) +import DynFlags -- The most important function here is cmmMakeDynamicReference. @@ -90,16 +91,17 @@ data ReferenceKind = DataReference deriving(Eq) cmmMakeDynamicReference - :: Monad m => (CLabel -> m ()) -- a monad & a function + :: Monad m => DynFlags + -> (CLabel -> m ()) -- a monad & a function -- used for recording imported symbols -> ReferenceKind -- whether this is the target of a jump -> CLabel -- the label -> m CmmExpr -cmmMakeDynamicReference addImport referenceKind lbl +cmmMakeDynamicReference dflags addImport referenceKind lbl | Just _ <- dynamicLinkerLabelInfo lbl = return $ CmmLit $ CmmLabel lbl -- already processed it, pass through - | otherwise = case howToAccessLabel referenceKind lbl of + | otherwise = case howToAccessLabel dflags referenceKind lbl of AccessViaStub -> do let stub = mkDynamicLinkerLabel CodeStub lbl addImport stub @@ -161,7 +163,7 @@ data LabelAccessStyle = AccessViaStub | AccessViaSymbolPtr | AccessDirectly -howToAccessLabel :: ReferenceKind -> CLabel -> LabelAccessStyle +howToAccessLabel :: DynFlags -> ReferenceKind -> CLabel -> LabelAccessStyle #if mingw32_TARGET_OS -- Windows @@ -170,8 +172,8 @@ howToAccessLabel :: ReferenceKind -> CLabel -> LabelAccessStyle -- are imported from a DLL via an __imp_* label. -- There are no stubs for imported code. -howToAccessLabel _ lbl | labelDynamic lbl = AccessViaSymbolPtr - | otherwise = AccessDirectly +howToAccessLabel dflags _ lbl | labelDynamic (thisPackage dflags) lbl = AccessViaSymbolPtr + | otherwise = AccessDirectly #elif darwin_TARGET_OS -- Mach-O (Darwin, Mac OS X) -- @@ -181,9 +183,9 @@ howToAccessLabel _ lbl | labelDynamic lbl = AccessViaSymbolPtr -- It is always possible to access something indirectly, -- even when it's not necessary. -howToAccessLabel DataReference lbl +howToAccessLabel dflags DataReference lbl -- data access to a dynamic library goes via a symbol pointer - | labelDynamic lbl = AccessViaSymbolPtr + | labelDynamic (thisPackage dflags) lbl = AccessViaSymbolPtr #if !x86_64_TARGET_ARCH -- when generating PIC code, all cross-module data references must @@ -204,17 +206,17 @@ howToAccessLabel DataReference lbl -- dyld code stubs don't work for tailcalls because the -- stack alignment is only right for regular calls. -- Therefore, we have to go via a symbol pointer: -howToAccessLabel JumpReference lbl - | labelDynamic lbl +howToAccessLabel dflags JumpReference lbl + | labelDynamic (thisPackage dflags) lbl = AccessViaSymbolPtr #endif -howToAccessLabel _ lbl +howToAccessLabel dflags _ lbl #if !x86_64_TARGET_ARCH -- Code stubs are the usual method of choice for imported code; -- not needed on x86_64 because Apple's new linker, ld64, generates -- them automatically. - | labelDynamic lbl + | labelDynamic (thisPackage dflags) lbl = AccessViaStub #endif | otherwise @@ -224,8 +226,8 @@ howToAccessLabel _ lbl #elif linux_TARGET_OS && powerpc64_TARGET_ARCH -- ELF PPC64 (powerpc64-linux), AIX, MacOS 9, BeOS/PPC -howToAccessLabel DataReference lbl = AccessViaSymbolPtr -howToAccessLabel _ lbl = AccessDirectly -- actually, .label instead of label +howToAccessLabel _ DataReference lbl = AccessViaSymbolPtr +howToAccessLabel _ _ lbl = AccessDirectly -- actually, .label instead of label #elif linux_TARGET_OS -- ELF (Linux) @@ -239,15 +241,15 @@ howToAccessLabel _ lbl = AccessDirectly -- actually, .label instead of label -- from position independent code. It is also required from the main program -- when dynamic libraries containing Haskell code are used. -howToAccessLabel _ lbl +howToAccessLabel _ _ lbl -- no PIC -> the dynamic linker does everything for us; -- if we don't dynamically link to Haskell code, -- it actually manages to do so without messing thins up. | not opt_PIC && opt_Static = AccessDirectly -howToAccessLabel DataReference lbl +howToAccessLabel dflags DataReference lbl -- A dynamic label needs to be accessed via a symbol pointer. - | labelDynamic lbl = AccessViaSymbolPtr + | labelDynamic (thisPackage dflags) lbl = AccessViaSymbolPtr #if powerpc_TARGET_ARCH -- For PowerPC32 -fPIC, we have to access even static data -- via a symbol pointer (see below for an explanation why @@ -269,22 +271,22 @@ howToAccessLabel DataReference lbl -- (AccessDirectly, because we get an implicit symbol stub) -- and calling functions from PIC code on non-i386 platforms (via a symbol stub) -howToAccessLabel CallReference lbl - | labelDynamic lbl && not opt_PIC +howToAccessLabel dflags CallReference lbl + | labelDynamic (thisPackage dflags) lbl && not opt_PIC = AccessDirectly #if !i386_TARGET_ARCH - | labelDynamic lbl && opt_PIC + | labelDynamic (thisPackage dflags) lbl && opt_PIC = AccessViaStub #endif -howToAccessLabel _ lbl - | labelDynamic lbl = AccessViaSymbolPtr +howToAccessLabel dflags _ lbl + | labelDynamic (thisPackage dflags) lbl = AccessViaSymbolPtr | otherwise = AccessDirectly #else -- -- all other platforms -- -howToAccessLabel _ _ +howToAccessLabel _ _ _ | not opt_PIC = AccessDirectly | otherwise = panic "howToAccessLabel: PIC not defined for this platform" #endif -- 1.7.10.4