diff options
author | Sylvain Henry <sylvain@haskus.fr> | 2020-05-25 17:37:55 +0200 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2020-06-18 23:08:35 -0400 |
commit | d4a0be758003f32b9d9d89cfd14b9839ac002f4d (patch) | |
tree | 2ced620f7598d9e71882be08b027a7ce9e448be2 /compiler/GHC | |
parent | 2af0ec9059b94e1fa6b37eda60216e0222e1a53d (diff) | |
download | haskell-d4a0be758003f32b9d9d89cfd14b9839ac002f4d.tar.gz |
Move tablesNextToCode field into Platform
tablesNextToCode is a platform setting and doesn't belong into DynFlags
(#17957). Doing this is also a prerequisite to fix #14335 where we deal
with two platforms (target and host) that may have different platform
settings.
Diffstat (limited to 'compiler/GHC')
-rw-r--r-- | compiler/GHC/ByteCode/InfoTable.hs | 4 | ||||
-rw-r--r-- | compiler/GHC/Cmm/Info.hs | 81 | ||||
-rw-r--r-- | compiler/GHC/Cmm/LayoutStack.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/Cmm/Parser.y | 7 | ||||
-rw-r--r-- | compiler/GHC/Cmm/Pipeline.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/Cmm/ProcPoint.hs | 8 | ||||
-rw-r--r-- | compiler/GHC/CmmToAsm/X86/Ppr.hs | 10 | ||||
-rw-r--r-- | compiler/GHC/Driver/Session.hs | 5 | ||||
-rw-r--r-- | compiler/GHC/Settings.hs | 3 | ||||
-rw-r--r-- | compiler/GHC/Settings/IO.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/StgToCmm/Bind.hs | 4 | ||||
-rw-r--r-- | compiler/GHC/StgToCmm/Closure.hs | 33 | ||||
-rw-r--r-- | compiler/GHC/StgToCmm/Expr.hs | 5 | ||||
-rw-r--r-- | compiler/GHC/StgToCmm/Layout.hs | 4 |
14 files changed, 85 insertions, 85 deletions
diff --git a/compiler/GHC/ByteCode/InfoTable.hs b/compiler/GHC/ByteCode/InfoTable.hs index b02683d10f..84f4ed3ef0 100644 --- a/compiler/GHC/ByteCode/InfoTable.hs +++ b/compiler/GHC/ByteCode/InfoTable.hs @@ -11,6 +11,7 @@ module GHC.ByteCode.InfoTable ( mkITbls ) where import GHC.Prelude +import GHC.Platform import GHC.ByteCode.Types import GHC.Runtime.Interpreter import GHC.Driver.Session @@ -72,7 +73,8 @@ make_constr_itbls hsc_env cons = descr = dataConIdentity dcon - tables_next_to_code = tablesNextToCode dflags + platform = targetPlatform dflags + tables_next_to_code = platformTablesNextToCode platform r <- iservCmd hsc_env (MkConInfoTable tables_next_to_code ptrs' nptrs_really conNo (tagForCon dflags dcon) descr) diff --git a/compiler/GHC/Cmm/Info.hs b/compiler/GHC/Cmm/Info.hs index 0c0fc98eb6..e9c3ded71c 100644 --- a/compiler/GHC/Cmm/Info.hs +++ b/compiler/GHC/Cmm/Info.hs @@ -124,7 +124,7 @@ mkInfoTable dflags proc@(CmmProc infos entry_lbl live blocks) -- in the non-tables-next-to-code case, procs can have at most a -- single info table associated with the entry label of the proc. -- - | not (tablesNextToCode dflags) + | not (platformTablesNextToCode (targetPlatform dflags)) = case topInfoTable proc of -- must be at most one -- no info table Nothing -> @@ -134,8 +134,8 @@ mkInfoTable dflags proc@(CmmProc infos entry_lbl live blocks) (top_decls, (std_info, extra_bits)) <- mkInfoTableContents dflags info Nothing let - rel_std_info = map (makeRelativeRefTo dflags info_lbl) std_info - rel_extra_bits = map (makeRelativeRefTo dflags info_lbl) extra_bits + rel_std_info = map (makeRelativeRefTo platform info_lbl) std_info + rel_extra_bits = map (makeRelativeRefTo platform info_lbl) extra_bits -- -- Separately emit info table (with the function entry -- point as first entry) and the entry code @@ -159,13 +159,14 @@ mkInfoTable dflags proc@(CmmProc infos entry_lbl live blocks) [CmmProc (mapFromList raw_infos) entry_lbl live blocks]) where + platform = targetPlatform dflags do_one_info (lbl,itbl) = do (top_decls, (std_info, extra_bits)) <- mkInfoTableContents dflags itbl Nothing let info_lbl = cit_lbl itbl - rel_std_info = map (makeRelativeRefTo dflags info_lbl) std_info - rel_extra_bits = map (makeRelativeRefTo dflags info_lbl) extra_bits + rel_std_info = map (makeRelativeRefTo platform info_lbl) std_info + rel_extra_bits = map (makeRelativeRefTo platform info_lbl) extra_bits -- return (top_decls, (lbl, CmmStaticsRaw info_lbl $ map CmmStaticLit $ reverse rel_extra_bits ++ rel_std_info)) @@ -195,7 +196,7 @@ mkInfoTableContents dflags | StackRep frame <- smrep = do { (prof_lits, prof_data) <- mkProfLits platform prof - ; let (srt_label, srt_bitmap) = mkSRTLit dflags info_lbl srt + ; let (srt_label, srt_bitmap) = mkSRTLit platform info_lbl srt ; (liveness_lit, liveness_data) <- mkLivenessBits dflags frame ; let std_info = mkStdInfoTable dflags prof_lits rts_tag srt_bitmap liveness_lit @@ -208,7 +209,7 @@ mkInfoTableContents dflags | HeapRep _ ptrs nonptrs closure_type <- smrep = do { let layout = packIntsCLit platform ptrs nonptrs ; (prof_lits, prof_data) <- mkProfLits platform prof - ; let (srt_label, srt_bitmap) = mkSRTLit dflags info_lbl srt + ; let (srt_label, srt_bitmap) = mkSRTLit platform info_lbl srt ; (mb_srt_field, mb_layout, extra_bits, ct_data) <- mk_pieces closure_type srt_label ; let std_info = mkStdInfoTable dflags prof_lits @@ -246,7 +247,7 @@ mkInfoTableContents dflags ; let fun_type | null liveness_data = aRG_GEN | otherwise = aRG_GEN_BIG extra_bits = [ packIntsCLit platform fun_type arity ] - ++ (if inlineSRT dflags then [] else [ srt_lit ]) + ++ (if inlineSRT platform then [] else [ srt_lit ]) ++ [ liveness_lit, slow_entry ] ; return (Nothing, Nothing, extra_bits, liveness_data) } where @@ -265,25 +266,25 @@ packIntsCLit platform a b = packHalfWordsCLit platform (toStgHalfWord platform (fromIntegral b)) -mkSRTLit :: DynFlags +mkSRTLit :: Platform -> CLabel -> Maybe CLabel -> ([CmmLit], -- srt_label, if any CmmLit) -- srt_bitmap -mkSRTLit dflags info_lbl (Just lbl) - | inlineSRT dflags - = ([], CmmLabelDiffOff lbl info_lbl 0 (halfWordWidth (targetPlatform dflags))) -mkSRTLit dflags _ Nothing = ([], CmmInt 0 (halfWordWidth (targetPlatform dflags))) -mkSRTLit dflags _ (Just lbl) = ([CmmLabel lbl], CmmInt 1 (halfWordWidth (targetPlatform dflags))) +mkSRTLit platform info_lbl (Just lbl) + | inlineSRT platform + = ([], CmmLabelDiffOff lbl info_lbl 0 (halfWordWidth platform)) +mkSRTLit platform _ Nothing = ([], CmmInt 0 (halfWordWidth platform)) +mkSRTLit platform _ (Just lbl) = ([CmmLabel lbl], CmmInt 1 (halfWordWidth platform)) -- | Is the SRT offset field inline in the info table on this platform? -- -- See the section "Referring to an SRT from the info table" in -- Note [SRTs] in GHC.Cmm.Info.Build -inlineSRT :: DynFlags -> Bool -inlineSRT dflags = platformArch (targetPlatform dflags) == ArchX86_64 - && tablesNextToCode dflags +inlineSRT :: Platform -> Bool +inlineSRT platform = platformArch platform == ArchX86_64 + && platformTablesNextToCode platform ------------------------------------------------------------------------- -- @@ -311,16 +312,14 @@ inlineSRT dflags = platformArch (targetPlatform dflags) == ArchX86_64 -- Note that this is done even when the -fPIC flag is not specified, -- as we want to keep binary compatibility between PIC and non-PIC. -makeRelativeRefTo :: DynFlags -> CLabel -> CmmLit -> CmmLit - -makeRelativeRefTo dflags info_lbl (CmmLabel lbl) - | tablesNextToCode dflags - = CmmLabelDiffOff lbl info_lbl 0 (wordWidth (targetPlatform dflags)) -makeRelativeRefTo dflags info_lbl (CmmLabelOff lbl off) - | tablesNextToCode dflags - = CmmLabelDiffOff lbl info_lbl off (wordWidth (targetPlatform dflags)) -makeRelativeRefTo _ _ lit = lit - +makeRelativeRefTo :: Platform -> CLabel -> CmmLit -> CmmLit +makeRelativeRefTo platform info_lbl lit + = if platformTablesNextToCode platform + then case lit of + CmmLabel lbl -> CmmLabelDiffOff lbl info_lbl 0 (wordWidth platform) + CmmLabelOff lbl off -> CmmLabelDiffOff lbl info_lbl off (wordWidth platform) + _ -> lit + else lit ------------------------------------------------------------------------- -- @@ -457,12 +456,13 @@ closureInfoPtr :: DynFlags -> CmmExpr -> CmmExpr closureInfoPtr dflags e = CmmLoad (wordAligned dflags e) (bWord (targetPlatform dflags)) -entryCode :: DynFlags -> CmmExpr -> CmmExpr --- Takes an info pointer (the first word of a closure) --- and returns its entry code -entryCode dflags e - | tablesNextToCode dflags = e - | otherwise = CmmLoad e (bWord (targetPlatform dflags)) +-- | Takes an info pointer (the first word of a closure) and returns its entry +-- code +entryCode :: Platform -> CmmExpr -> CmmExpr +entryCode platform e = + if platformTablesNextToCode platform + then e + else CmmLoad e (bWord platform) getConstrTag :: DynFlags -> CmmExpr -> CmmExpr -- Takes a closure pointer, and return the *zero-indexed* @@ -489,8 +489,8 @@ infoTable :: DynFlags -> CmmExpr -> CmmExpr -- and returns a pointer to the first word of the standard-form -- info table, excluding the entry-code word (if present) infoTable dflags info_ptr - | tablesNextToCode dflags = cmmOffsetB platform info_ptr (- stdInfoTableSizeB dflags) - | otherwise = cmmOffsetW platform info_ptr 1 -- Past the entry code pointer + | platformTablesNextToCode platform = cmmOffsetB platform info_ptr (- stdInfoTableSizeB dflags) + | otherwise = cmmOffsetW platform info_ptr 1 -- Past the entry code pointer where platform = targetPlatform dflags infoTableConstrTag :: DynFlags -> CmmExpr -> CmmExpr @@ -527,7 +527,7 @@ funInfoTable :: DynFlags -> CmmExpr -> CmmExpr -- and returns a pointer to the first word of the StgFunInfoExtra struct -- in the info table. funInfoTable dflags info_ptr - | tablesNextToCode dflags + | platformTablesNextToCode platform = cmmOffsetB platform info_ptr (- stdInfoTableSizeB dflags - sIZEOF_StgFunInfoExtraRev dflags) | otherwise = cmmOffsetW platform info_ptr (1 + stdInfoTableSizeW dflags) @@ -543,12 +543,13 @@ funInfoArity dflags iptr platform = targetPlatform dflags fun_info = funInfoTable dflags iptr rep = cmmBits (widthFromBytes rep_bytes) + tablesNextToCode = platformTablesNextToCode platform (rep_bytes, offset) - | tablesNextToCode dflags = ( pc_REP_StgFunInfoExtraRev_arity pc - , oFFSET_StgFunInfoExtraRev_arity dflags ) - | otherwise = ( pc_REP_StgFunInfoExtraFwd_arity pc - , oFFSET_StgFunInfoExtraFwd_arity dflags ) + | tablesNextToCode = ( pc_REP_StgFunInfoExtraRev_arity pc + , oFFSET_StgFunInfoExtraRev_arity dflags ) + | otherwise = ( pc_REP_StgFunInfoExtraFwd_arity pc + , oFFSET_StgFunInfoExtraFwd_arity dflags ) pc = platformConstants dflags diff --git a/compiler/GHC/Cmm/LayoutStack.hs b/compiler/GHC/Cmm/LayoutStack.hs index b8fcf65b58..b8cf2c4900 100644 --- a/compiler/GHC/Cmm/LayoutStack.hs +++ b/compiler/GHC/Cmm/LayoutStack.hs @@ -1164,7 +1164,7 @@ lowerSafeForeignCall dflags block -- received an exception during the call, then the stack might be -- different. Hence we continue by jumping to the top stack frame, -- not by jumping to succ. - jump = CmmCall { cml_target = entryCode dflags $ + jump = CmmCall { cml_target = entryCode platform $ CmmLoad spExpr (bWord platform) , cml_cont = Just succ , cml_args_regs = regs diff --git a/compiler/GHC/Cmm/Parser.y b/compiler/GHC/Cmm/Parser.y index 41d5d3d6d6..1c9f0ad041 100644 --- a/compiler/GHC/Cmm/Parser.y +++ b/compiler/GHC/Cmm/Parser.y @@ -909,17 +909,18 @@ exprOp name args_code = do exprMacros :: DynFlags -> UniqFM ([CmmExpr] -> CmmExpr) exprMacros dflags = listToUFM [ - ( fsLit "ENTRY_CODE", \ [x] -> entryCode dflags x ), + ( fsLit "ENTRY_CODE", \ [x] -> entryCode platform x ), ( fsLit "INFO_PTR", \ [x] -> closureInfoPtr dflags x ), ( fsLit "STD_INFO", \ [x] -> infoTable dflags x ), ( fsLit "FUN_INFO", \ [x] -> funInfoTable dflags x ), - ( fsLit "GET_ENTRY", \ [x] -> entryCode dflags (closureInfoPtr dflags x) ), + ( fsLit "GET_ENTRY", \ [x] -> entryCode platform (closureInfoPtr dflags x) ), ( fsLit "GET_STD_INFO", \ [x] -> infoTable dflags (closureInfoPtr dflags x) ), ( fsLit "GET_FUN_INFO", \ [x] -> funInfoTable dflags (closureInfoPtr dflags x) ), ( fsLit "INFO_TYPE", \ [x] -> infoTableClosureType dflags x ), ( fsLit "INFO_PTRS", \ [x] -> infoTablePtrs dflags x ), ( fsLit "INFO_NPTRS", \ [x] -> infoTableNonPtrs dflags x ) ] + where platform = targetPlatform dflags -- we understand a subset of C-- primitives: machOps = listToUFM $ @@ -1213,7 +1214,7 @@ doReturn exprs_code = do mkReturnSimple :: DynFlags -> [CmmActual] -> UpdFrameOffset -> CmmAGraph mkReturnSimple dflags actuals updfr_off = mkReturn dflags e actuals updfr_off - where e = entryCode dflags (CmmLoad (CmmStackSlot Old updfr_off) + where e = entryCode platform (CmmLoad (CmmStackSlot Old updfr_off) (gcWord platform)) platform = targetPlatform dflags diff --git a/compiler/GHC/Cmm/Pipeline.hs b/compiler/GHC/Cmm/Pipeline.hs index 2dc4ecb80e..e28c880d44 100644 --- a/compiler/GHC/Cmm/Pipeline.hs +++ b/compiler/GHC/Cmm/Pipeline.hs @@ -172,7 +172,7 @@ cpsTop hsc_env proc = -- label to put on info tables for basic blocks that are not -- the entry point. splitting_proc_points = hscTarget dflags /= HscAsm - || not (tablesNextToCode dflags) + || not (platformTablesNextToCode platform) || -- Note [inconsistent-pic-reg] usingInconsistentPicReg usingInconsistentPicReg diff --git a/compiler/GHC/Cmm/ProcPoint.hs b/compiler/GHC/Cmm/ProcPoint.hs index fbefc544dc..1a42dad51d 100644 --- a/compiler/GHC/Cmm/ProcPoint.hs +++ b/compiler/GHC/Cmm/ProcPoint.hs @@ -315,10 +315,12 @@ splitAtProcPoints dflags entry_label callPPs procPoints procMap -- when jumping to a PP that has an info table, if -- tablesNextToCode is off we must jump to the entry -- label instead. + platform = targetPlatform dflags + tablesNextToCode = platformTablesNextToCode platform jump_label (Just info_lbl) _ - | tablesNextToCode dflags = info_lbl - | otherwise = toEntryLbl info_lbl - jump_label Nothing block_lbl = block_lbl + | tablesNextToCode = info_lbl + | otherwise = toEntryLbl info_lbl + jump_label Nothing block_lbl = block_lbl add_if_pp id rst = case mapLookup id procLabels of Just (lbl, mb_info_lbl) -> (id, jump_label mb_info_lbl lbl) : rst diff --git a/compiler/GHC/CmmToAsm/X86/Ppr.hs b/compiler/GHC/CmmToAsm/X86/Ppr.hs index 6be1c8ef4d..1accde5a5d 100644 --- a/compiler/GHC/CmmToAsm/X86/Ppr.hs +++ b/compiler/GHC/CmmToAsm/X86/Ppr.hs @@ -183,8 +183,8 @@ pprGloblDecl lbl | not (externallyVisibleCLabel lbl) = empty | otherwise = text ".globl " <> ppr lbl -pprLabelType' :: DynFlags -> CLabel -> SDoc -pprLabelType' dflags lbl = +pprLabelType' :: Platform -> CLabel -> SDoc +pprLabelType' platform lbl = if isCFunctionLabel lbl || functionOkInfoTable then text "@function" else @@ -237,16 +237,14 @@ pprLabelType' dflags lbl = every code-like thing to give the needed information for to the tools but mess up with the relocation. https://phabricator.haskell.org/D4730 -} - functionOkInfoTable = tablesNextToCode dflags && + functionOkInfoTable = platformTablesNextToCode platform && isInfoTableLabel lbl && not (isConInfoTableLabel lbl) pprTypeDecl :: Platform -> CLabel -> SDoc pprTypeDecl platform lbl = if osElfTarget (platformOS platform) && externallyVisibleCLabel lbl - then - sdocWithDynFlags $ \df -> - text ".type " <> ppr lbl <> ptext (sLit ", ") <> pprLabelType' df lbl + then text ".type " <> ppr lbl <> ptext (sLit ", ") <> pprLabelType' platform lbl else empty pprLabel :: Platform -> CLabel -> SDoc diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs index d2f1b42ac3..f1db2436bf 100644 --- a/compiler/GHC/Driver/Session.hs +++ b/compiler/GHC/Driver/Session.hs @@ -132,7 +132,6 @@ module GHC.Driver.Session ( sGhcWithNativeCodeGen, sGhcWithSMP, sGhcRTSWays, - sTablesNextToCode, sLibFFI, sGhcThreaded, sGhcDebugged, @@ -151,7 +150,6 @@ module GHC.Driver.Session ( opt_L, opt_P, opt_F, opt_c, opt_cxx, opt_a, opt_l, opt_i, opt_P_signature, opt_windres, opt_lo, opt_lc, opt_lcc, - tablesNextToCode, -- ** Manipulating DynFlags addPluginModuleName, @@ -993,9 +991,6 @@ opt_lc dflags= toolSettings_opt_lc $ toolSettings dflags opt_i :: DynFlags -> [String] opt_i dflags= toolSettings_opt_i $ toolSettings dflags -tablesNextToCode :: DynFlags -> Bool -tablesNextToCode = platformMisc_tablesNextToCode . platformMisc - -- | The directory for this version of ghc in the user's app directory -- (typically something like @~/.ghc/x86_64-linux-7.6.3@) -- diff --git a/compiler/GHC/Settings.hs b/compiler/GHC/Settings.hs index 6223e48704..354fa15e4d 100644 --- a/compiler/GHC/Settings.hs +++ b/compiler/GHC/Settings.hs @@ -59,7 +59,6 @@ module GHC.Settings , sGhcWithNativeCodeGen , sGhcWithSMP , sGhcRTSWays - , sTablesNextToCode , sLibFFI , sGhcThreaded , sGhcDebugged @@ -268,8 +267,6 @@ sGhcWithSMP :: Settings -> Bool sGhcWithSMP = platformMisc_ghcWithSMP . sPlatformMisc sGhcRTSWays :: Settings -> String sGhcRTSWays = platformMisc_ghcRTSWays . sPlatformMisc -sTablesNextToCode :: Settings -> Bool -sTablesNextToCode = platformMisc_tablesNextToCode . sPlatformMisc sLibFFI :: Settings -> Bool sLibFFI = platformMisc_libFFI . sPlatformMisc sGhcThreaded :: Settings -> Bool diff --git a/compiler/GHC/Settings/IO.hs b/compiler/GHC/Settings/IO.hs index a3478f4497..956b28d270 100644 --- a/compiler/GHC/Settings/IO.hs +++ b/compiler/GHC/Settings/IO.hs @@ -78,7 +78,6 @@ initSettings top_dir = do getBooleanSetting key = either pgmError pure $ getBooleanSetting0 settingsFile mySettings key targetPlatformString <- getSetting "target platform string" - tablesNextToCode <- getBooleanSetting "Tables next to code" myExtraGccViaCFlags <- getSetting "GCC extra via C opts" -- On Windows, mingw is distributed with GHC, -- so we look in TopDir/../mingw/bin, @@ -220,7 +219,6 @@ initSettings top_dir = do , platformMisc_ghcWithNativeCodeGen = ghcWithNativeCodeGen , platformMisc_ghcWithSMP = ghcWithSMP , platformMisc_ghcRTSWays = ghcRTSWays - , platformMisc_tablesNextToCode = tablesNextToCode , platformMisc_libFFI = useLibFFI , platformMisc_ghcThreaded = ghcThreaded , platformMisc_ghcDebugged = ghcDebugged diff --git a/compiler/GHC/StgToCmm/Bind.hs b/compiler/GHC/StgToCmm/Bind.hs index 5402b6239b..2217724922 100644 --- a/compiler/GHC/StgToCmm/Bind.hs +++ b/compiler/GHC/StgToCmm/Bind.hs @@ -552,7 +552,7 @@ mkSlowEntryCode bndr cl_info arg_regs -- function closure is already in `Node' platform <- getPlatform let node = idToReg platform (NonVoid bndr) slow_lbl = closureSlowEntryLabel cl_info - fast_lbl = closureLocalEntryLabel dflags cl_info + fast_lbl = closureLocalEntryLabel platform cl_info -- mkDirectJump does not clobber `Node' containing function closure jump = mkJump dflags NativeNodeCall (mkLblExpr fast_lbl) @@ -727,7 +727,7 @@ link_caf node = do -- see Note [atomic CAF entry] in rts/sm/Storage.c ; updfr <- getUpdFrameOff - ; let target = entryCode dflags (closureInfoPtr dflags (CmmReg (CmmLocal node))) + ; let target = entryCode platform (closureInfoPtr dflags (CmmReg (CmmLocal node))) ; emit =<< mkCmmIfThen (cmmEqWord platform (CmmReg (CmmLocal bh)) (zeroExpr platform)) -- re-enter the CAF diff --git a/compiler/GHC/StgToCmm/Closure.hs b/compiler/GHC/StgToCmm/Closure.hs index 40ff161819..b21277641b 100644 --- a/compiler/GHC/StgToCmm/Closure.hs +++ b/compiler/GHC/StgToCmm/Closure.hs @@ -65,6 +65,7 @@ module GHC.StgToCmm.Closure ( #include "HsVersions.h" import GHC.Prelude +import GHC.Platform import GHC.Stg.Syntax import GHC.Runtime.Heap.Layout @@ -511,7 +512,7 @@ getCallMethod dflags name id (LFReEntrant _ arity _ _) n_args _v_args _cg_loc -- See Note [Evaluating functions with profiling] in rts/Apply.cmm = ASSERT( arity /= 0 ) ReturnIt | n_args < arity = SlowCall -- Not enough args - | otherwise = DirectEntry (enterIdLabel dflags name (idCafInfo id)) arity + | otherwise = DirectEntry (enterIdLabel (targetPlatform dflags) name (idCafInfo id)) arity getCallMethod _ _name _ LFUnlifted n_args _v_args _cg_loc _self_loop_info = ASSERT( n_args == 0 ) ReturnIt @@ -781,10 +782,10 @@ staticClosureLabel = toClosureLbl . closureInfoLabel closureSlowEntryLabel :: ClosureInfo -> CLabel closureSlowEntryLabel = toSlowEntryLbl . closureInfoLabel -closureLocalEntryLabel :: DynFlags -> ClosureInfo -> CLabel -closureLocalEntryLabel dflags - | tablesNextToCode dflags = toInfoLbl . closureInfoLabel - | otherwise = toEntryLbl . closureInfoLabel +closureLocalEntryLabel :: Platform -> ClosureInfo -> CLabel +closureLocalEntryLabel platform + | platformTablesNextToCode platform = toInfoLbl . closureInfoLabel + | otherwise = toEntryLbl . closureInfoLabel mkClosureInfoTableLabel :: DynFlags -> Id -> LambdaFormInfo -> CLabel mkClosureInfoTableLabel dflags id lf_info @@ -821,22 +822,26 @@ thunkEntryLabel dflags _thunk_id _ (ApThunk arity) upd_flag thunkEntryLabel dflags _thunk_id _ (SelectorThunk offset) upd_flag = enterSelectorLabel dflags upd_flag offset thunkEntryLabel dflags thunk_id c _ _ - = enterIdLabel dflags thunk_id c + = enterIdLabel (targetPlatform dflags) thunk_id c enterApLabel :: DynFlags -> Bool -> Arity -> CLabel enterApLabel dflags is_updatable arity - | tablesNextToCode dflags = mkApInfoTableLabel dflags is_updatable arity - | otherwise = mkApEntryLabel dflags is_updatable arity + | platformTablesNextToCode platform = mkApInfoTableLabel dflags is_updatable arity + | otherwise = mkApEntryLabel dflags is_updatable arity + where + platform = targetPlatform dflags enterSelectorLabel :: DynFlags -> Bool -> WordOff -> CLabel enterSelectorLabel dflags upd_flag offset - | tablesNextToCode dflags = mkSelectorInfoLabel dflags upd_flag offset - | otherwise = mkSelectorEntryLabel dflags upd_flag offset + | platformTablesNextToCode platform = mkSelectorInfoLabel dflags upd_flag offset + | otherwise = mkSelectorEntryLabel dflags upd_flag offset + where + platform = targetPlatform dflags -enterIdLabel :: DynFlags -> Name -> CafInfo -> CLabel -enterIdLabel dflags id c - | tablesNextToCode dflags = mkInfoTableLabel id c - | otherwise = mkEntryLabel id c +enterIdLabel :: Platform -> Name -> CafInfo -> CLabel +enterIdLabel platform id c + | platformTablesNextToCode platform = mkInfoTableLabel id c + | otherwise = mkEntryLabel id c -------------------------------------- diff --git a/compiler/GHC/StgToCmm/Expr.hs b/compiler/GHC/StgToCmm/Expr.hs index 164348895d..0ff9db404c 100644 --- a/compiler/GHC/StgToCmm/Expr.hs +++ b/compiler/GHC/StgToCmm/Expr.hs @@ -1007,6 +1007,7 @@ cgIdApp fun_id args = do emitEnter :: CmmExpr -> FCode ReturnKind emitEnter fun = do { dflags <- getDynFlags + ; platform <- getPlatform ; adjustHpBackwards ; sequel <- getSequel ; updfr_off <- getUpdFrameOff @@ -1020,7 +1021,7 @@ emitEnter fun = do -- Right now, we do what the old codegen did, and omit the tag -- test, just generating an enter. Return -> do - { let entry = entryCode dflags $ closureInfoPtr dflags $ CmmReg nodeReg + { let entry = entryCode platform $ closureInfoPtr dflags $ CmmReg nodeReg ; emit $ mkJump dflags NativeNodeCall entry [cmmUntag dflags fun] updfr_off ; return AssignedDirectly @@ -1062,7 +1063,7 @@ emitEnter fun = do -- refer to fun via nodeReg after the copyout, to avoid having -- both live simultaneously; this sometimes enables fun to be -- inlined in the RHS of the R1 assignment. - ; let entry = entryCode dflags (closureInfoPtr dflags (CmmReg nodeReg)) + ; let entry = entryCode platform (closureInfoPtr dflags (CmmReg nodeReg)) the_call = toCall entry (Just lret) updfr_off off outArgs regs ; tscope <- getTickScope ; emit $ diff --git a/compiler/GHC/StgToCmm/Layout.hs b/compiler/GHC/StgToCmm/Layout.hs index ce04371ce2..646f4fa1d9 100644 --- a/compiler/GHC/StgToCmm/Layout.hs +++ b/compiler/GHC/StgToCmm/Layout.hs @@ -86,7 +86,7 @@ emitReturn results Return -> do { adjustHpBackwards ; let e = CmmLoad (CmmStackSlot Old updfr_off) (gcWord platform) - ; emit (mkReturn dflags (entryCode dflags e) results updfr_off) + ; emit (mkReturn dflags (entryCode platform e) results updfr_off) } AssignTo regs adjust -> do { when adjust adjustHpBackwards @@ -222,7 +222,7 @@ slowCall fun stg_args fast_code <- getCode $ emitCall (NativeNodeCall, NativeReturn) - (entryCode dflags fun_iptr) + (entryCode platform fun_iptr) (nonVArgs ((P,Just funv):argsreps)) slow_lbl <- newBlockId |