summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorIan Lynagh <ian@well-typed.com>2012-08-06 22:51:28 +0100
committerIan Lynagh <ian@well-typed.com>2012-08-06 22:51:28 +0100
commite6ef5ab66f51a8b821a4ae8646faca19cf600d94 (patch)
tree0ac8f5178caa80f1fabc3da22e46db8cb19a553a
parent8e7fb28fc89eb9b99c747698f41995c269cd1090 (diff)
downloadhaskell-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.hs25
-rw-r--r--compiler/cmm/CmmOpt.hs11
-rw-r--r--compiler/cmm/CmmParse.y7
-rw-r--r--compiler/cmm/CmmPipeline.hs3
-rw-r--r--compiler/codeGen/CgClosure.lhs11
-rw-r--r--compiler/codeGen/CgCon.lhs7
-rw-r--r--compiler/codeGen/CgInfoTbls.hs24
-rw-r--r--compiler/codeGen/CgTailCall.lhs9
-rw-r--r--compiler/codeGen/ClosureInfo.lhs37
-rw-r--r--compiler/codeGen/StgCmmBind.hs7
-rw-r--r--compiler/codeGen/StgCmmClosure.hs59
-rw-r--r--compiler/codeGen/StgCmmExpr.hs7
-rw-r--r--compiler/codeGen/StgCmmLayout.hs14
-rw-r--r--compiler/main/DynFlags.hs10
-rw-r--r--compiler/main/StaticFlagParser.hs12
-rw-r--r--compiler/main/StaticFlags.hs10
-rw-r--r--compiler/main/SysTools.lhs16
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}