diff options
author | Ian Lynagh <ian@well-typed.com> | 2012-08-06 22:51:28 +0100 |
---|---|---|
committer | Ian Lynagh <ian@well-typed.com> | 2012-08-06 22:51:28 +0100 |
commit | e6ef5ab66f51a8b821a4ae8646faca19cf600d94 (patch) | |
tree | 0ac8f5178caa80f1fabc3da22e46db8cb19a553a | |
parent | 8e7fb28fc89eb9b99c747698f41995c269cd1090 (diff) | |
download | haskell-e6ef5ab66f51a8b821a4ae8646faca19cf600d94.tar.gz |
Make tablesNextToCode "dynamic"
This is a bit odd by itself, but it's a stepping stone on the way to
putting "target unregisterised" into the settings file.
-rw-r--r-- | compiler/cmm/CmmInfo.hs | 25 | ||||
-rw-r--r-- | compiler/cmm/CmmOpt.hs | 11 | ||||
-rw-r--r-- | compiler/cmm/CmmParse.y | 7 | ||||
-rw-r--r-- | compiler/cmm/CmmPipeline.hs | 3 | ||||
-rw-r--r-- | compiler/codeGen/CgClosure.lhs | 11 | ||||
-rw-r--r-- | compiler/codeGen/CgCon.lhs | 7 | ||||
-rw-r--r-- | compiler/codeGen/CgInfoTbls.hs | 24 | ||||
-rw-r--r-- | compiler/codeGen/CgTailCall.lhs | 9 | ||||
-rw-r--r-- | compiler/codeGen/ClosureInfo.lhs | 37 | ||||
-rw-r--r-- | compiler/codeGen/StgCmmBind.hs | 7 | ||||
-rw-r--r-- | compiler/codeGen/StgCmmClosure.hs | 59 | ||||
-rw-r--r-- | compiler/codeGen/StgCmmExpr.hs | 7 | ||||
-rw-r--r-- | compiler/codeGen/StgCmmLayout.hs | 14 | ||||
-rw-r--r-- | compiler/main/DynFlags.hs | 10 | ||||
-rw-r--r-- | compiler/main/StaticFlagParser.hs | 12 | ||||
-rw-r--r-- | compiler/main/StaticFlags.hs | 10 | ||||
-rw-r--r-- | compiler/main/SysTools.lhs | 16 |
17 files changed, 139 insertions, 130 deletions
diff --git a/compiler/cmm/CmmInfo.hs b/compiler/cmm/CmmInfo.hs index 7bdaf5aaca..29affaef0b 100644 --- a/compiler/cmm/CmmInfo.hs +++ b/compiler/cmm/CmmInfo.hs @@ -27,7 +27,6 @@ import Maybes import Constants import DynFlags import Panic -import StaticFlags import UniqSupply import MonadUtils import Util @@ -88,7 +87,7 @@ cmmToRawCmm dflags cmms -- * The SRT slot is only there if there is SRT info to record mkInfoTable :: DynFlags -> CmmDecl -> UniqSM [RawCmmDecl] -mkInfoTable _ (CmmData sec dat) +mkInfoTable _ (CmmData sec dat) = return [CmmData sec dat] mkInfoTable dflags proc@(CmmProc infos entry_lbl blocks) @@ -96,7 +95,7 @@ mkInfoTable dflags proc@(CmmProc infos entry_lbl 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 + | not (tablesNextToCode dflags) = case topInfoTable proc of -- must be at most one -- no info table Nothing -> @@ -106,8 +105,8 @@ mkInfoTable dflags proc@(CmmProc infos entry_lbl blocks) (top_decls, (std_info, extra_bits)) <- mkInfoTableContents dflags info Nothing let - rel_std_info = map (makeRelativeRefTo info_lbl) std_info - rel_extra_bits = map (makeRelativeRefTo info_lbl) extra_bits + rel_std_info = map (makeRelativeRefTo dflags info_lbl) std_info + rel_extra_bits = map (makeRelativeRefTo dflags info_lbl) extra_bits -- case blocks of ListGraph [] -> @@ -143,8 +142,8 @@ mkInfoTable dflags proc@(CmmProc infos entry_lbl blocks) mkInfoTableContents dflags itbl Nothing let info_lbl = cit_lbl itbl - rel_std_info = map (makeRelativeRefTo info_lbl) std_info - rel_extra_bits = map (makeRelativeRefTo info_lbl) extra_bits + rel_std_info = map (makeRelativeRefTo dflags info_lbl) std_info + rel_extra_bits = map (makeRelativeRefTo dflags info_lbl) extra_bits -- return (top_decls, (lbl, Statics info_lbl $ map CmmStaticLit $ reverse rel_extra_bits ++ rel_std_info)) @@ -267,15 +266,15 @@ mkSRTLit (C_SRT lbl off bitmap) = ([cmmLabelOffW lbl off], bitmap) -- 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 :: CLabel -> CmmLit -> CmmLit +makeRelativeRefTo :: DynFlags -> CLabel -> CmmLit -> CmmLit -makeRelativeRefTo info_lbl (CmmLabel lbl) - | tablesNextToCode +makeRelativeRefTo dflags info_lbl (CmmLabel lbl) + | tablesNextToCode dflags = CmmLabelDiffOff lbl info_lbl 0 -makeRelativeRefTo info_lbl (CmmLabelOff lbl off) - | tablesNextToCode +makeRelativeRefTo dflags info_lbl (CmmLabelOff lbl off) + | tablesNextToCode dflags = CmmLabelDiffOff lbl info_lbl off -makeRelativeRefTo _ lit = lit +makeRelativeRefTo _ _ lit = lit ------------------------------------------------------------------------- diff --git a/compiler/cmm/CmmOpt.hs b/compiler/cmm/CmmOpt.hs index 09cbf5045d..5f208244f8 100644 --- a/compiler/cmm/CmmOpt.hs +++ b/compiler/cmm/CmmOpt.hs @@ -21,7 +21,6 @@ import OldPprCmm import CmmNode (wrapRecExp) import CmmUtils import DynFlags -import StaticFlags import CLabel import UniqFM @@ -672,10 +671,10 @@ exactLog2 x_ except factorial, but what the hell. -} -cmmLoopifyForC :: RawCmmDecl -> RawCmmDecl +cmmLoopifyForC :: DynFlags -> RawCmmDecl -> RawCmmDecl -- XXX: revisit if we actually want to do this -- cmmLoopifyForC p@(CmmProc Nothing _ _) = p -- only if there's an info table, ignore case alts -cmmLoopifyForC (CmmProc infos entry_lbl +cmmLoopifyForC dflags (CmmProc infos entry_lbl (ListGraph blocks@(BasicBlock top_id _ : _))) = -- pprTrace "jump_lbl" (ppr jump_lbl <+> ppr entry_lbl) $ CmmProc infos entry_lbl (ListGraph blocks') @@ -686,10 +685,10 @@ cmmLoopifyForC (CmmProc infos entry_lbl = CmmBranch top_id do_stmt stmt = stmt - jump_lbl | tablesNextToCode = toInfoLbl entry_lbl - | otherwise = entry_lbl + jump_lbl | tablesNextToCode dflags = toInfoLbl entry_lbl + | otherwise = entry_lbl -cmmLoopifyForC top = top +cmmLoopifyForC _ top = top -- ----------------------------------------------------------------------------- -- Utils diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y index f14aa9c987..cd8dc6c711 100644 --- a/compiler/cmm/CmmParse.y +++ b/compiler/cmm/CmmParse.y @@ -656,11 +656,11 @@ exprOp name args_code = do exprMacros :: DynFlags -> UniqFM ([CmmExpr] -> CmmExpr) exprMacros dflags = listToUFM [ - ( fsLit "ENTRY_CODE", \ [x] -> entryCode x ), + ( fsLit "ENTRY_CODE", \ [x] -> entryCode dflags x ), ( fsLit "INFO_PTR", \ [x] -> closureInfoPtr x ), ( fsLit "STD_INFO", \ [x] -> infoTable dflags x ), ( fsLit "FUN_INFO", \ [x] -> funInfoTable dflags x ), - ( fsLit "GET_ENTRY", \ [x] -> entryCode (closureInfoPtr x) ), + ( fsLit "GET_ENTRY", \ [x] -> entryCode dflags (closureInfoPtr x) ), ( fsLit "GET_STD_INFO", \ [x] -> infoTable dflags (closureInfoPtr x) ), ( fsLit "GET_FUN_INFO", \ [x] -> funInfoTable dflags (closureInfoPtr x) ), ( fsLit "INFO_TYPE", \ [x] -> infoTableClosureType dflags x ), @@ -932,13 +932,14 @@ doStore rep addr_code val_code -- Return an unboxed tuple. emitRetUT :: [(CgRep,CmmExpr)] -> Code emitRetUT args = do + dflags <- getDynFlags tickyUnboxedTupleReturn (length args) -- TICK (sp, stmts, live) <- pushUnboxedTuple 0 args emitSimultaneously stmts -- NB. the args might overlap with the stack slots -- or regs that we assign to, so better use -- simultaneous assignments here (#3546) when (sp /= 0) $ stmtC (CmmAssign spReg (cmmRegOffW spReg (-sp))) - stmtC $ CmmJump (entryCode (CmmLoad (cmmRegOffW spReg sp) bWord)) (Just live) + stmtC $ CmmJump (entryCode dflags (CmmLoad (cmmRegOffW spReg sp) bWord)) (Just live) -- ----------------------------------------------------------------------------- -- If-then-else and boolean expressions diff --git a/compiler/cmm/CmmPipeline.hs b/compiler/cmm/CmmPipeline.hs index f53135384c..e86374b264 100644 --- a/compiler/cmm/CmmPipeline.hs +++ b/compiler/cmm/CmmPipeline.hs @@ -25,7 +25,6 @@ import ErrUtils import HscTypes import Control.Monad import Outputable -import StaticFlags ----------------------------------------------------------------------------- -- | Top level driver for C-- pipeline @@ -161,7 +160,7 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}}) -- label to put on info tables for basic blocks that are not -- the entry point. splitting_proc_points = hscTarget dflags /= HscAsm - || not tablesNextToCode + || not (tablesNextToCode dflags) runUniqSM :: UniqSM a -> IO a runUniqSM m = do diff --git a/compiler/codeGen/CgClosure.lhs b/compiler/codeGen/CgClosure.lhs index 7229fbdfc2..053314b966 100644 --- a/compiler/codeGen/CgClosure.lhs +++ b/compiler/codeGen/CgClosure.lhs @@ -288,7 +288,8 @@ closureCodeBody _binder_info cl_info cc args body ; setTickyCtrLabel ticky_ctr_lbl $ do -- Emit the slow-entry code - { reg_save_code <- mkSlowEntryCode cl_info reg_args + { dflags <- getDynFlags + ; reg_save_code <- mkSlowEntryCode dflags cl_info reg_args -- Emit the main entry code ; blks <- forkProc $ @@ -339,13 +340,13 @@ The slow entry point is used in two places: (b) returning from a heap-check failure \begin{code} -mkSlowEntryCode :: ClosureInfo -> [(Id,GlobalReg)] -> FCode CmmStmts +mkSlowEntryCode :: DynFlags -> ClosureInfo -> [(Id,GlobalReg)] -> FCode CmmStmts -- If this function doesn't have a specialised ArgDescr, we need -- to generate the function's arg bitmap, slow-entry code, and -- register-save code for the heap-check failure -- Here, we emit the slow-entry code, and -- return the register-save assignments -mkSlowEntryCode cl_info reg_args +mkSlowEntryCode dflags cl_info reg_args | Just (_, ArgGen _) <- closureFunInfo cl_info = do { emitSimpleProc slow_lbl (emitStmts load_stmts) ; return save_stmts } @@ -378,7 +379,7 @@ mkSlowEntryCode cl_info reg_args stk_adj_pop = CmmAssign spReg (cmmRegOffW spReg final_stk_offset) stk_adj_push = CmmAssign spReg (cmmRegOffW spReg (- final_stk_offset)) live_regs = Just $ map snd reps_w_regs - jump_to_entry = CmmJump (mkLblExpr (entryLabelFromCI cl_info)) live_regs + jump_to_entry = CmmJump (mkLblExpr (entryLabelFromCI dflags cl_info)) live_regs \end{code} @@ -599,7 +600,7 @@ link_caf cl_info _is_upd = do -- re-enter R1. Doing this directly is slightly dodgy; we're -- assuming lots of things, like the stack pointer hasn't -- moved since we entered the CAF. - let target = entryCode (closureInfoPtr (CmmReg nodeReg)) in + let target = entryCode dflags (closureInfoPtr (CmmReg nodeReg)) in stmtC (CmmJump target $ Just [node]) ; returnFC hp_rel } diff --git a/compiler/codeGen/CgCon.lhs b/compiler/codeGen/CgCon.lhs index 86e6ff8589..15347de060 100644 --- a/compiler/codeGen/CgCon.lhs +++ b/compiler/codeGen/CgCon.lhs @@ -323,7 +323,7 @@ cgReturnDataCon con amodes = do if isUnboxedTupleCon con then returnUnboxedTuple amodes -- when profiling we can't shortcut here, we have to enter the closure -- for it to be marked as "used" for LDV profiling. - else if dopt Opt_SccProfilingOn dflags then build_it_then enter_it + else if dopt Opt_SccProfilingOn dflags then build_it_then (enter_it dflags) else ASSERT( amodes `lengthIs` dataConRepRepArity con ) do { EndOfBlockInfo _ sequel <- getEndOfBlockInfo ; case sequel of @@ -352,8 +352,9 @@ cgReturnDataCon con amodes = do } where node_live = Just [node] - enter_it = stmtsC [ CmmAssign nodeReg (cmmUntag (CmmReg nodeReg)), - CmmJump (entryCode $ closureInfoPtr $ CmmReg nodeReg) + enter_it dflags + = stmtsC [ CmmAssign nodeReg (cmmUntag (CmmReg nodeReg)), + CmmJump (entryCode dflags $ closureInfoPtr $ CmmReg nodeReg) node_live ] jump_to lbl = stmtC $ CmmJump (CmmLit lbl) node_live diff --git a/compiler/codeGen/CgInfoTbls.hs b/compiler/codeGen/CgInfoTbls.hs index 133d78d371..3f8e6c0222 100644 --- a/compiler/codeGen/CgInfoTbls.hs +++ b/compiler/codeGen/CgInfoTbls.hs @@ -42,7 +42,6 @@ import OldCmm import CLabel import Name import Unique -import StaticFlags import Constants import DynFlags @@ -61,9 +60,10 @@ import Outputable emitClosureCodeAndInfoTable :: ClosureInfo -> [CmmFormal] -> CgStmts -> Code emitClosureCodeAndInfoTable cl_info args body - = do { blks <- cgStmtsToBlocks body + = do { dflags <- getDynFlags + ; blks <- cgStmtsToBlocks body ; info <- mkCmmInfo cl_info - ; emitInfoTableAndCode (entryLabelFromCI cl_info) info args blks } + ; emitInfoTableAndCode (entryLabelFromCI dflags cl_info) info args blks } -- Convert from 'ClosureInfo' to 'CmmInfo'. -- Not used for return points. (The 'smRepClosureTypeInt' call would panic.) @@ -234,8 +234,9 @@ emitAlgReturnTarget name branches mb_deflt fam_sz -------------------------------- emitReturnInstr :: Maybe [GlobalReg] -> Code emitReturnInstr live - = do { info_amode <- getSequelAmode - ; stmtC (CmmJump (entryCode info_amode) live) } + = do { dflags <- getDynFlags + ; info_amode <- getSequelAmode + ; stmtC (CmmJump (entryCode dflags info_amode) live) } ----------------------------------------------------------------------------- -- @@ -280,11 +281,12 @@ closureInfoPtr :: CmmExpr -> CmmExpr -- Takes a closure pointer and returns the info table pointer closureInfoPtr e = CmmLoad e bWord -entryCode :: CmmExpr -> CmmExpr +entryCode :: DynFlags -> CmmExpr -> CmmExpr -- Takes an info pointer (the first word of a closure) -- and returns its entry code -entryCode e | tablesNextToCode = e - | otherwise = CmmLoad e bWord +entryCode dflags e + | tablesNextToCode dflags = e + | otherwise = CmmLoad e bWord getConstrTag :: DynFlags -> CmmExpr -> CmmExpr -- Takes a closure pointer, and return the *zero-indexed* @@ -309,8 +311,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 = cmmOffsetB info_ptr (- stdInfoTableSizeB dflags) - | otherwise = cmmOffsetW info_ptr 1 -- Past the entry code pointer + | tablesNextToCode dflags = cmmOffsetB info_ptr (- stdInfoTableSizeB dflags) + | otherwise = cmmOffsetW info_ptr 1 -- Past the entry code pointer infoTableConstrTag :: DynFlags -> CmmExpr -> CmmExpr -- Takes an info table pointer (from infoTable) and returns the constr tag @@ -342,7 +344,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 + | tablesNextToCode dflags = cmmOffsetB info_ptr (- stdInfoTableSizeB dflags - sIZEOF_StgFunInfoExtraRev) | otherwise = cmmOffsetW info_ptr (1 + stdInfoTableSizeW dflags) diff --git a/compiler/codeGen/CgTailCall.lhs b/compiler/codeGen/CgTailCall.lhs index ee4144800a..6f98e4a09c 100644 --- a/compiler/codeGen/CgTailCall.lhs +++ b/compiler/codeGen/CgTailCall.lhs @@ -105,9 +105,10 @@ performTailCall fun_info arg_amodes pending_assts -- to make the heap check easier. The tail-call sequence -- is very similar to returning an unboxed tuple, so we -- share some code. - do { (final_sp, arg_assts, live) <- pushUnboxedTuple join_sp arg_amodes + do { dflags <- getDynFlags + ; (final_sp, arg_assts, live) <- pushUnboxedTuple join_sp arg_amodes ; emitSimultaneously (pending_assts `plusStmts` arg_assts) - ; let lbl = enterReturnPtLabel (idUnique (cgIdInfoId fun_info)) + ; let lbl = enterReturnPtLabel dflags (idUnique (cgIdInfoId fun_info)) ; doFinalJump final_sp True $ jumpToLbl lbl (Just live) } | otherwise @@ -126,7 +127,7 @@ performTailCall fun_info arg_amodes pending_assts -- Node must always point to things we enter EnterIt -> do { emitSimultaneously (node_asst `plusStmts` pending_assts) - ; let target = entryCode (closureInfoPtr (CmmReg nodeReg)) + ; let target = entryCode dflags (closureInfoPtr (CmmReg nodeReg)) enterClosure = stmtC (CmmJump target node_live) -- If this is a scrutinee -- let's check if the closure is a constructor @@ -207,7 +208,7 @@ performTailCall fun_info arg_amodes pending_assts -- No, enter the closure. ; enterClosure ; labelC is_constr - ; stmtC (CmmJump (entryCode $ + ; stmtC (CmmJump (entryCode dflags $ CmmLit (CmmLabel lbl)) (Just [node])) } {- diff --git a/compiler/codeGen/ClosureInfo.lhs b/compiler/codeGen/ClosureInfo.lhs index b71a722c38..d3db24ce4c 100644 --- a/compiler/codeGen/ClosureInfo.lhs +++ b/compiler/codeGen/ClosureInfo.lhs @@ -83,7 +83,6 @@ import SMRep import CLabel import Cmm import Unique -import StaticFlags import Var import Id import IdInfo @@ -658,11 +657,11 @@ getCallMethod dflags _ _ lf_info _ -- fetched since we allocated it. EnterIt -getCallMethod _ name caf (LFReEntrant _ arity _ _) n_args +getCallMethod dflags name caf (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 name caf) arity + | otherwise = DirectEntry (enterIdLabel dflags name caf) arity getCallMethod dflags _ _ (LFCon con) n_args -- when profiling, we must always enter a closure when we use it, so @@ -716,11 +715,11 @@ getCallMethod _ _ _ LFBlackHole _ -- been updated, but we don't know with -- what, so we slow call it -getCallMethod _ name _ (LFLetNoEscape 0) _ - = JumpToIt (enterReturnPtLabel (nameUnique name)) +getCallMethod dflags name _ (LFLetNoEscape 0) _ + = JumpToIt (enterReturnPtLabel dflags (nameUnique name)) -getCallMethod _ name _ (LFLetNoEscape arity) n_args - | n_args == arity = DirectEntry (enterReturnPtLabel (nameUnique name)) arity +getCallMethod dflags name _ (LFLetNoEscape arity) n_args + | n_args == arity = DirectEntry (enterReturnPtLabel dflags (nameUnique name)) arity | otherwise = pprPanic "let-no-escape: " (ppr name <+> ppr arity) @@ -971,10 +970,10 @@ Label generation. infoTableLabelFromCI :: ClosureInfo -> CLabel infoTableLabelFromCI = fst . labelsFromCI -entryLabelFromCI :: ClosureInfo -> CLabel -entryLabelFromCI ci - | tablesNextToCode = info_lbl - | otherwise = entry_lbl +entryLabelFromCI :: DynFlags -> ClosureInfo -> CLabel +entryLabelFromCI dflags ci + | tablesNextToCode dflags = info_lbl + | otherwise = entry_lbl where (info_lbl, entry_lbl) = labelsFromCI ci labelsFromCI :: ClosureInfo -> (CLabel, CLabel) -- (Info, Entry) @@ -1039,15 +1038,15 @@ enterSelectorLabel upd_flag offset | otherwise = mkSelectorEntryLabel upd_flag offset -} -enterIdLabel :: Name -> CafInfo -> CLabel -enterIdLabel id - | tablesNextToCode = mkInfoTableLabel id - | otherwise = mkEntryLabel id +enterIdLabel :: DynFlags -> Name -> CafInfo -> CLabel +enterIdLabel dflags id + | tablesNextToCode dflags = mkInfoTableLabel id + | otherwise = mkEntryLabel id -enterReturnPtLabel :: Unique -> CLabel -enterReturnPtLabel name - | tablesNextToCode = mkReturnInfoLabel name - | otherwise = mkReturnPtLabel name +enterReturnPtLabel :: DynFlags -> Unique -> CLabel +enterReturnPtLabel dflags name + | tablesNextToCode dflags = mkReturnInfoLabel name + | otherwise = mkReturnPtLabel name \end{code} diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs index 861c4e33e1..a38078a1c8 100644 --- a/compiler/codeGen/StgCmmBind.hs +++ b/compiler/codeGen/StgCmmBind.hs @@ -466,8 +466,9 @@ mkSlowEntryCode :: ClosureInfo -> [LocalReg] -> FCode () mkSlowEntryCode _ [] = panic "entering a closure with no arguments?" mkSlowEntryCode cl_info arg_regs -- function closure is already in `Node' | Just (_, ArgGen _) <- closureFunInfo cl_info - = do let slow_lbl = closureSlowEntryLabel cl_info - fast_lbl = closureLocalEntryLabel cl_info + = do dflags <- getDynFlags + let slow_lbl = closureSlowEntryLabel cl_info + fast_lbl = closureLocalEntryLabel dflags cl_info -- mkDirectJump does not clobber `Node' containing function closure jump = mkDirectJump (mkLblExpr fast_lbl) (map (CmmReg . CmmLocal) arg_regs) @@ -678,7 +679,7 @@ link_caf _is_upd = do -- re-enter R1. Doing this directly is slightly dodgy; we're -- assuming lots of things, like the stack pointer hasn't -- moved since we entered the CAF. - (let target = entryCode (closureInfoPtr (CmmReg nodeReg)) in + (let target = entryCode dflags (closureInfoPtr (CmmReg nodeReg)) in mkJump target [] updfr) ; return hp_rel } diff --git a/compiler/codeGen/StgCmmClosure.hs b/compiler/codeGen/StgCmmClosure.hs index 7a9c8414ee..2afcb6a8c7 100644 --- a/compiler/codeGen/StgCmmClosure.hs +++ b/compiler/codeGen/StgCmmClosure.hs @@ -76,7 +76,6 @@ import SMRep import Cmm import CLabel -import StaticFlags import Id import IdInfo import DataCon @@ -481,11 +480,11 @@ getCallMethod dflags _name _ lf_info _n_args -- fetched since we allocated it. EnterIt -getCallMethod _ name caf (LFReEntrant _ arity _ _) n_args +getCallMethod dflags name caf (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 name caf) arity + | otherwise = DirectEntry (enterIdLabel dflags name caf) arity getCallMethod _ _name _ LFUnLifted n_args = ASSERT( n_args == 0 ) ReturnIt @@ -515,7 +514,7 @@ getCallMethod dflags name caf (LFThunk _ _ updatable std_form_info is_fun) n_arg | otherwise -- Jump direct to code for single-entry thunks = ASSERT( n_args == 0 ) - DirectEntry (thunkEntryLabel name caf std_form_info updatable) 0 + DirectEntry (thunkEntryLabel dflags name caf std_form_info updatable) 0 getCallMethod _ _name _ (LFUnknown True) _n_args = SlowCall -- might be a function @@ -779,10 +778,10 @@ closureRednCountsLabel = toRednCountsLbl . closureInfoLabel closureSlowEntryLabel :: ClosureInfo -> CLabel closureSlowEntryLabel = toSlowEntryLbl . closureInfoLabel -closureLocalEntryLabel :: ClosureInfo -> CLabel -closureLocalEntryLabel - | tablesNextToCode = toInfoLbl . closureInfoLabel - | otherwise = toEntryLbl . closureInfoLabel +closureLocalEntryLabel :: DynFlags -> ClosureInfo -> CLabel +closureLocalEntryLabel dflags + | tablesNextToCode dflags = toInfoLbl . closureInfoLabel + | otherwise = toEntryLbl . closureInfoLabel mkClosureInfoTableLabel :: Id -> LambdaFormInfo -> CLabel mkClosureInfoTableLabel id lf_info @@ -813,30 +812,30 @@ mkClosureInfoTableLabel id lf_info -- invariants in CorePrep anything else gets eta expanded. -thunkEntryLabel :: Name -> CafInfo -> StandardFormInfo -> Bool -> CLabel +thunkEntryLabel :: DynFlags -> Name -> CafInfo -> StandardFormInfo -> Bool -> CLabel -- thunkEntryLabel is a local help function, not exported. It's used from -- getCallMethod. -thunkEntryLabel _thunk_id _ (ApThunk arity) upd_flag - = enterApLabel upd_flag arity -thunkEntryLabel _thunk_id _ (SelectorThunk offset) upd_flag - = enterSelectorLabel upd_flag offset -thunkEntryLabel thunk_id c _ _ - = enterIdLabel thunk_id c - -enterApLabel :: Bool -> Arity -> CLabel -enterApLabel is_updatable arity - | tablesNextToCode = mkApInfoTableLabel is_updatable arity - | otherwise = mkApEntryLabel is_updatable arity - -enterSelectorLabel :: Bool -> WordOff -> CLabel -enterSelectorLabel upd_flag offset - | tablesNextToCode = mkSelectorInfoLabel upd_flag offset - | otherwise = mkSelectorEntryLabel upd_flag offset - -enterIdLabel :: Name -> CafInfo -> CLabel -enterIdLabel id c - | tablesNextToCode = mkInfoTableLabel id c - | otherwise = mkEntryLabel id c +thunkEntryLabel dflags _thunk_id _ (ApThunk arity) upd_flag + = enterApLabel dflags upd_flag arity +thunkEntryLabel dflags _thunk_id _ (SelectorThunk offset) upd_flag + = enterSelectorLabel dflags upd_flag offset +thunkEntryLabel dflags thunk_id c _ _ + = enterIdLabel dflags thunk_id c + +enterApLabel :: DynFlags -> Bool -> Arity -> CLabel +enterApLabel dflags is_updatable arity + | tablesNextToCode dflags = mkApInfoTableLabel is_updatable arity + | otherwise = mkApEntryLabel is_updatable arity + +enterSelectorLabel :: DynFlags -> Bool -> WordOff -> CLabel +enterSelectorLabel dflags upd_flag offset + | tablesNextToCode dflags = mkSelectorInfoLabel upd_flag offset + | otherwise = mkSelectorEntryLabel upd_flag offset + +enterIdLabel :: DynFlags -> Name -> CafInfo -> CLabel +enterIdLabel dflags id c + | tablesNextToCode dflags = mkInfoTableLabel id c + | otherwise = mkEntryLabel id c -------------------------------------- diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs index 95c61082c0..35533ec933 100644 --- a/compiler/codeGen/StgCmmExpr.hs +++ b/compiler/codeGen/StgCmmExpr.hs @@ -659,7 +659,8 @@ cgTailCall fun_id fun_info args = do emitEnter :: CmmExpr -> FCode ReturnKind emitEnter fun = do - { adjustHpBackwards + { dflags <- getDynFlags + ; adjustHpBackwards ; sequel <- getSequel ; updfr_off <- getUpdFrameOff ; case sequel of @@ -672,7 +673,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 $ closureInfoPtr $ CmmReg nodeReg + { let entry = entryCode dflags $ closureInfoPtr $ CmmReg nodeReg ; emit $ mkForeignJump NativeNodeCall entry [cmmUntag fun] updfr_off ; return AssignedDirectly @@ -714,7 +715,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 (closureInfoPtr (CmmReg nodeReg)) + ; let entry = entryCode dflags (closureInfoPtr (CmmReg nodeReg)) the_call = toCall entry (Just lret) updfr_off off outArgs regs ; emit $ copyout <*> diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs index 8a20411064..4e2b478f77 100644 --- a/compiler/codeGen/StgCmmLayout.hs +++ b/compiler/codeGen/StgCmmLayout.hs @@ -54,7 +54,6 @@ import Name import TyCon ( PrimRep(..) ) import BasicTypes ( RepArity ) import DynFlags -import StaticFlags import Module import Constants @@ -595,11 +594,12 @@ closureInfoPtr :: CmmExpr -> CmmExpr -- Takes a closure pointer and returns the info table pointer closureInfoPtr e = CmmLoad e bWord -entryCode :: CmmExpr -> CmmExpr +entryCode :: DynFlags -> CmmExpr -> CmmExpr -- Takes an info pointer (the first word of a closure) -- and returns its entry code -entryCode e | tablesNextToCode = e - | otherwise = CmmLoad e bWord +entryCode dflags e + | tablesNextToCode dflags = e + | otherwise = CmmLoad e bWord getConstrTag :: DynFlags -> CmmExpr -> CmmExpr -- Takes a closure pointer, and return the *zero-indexed* @@ -624,8 +624,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 = cmmOffsetB info_ptr (- stdInfoTableSizeB dflags) - | otherwise = cmmOffsetW info_ptr 1 -- Past the entry code pointer + | tablesNextToCode dflags = cmmOffsetB info_ptr (- stdInfoTableSizeB dflags) + | otherwise = cmmOffsetW info_ptr 1 -- Past the entry code pointer infoTableConstrTag :: DynFlags -> CmmExpr -> CmmExpr -- Takes an info table pointer (from infoTable) and returns the constr tag @@ -657,7 +657,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 + | tablesNextToCode dflags = cmmOffsetB info_ptr (- stdInfoTableSizeB dflags - sIZEOF_StgFunInfoExtraRev) | otherwise = cmmOffsetW info_ptr (1 + stdInfoTableSizeW dflags) diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index c422980dd8..c528402b7a 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -46,6 +46,7 @@ module DynFlags ( DynLibLoader(..), fFlags, fWarningFlags, fLangFlags, xFlags, wayNames, dynFlagDependencies, + tablesNextToCode, printOutputForUser, printInfoForUser, @@ -881,6 +882,15 @@ defaultObjectTarget | cGhcWithNativeCodeGen == "YES" = HscAsm | otherwise = HscLlvm +-- Derived, not a real option. Determines whether we will be compiling +-- info tables that reside just before the entry code, or with an +-- indirection to the entry code. See TABLES_NEXT_TO_CODE in +-- includes/rts/storage/InfoTables.h. +tablesNextToCode :: DynFlags -> Bool +tablesNextToCode _ = not opt_Unregisterised + && cGhcEnableTablesNextToCode == "YES" + + data DynLibLoader = Deployable | SystemDependent diff --git a/compiler/main/StaticFlagParser.hs b/compiler/main/StaticFlagParser.hs index ddb40268fb..adda6f1505 100644 --- a/compiler/main/StaticFlagParser.hs +++ b/compiler/main/StaticFlagParser.hs @@ -18,7 +18,7 @@ module StaticFlagParser ( #include "HsVersions.h" import qualified StaticFlags as SF -import StaticFlags ( v_opt_C_ready, getWayFlags, tablesNextToCode, WayName(..) +import StaticFlags ( v_opt_C_ready, getWayFlags, WayName(..) , opt_SimplExcessPrecision ) import CmdLineParser import Config @@ -81,14 +81,6 @@ parseStaticFlagsFull flagsAvailable args = do -- see sanity code in staticOpts writeIORef v_opt_C_ready True - -- TABLES_NEXT_TO_CODE affects the info table layout. - -- Be careful to do this *after* all processArgs, - -- because evaluating tablesNextToCode involves looking at the global - -- static flags. Those pesky global variables... - let cg_flags | tablesNextToCode = map (mkGeneralLocated "in cg_flags") - ["-optc-DTABLES_NEXT_TO_CODE"] - | otherwise = [] - -- HACK: -fexcess-precision is both a static and a dynamic flag. If -- the static flag parser has slurped it, we must return it as a -- leftover too. ToDo: make -fexcess-precision dynamic only. @@ -98,7 +90,7 @@ parseStaticFlagsFull flagsAvailable args = do | otherwise = [] when (not (null errs)) $ ghcError $ errorsToGhcException errs - return (excess_prec ++ cg_flags ++ more_leftover ++ leftover, + return (excess_prec ++ more_leftover ++ leftover, warns1 ++ warns2) flagsStatic :: [Flag IO] diff --git a/compiler/main/StaticFlags.hs b/compiler/main/StaticFlags.hs index 79faf1ec2f..f19497cb94 100644 --- a/compiler/main/StaticFlags.hs +++ b/compiler/main/StaticFlags.hs @@ -74,7 +74,6 @@ module StaticFlags ( opt_HistorySize, opt_Unregisterised, v_Ld_inputs, - tablesNextToCode, opt_StubDeadValues, opt_Ticky, @@ -87,7 +86,6 @@ module StaticFlags ( #include "HsVersions.h" -import Config import FastString import Util import Maybes ( firstJusts ) @@ -314,14 +312,6 @@ opt_Static = lookUp (fsLit "-static") opt_Unregisterised :: Bool opt_Unregisterised = lookUp (fsLit "-funregisterised") --- Derived, not a real option. Determines whether we will be compiling --- info tables that reside just before the entry code, or with an --- indirection to the entry code. See TABLES_NEXT_TO_CODE in --- includes/rts/storage/InfoTables.h. -tablesNextToCode :: Bool -tablesNextToCode = not opt_Unregisterised - && cGhcEnableTablesNextToCode == "YES" - -- Include full span info in error messages, instead of just the start position. opt_ErrorSpans :: Bool opt_ErrorSpans = lookUp (fsLit "-ferror-spans") diff --git a/compiler/main/SysTools.lhs b/compiler/main/SysTools.lhs index 0928927888..295aa595e1 100644 --- a/compiler/main/SysTools.lhs +++ b/compiler/main/SysTools.lhs @@ -51,6 +51,7 @@ import Platform import Util import DynFlags import Exception +import StaticFlags import Data.IORef import Control.Monad @@ -217,7 +218,12 @@ initSysTools mbMinusB -- to make that possible, so for now you can't. gcc_prog <- getSetting "C compiler command" gcc_args_str <- getSetting "C compiler flags" - let gcc_args = map Option (words gcc_args_str) + let + -- TABLES_NEXT_TO_CODE affects the info table layout. + tntc_gcc_args + | tablesNextToCode' = ["-DTABLES_NEXT_TO_CODE"] + | otherwise = [] + gcc_args = map Option (words gcc_args_str ++ tntc_gcc_args) ldSupportsCompactUnwind <- getBooleanSetting "ld supports compact unwind" ldSupportsBuildId <- getBooleanSetting "ld supports build-id" ldIsGnuLd <- getBooleanSetting "ld is GNU ld" @@ -316,6 +322,14 @@ initSysTools mbMinusB sOpt_lo = [], sOpt_lc = [] } + +-- Derived, not a real option. Determines whether we will be compiling +-- info tables that reside just before the entry code, or with an +-- indirection to the entry code. See TABLES_NEXT_TO_CODE in +-- includes/rts/storage/InfoTables.h. +tablesNextToCode' :: Bool +tablesNextToCode' = not opt_Unregisterised + && cGhcEnableTablesNextToCode == "YES" \end{code} \begin{code} |