diff options
| -rw-r--r-- | compiler/cmm/CLabel.hs | 101 | ||||
| -rw-r--r-- | compiler/cmm/PprC.hs | 6 | ||||
| -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 | ||||
| -rw-r--r-- | compiler/nativeGen/AsmCodeGen.lhs | 43 | ||||
| -rw-r--r-- | compiler/nativeGen/MachCodeGen.hs | 29 | ||||
| -rw-r--r-- | compiler/nativeGen/NCGMonad.hs | 28 | ||||
| -rw-r--r-- | 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 48e576f74a..a67e587b4d 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 6032dc255c..77b8a8fd5d 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 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 diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs index 1cbdb7b98a..3036a7ac6a 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 cc940749f9..d07803de14 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 8fdcd44024..02491d1d2e 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 2571b5ca06..1411bbc6b1 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 |