Skip to content

GitLab

GHC
GHC
Commit 229e9fc5 authored by Ian Lynagh's avatar Ian Lynagh
Browse files
Options

Make -fscc-profiling a dynamic flag 

All the flags that 'ways' imply are now dynamic
parent 4b18cc53
Hide whitespace changes
Inline Side-by-side
Showing with 786 additions and 654 deletions
compiler/cmm/CmmInfo.hs
View file @ 229e9fc5
......@@ -24,8 +24,8 @@ import qualified Stream
import Maybes
import Constants
import DynFlags
import Panic
import Platform
import StaticFlags
import UniqSupply
import MonadUtils
......@@ -42,12 +42,12 @@ mkEmptyContInfoTable info_lbl
, cit_prof = NoProfilingInfo
, cit_srt = NoC_SRT }
cmmToRawCmm :: Platform -> Stream IO Old.CmmGroup ()
cmmToRawCmm :: DynFlags -> Stream IO Old.CmmGroup ()
-> IO (Stream IO Old.RawCmmGroup ())
cmmToRawCmm platform cmms
cmmToRawCmm dflags cmms
= do { uniqs <- mkSplitUniqSupply 'i'
; let do_one uniqs cmm = do
case initUs uniqs $ concatMapM (mkInfoTable platform) cmm of
case initUs uniqs $ concatMapM (mkInfoTable dflags) cmm of
(b,uniqs') -> return (uniqs',b)
-- NB. strictness fixes a space leak. DO NOT REMOVE.
; return (Stream.mapAccumL do_one uniqs cmms >> return ())
......@@ -86,16 +86,16 @@ cmmToRawCmm platform cmms
--
-- * The SRT slot is only there if there is SRT info to record
mkInfoTable :: Platform -> CmmDecl -> UniqSM [RawCmmDecl]
mkInfoTable :: DynFlags -> CmmDecl -> UniqSM [RawCmmDecl]
mkInfoTable _ (CmmData sec dat)
= return [CmmData sec dat]
mkInfoTable platform (CmmProc info entry_label blocks)
mkInfoTable dflags (CmmProc info entry_label blocks)
| CmmNonInfoTable <- info -- Code without an info table. Easy.
= return [CmmProc Nothing entry_label blocks]
| CmmInfoTable { cit_lbl = info_lbl } <- info
= do { (top_decls, info_cts) <- mkInfoTableContents platform info Nothing
= do { (top_decls, info_cts) <- mkInfoTableContents dflags info Nothing
; return (top_decls ++
mkInfoTableAndCode info_lbl info_cts
entry_label blocks) }
......@@ -107,20 +107,20 @@ type InfoTableContents = ( [CmmLit] -- The standard part
, [CmmLit] ) -- The "extra bits"
-- These Lits have *not* had mkRelativeTo applied to them
mkInfoTableContents :: Platform
mkInfoTableContents :: DynFlags
-> CmmInfoTable
-> Maybe StgHalfWord -- Override default RTS type tag?
-> UniqSM ([RawCmmDecl], -- Auxiliary top decls
InfoTableContents) -- Info tbl + extra bits
mkInfoTableContents platform
mkInfoTableContents dflags
info@(CmmInfoTable { cit_lbl = info_lbl
, cit_rep = smrep
, cit_prof = prof
, cit_srt = srt })
mb_rts_tag
| RTSRep rts_tag rep <- smrep
= mkInfoTableContents platform info{cit_rep = rep} (Just rts_tag)
= mkInfoTableContents dflags info{cit_rep = rep} (Just rts_tag)
-- Completely override the rts_tag that mkInfoTableContents would
-- otherwise compute, with the rts_tag stored in the RTSRep
-- (which in turn came from a handwritten .cmm file)
......@@ -130,7 +130,7 @@ mkInfoTableContents platform
; let (srt_label, srt_bitmap) = mkSRTLit srt
; (liveness_lit, liveness_data) <- mkLivenessBits frame
; let
std_info = mkStdInfoTable prof_lits rts_tag srt_bitmap liveness_lit
std_info = mkStdInfoTable dflags prof_lits rts_tag srt_bitmap liveness_lit
rts_tag | Just tag <- mb_rts_tag = tag
| null liveness_data = rET_SMALL -- Fits in extra_bits
| otherwise = rET_BIG -- Does not; extra_bits is
......@@ -143,7 +143,7 @@ mkInfoTableContents platform
; let (srt_label, srt_bitmap) = mkSRTLit srt
; (mb_srt_field, mb_layout, extra_bits, ct_data)
<- mk_pieces closure_type srt_label
; let std_info = mkStdInfoTable prof_lits
; let std_info = mkStdInfoTable dflags prof_lits
(mb_rts_tag `orElse` rtsClosureType smrep)
(mb_srt_field `orElse` srt_bitmap)
(mb_layout `orElse` layout)
......@@ -326,13 +326,14 @@ mkLivenessBits liveness
-- so we can't use constant offsets from Constants
mkStdInfoTable
:: (CmmLit,CmmLit) -- Closure type descr and closure descr (profiling)
:: DynFlags
-> (CmmLit,CmmLit) -- Closure type descr and closure descr (profiling)
-> StgHalfWord -- Closure RTS tag
-> StgHalfWord -- SRT length
-> CmmLit -- layout field
-> [CmmLit]
mkStdInfoTable (type_descr, closure_descr) cl_type srt_len layout_lit
mkStdInfoTable dflags (type_descr, closure_descr) cl_type srt_len layout_lit
= -- Parallel revertible-black hole field
prof_info
-- Ticky info (none at present)
......@@ -341,8 +342,8 @@ mkStdInfoTable (type_descr, closure_descr) cl_type srt_len layout_lit
where
prof_info
| opt_SccProfilingOn = [type_descr, closure_descr]
| otherwise = []
| dopt Opt_SccProfilingOn dflags = [type_descr, closure_descr]
| otherwise = []
type_lit = packHalfWordsCLit cl_type srt_len
......
compiler/cmm/CmmLayoutStack.hs
View file @ 229e9fc5
......@@ -23,6 +23,7 @@ import Maybes
import UniqFM
import Util
import DynFlags
import FastString
import Outputable
import Data.Map (Map)
......@@ -103,9 +104,9 @@ instance Outputable StackMap where
text "sm_regs = " <> ppr (eltsUFM sm_regs)
cmmLayoutStack :: ProcPointSet -> ByteOff -> CmmGraph
cmmLayoutStack :: DynFlags -> ProcPointSet -> ByteOff -> CmmGraph
-> UniqSM (CmmGraph, BlockEnv StackMap)
cmmLayoutStack procpoints entry_args
cmmLayoutStack dflags procpoints entry_args
graph0@(CmmGraph { g_entry = entry })
= do
-- pprTrace "cmmLayoutStack" (ppr entry_args) $ return ()
......@@ -118,7 +119,7 @@ cmmLayoutStack procpoints entry_args
layout procpoints liveness entry entry_args
rec_stackmaps rec_high_sp blocks
new_blocks' <- mapM lowerSafeForeignCall new_blocks
new_blocks' <- mapM (lowerSafeForeignCall dflags) new_blocks
-- pprTrace ("Sp HWM") (ppr _final_high_sp) $ return ()
return (ofBlockList entry new_blocks', final_stackmaps)
......@@ -870,8 +871,8 @@ Note the copyOut, which saves the results in the places that L1 is
expecting them (see Note {safe foreign call convention]).
-}
lowerSafeForeignCall :: CmmBlock -> UniqSM CmmBlock
lowerSafeForeignCall block
lowerSafeForeignCall :: DynFlags -> CmmBlock -> UniqSM CmmBlock
lowerSafeForeignCall dflags block
| (entry, middle, CmmForeignCall { .. }) <- blockSplit block
= do
-- Both 'id' and 'new_base' are KindNonPtr because they're
......@@ -881,7 +882,7 @@ lowerSafeForeignCall block
let (caller_save, caller_load) = callerSaveVolatileRegs
load_tso <- newTemp gcWord
load_stack <- newTemp gcWord
let suspend = saveThreadState <*>
let suspend = saveThreadState dflags <*>
caller_save <*>
mkMiddle (callSuspendThread id intrbl)
midCall = mkUnsafeCall tgt res args
......@@ -890,7 +891,7 @@ lowerSafeForeignCall block
-- might now have a different Capability!
mkAssign (CmmGlobal BaseReg) (CmmReg (CmmLocal new_base)) <*>
caller_load <*>
loadThreadState load_tso load_stack
loadThreadState dflags load_tso load_stack
-- Note: The successor must be a procpoint, and we have already split,
-- so we use a jump, not a branch.
succLbl = CmmLit (CmmLabel (infoTblLbl succ))
......
compiler/cmm/CmmParse.y
View file @ 229e9fc5
......@@ -216,12 +216,13 @@ static :: { ExtFCode [CmmStatic] }
(widthInBytes (typeWidth $1) *
fromIntegral $3)] }
| 'CLOSURE' '(' NAME lits ')'
{ do lits <- sequence $4;
return $ map CmmStaticLit $
mkStaticClosure (mkForeignLabel $3 Nothing ForeignLabelInExternalPackage IsData)
{ do { lits <- sequence $4
; dflags <- getDynFlags
; return $ map CmmStaticLit $
mkStaticClosure dflags (mkForeignLabel $3 Nothing ForeignLabelInExternalPackage IsData)
-- mkForeignLabel because these are only used
-- for CHARLIKE and INTLIKE closures in the RTS.
dontCareCCS (map getLit lits) [] [] [] }
dontCareCCS (map getLit lits) [] [] [] } }
-- arrays of closures required for the CHARLIKE & INTLIKE arrays
lits :: { [ExtFCode CmmExpr] }
......@@ -260,9 +261,10 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) }
: 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
-- ptrs, nptrs, closure type, description, type
{% withThisPackage $ \pkg ->
do let prof = profilingInfo $11 $13
do dflags <- getDynFlags
let prof = profilingInfo dflags $11 $13
rep = mkRTSRep (fromIntegral $9) $
mkHeapRep False (fromIntegral $5)
mkHeapRep dflags False (fromIntegral $5)
(fromIntegral $7) Thunk
-- not really Thunk, but that makes the info table
-- we want.
......@@ -275,11 +277,12 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) }
| 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ')'
-- ptrs, nptrs, closure type, description, type, fun type
{% withThisPackage $ \pkg ->
do let prof = profilingInfo $11 $13
do dflags <- getDynFlags
let prof = profilingInfo dflags $11 $13
ty = Fun 0 (ArgSpec (fromIntegral $15))
-- Arity zero, arg_type $15
rep = mkRTSRep (fromIntegral $9) $
mkHeapRep False (fromIntegral $5)
mkHeapRep dflags False (fromIntegral $5)
(fromIntegral $7) ty
return (mkCmmEntryLabel pkg $3,
CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
......@@ -292,11 +295,12 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) }
| 'INFO_TABLE_CONSTR' '(' NAME ',' INT ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
-- ptrs, nptrs, tag, closure type, description, type
{% withThisPackage $ \pkg ->
do let prof = profilingInfo $13 $15
do dflags <- getDynFlags
let prof = profilingInfo dflags $13 $15
ty = Constr (fromIntegral $9) -- Tag
(stringToWord8s $13)
rep = mkRTSRep (fromIntegral $11) $
mkHeapRep False (fromIntegral $5)
mkHeapRep dflags False (fromIntegral $5)
(fromIntegral $7) ty
return (mkCmmEntryLabel pkg $3,
CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
......@@ -310,10 +314,11 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) }
| 'INFO_TABLE_SELECTOR' '(' NAME ',' INT ',' INT ',' STRING ',' STRING ')'
-- selector, closure type, description, type
{% withThisPackage $ \pkg ->
do let prof = profilingInfo $9 $11
do dflags <- getDynFlags
let prof = profilingInfo dflags $9 $11
ty = ThunkSelector (fromIntegral $5)
rep = mkRTSRep (fromIntegral $7) $
mkHeapRep False 0 0 ty
mkHeapRep dflags False 0 0 ty
return (mkCmmEntryLabel pkg $3,
CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
, cit_rep = rep
......@@ -639,8 +644,9 @@ nameToMachOp name =
Just m -> return m
exprOp :: FastString -> [ExtFCode CmmExpr] -> P (ExtFCode CmmExpr)
exprOp name args_code =
case lookupUFM exprMacros name of
exprOp name args_code = do
dflags <- getDynFlags
case lookupUFM (exprMacros dflags) name of
Just f -> return $ do
args <- sequence args_code
return (f args)
......@@ -648,18 +654,18 @@ exprOp name args_code =
mo <- nameToMachOp name
return $ mkMachOp mo args_code
exprMacros :: UniqFM ([CmmExpr] -> CmmExpr)
exprMacros = listToUFM [
exprMacros :: DynFlags -> UniqFM ([CmmExpr] -> CmmExpr)
exprMacros dflags = listToUFM [
( fsLit "ENTRY_CODE", \ [x] -> entryCode x ),
( fsLit "INFO_PTR", \ [x] -> closureInfoPtr x ),
( fsLit "STD_INFO", \ [x] -> infoTable x ),
( fsLit "FUN_INFO", \ [x] -> funInfoTable x ),
( fsLit "STD_INFO", \ [x] -> infoTable dflags x ),
( fsLit "FUN_INFO", \ [x] -> funInfoTable dflags x ),
( fsLit "GET_ENTRY", \ [x] -> entryCode (closureInfoPtr x) ),
( fsLit "GET_STD_INFO", \ [x] -> infoTable (closureInfoPtr x) ),
( fsLit "GET_FUN_INFO", \ [x] -> funInfoTable (closureInfoPtr x) ),
( fsLit "INFO_TYPE", \ [x] -> infoTableClosureType x ),
( fsLit "INFO_PTRS", \ [x] -> infoTablePtrs x ),
( fsLit "INFO_NPTRS", \ [x] -> infoTableNonPtrs 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 ),
( fsLit "INFO_PTRS", \ [x] -> infoTablePtrs dflags x ),
( fsLit "INFO_NPTRS", \ [x] -> infoTableNonPtrs dflags x )
]
-- we understand a subset of C-- primitives:
......@@ -824,15 +830,17 @@ stmtMacros = listToUFM [
]
profilingInfo desc_str ty_str
| not opt_SccProfilingOn = NoProfilingInfo
| otherwise = ProfilingInfo (stringToWord8s desc_str)
(stringToWord8s ty_str)
profilingInfo dflags desc_str ty_str
= if not (dopt Opt_SccProfilingOn dflags)
then NoProfilingInfo
else ProfilingInfo (stringToWord8s desc_str)
(stringToWord8s ty_str)
staticClosure :: PackageId -> FastString -> FastString -> [CmmLit] -> ExtCode
staticClosure pkg cl_label info payload
= code $ emitDataLits (mkCmmDataLabel pkg cl_label) lits
where lits = mkStaticClosure (mkCmmInfoLabel pkg info) dontCareCCS payload [] [] []
= do dflags <- getDynFlags
let lits = mkStaticClosure dflags (mkCmmInfoLabel pkg info) dontCareCCS payload [] [] []
code $ emitDataLits (mkCmmDataLabel pkg cl_label) lits
foreignCall
:: String
......@@ -1036,12 +1044,12 @@ doSwitch mb_range scrut arms deflt
-- The initial environment: we define some constants that the compiler
-- knows about here.
initEnv :: Env
initEnv = listToUFM [
initEnv :: DynFlags -> Env
initEnv dflags = listToUFM [
( fsLit "SIZEOF_StgHeader",
VarN (CmmLit (CmmInt (fromIntegral (fixedHdrSize * wORD_SIZE)) wordWidth) )),
VarN (CmmLit (CmmInt (fromIntegral (fixedHdrSize dflags * wORD_SIZE)) wordWidth) )),
( fsLit "SIZEOF_StgInfoTable",
VarN (CmmLit (CmmInt (fromIntegral stdInfoTableSizeB) wordWidth) ))
VarN (CmmLit (CmmInt (fromIntegral (stdInfoTableSizeB dflags)) wordWidth) ))
]
parseCmmFile :: DynFlags -> FilePath -> IO (Messages, Maybe CmmGroup)
......@@ -1059,7 +1067,7 @@ parseCmmFile dflags filename = do
return ((emptyBag, unitBag msg), Nothing)
POk pst code -> do
st <- initC
let (cmm,_) = runC dflags no_module st (getCmm (unEC code initEnv [] >> return ()))
let (cmm,_) = runC dflags no_module st (getCmm (unEC code (initEnv dflags) [] >> return ()))
let ms = getMessages pst
if (errorsFound dflags ms)
then return (ms, Nothing)
......
compiler/cmm/CmmPipeline.hs
View file @ 229e9fc5
......@@ -72,7 +72,7 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}})
----------- Layout the stack and manifest Sp ---------------
-- (also does: removeDeadAssignments, and lowerSafeForeignCalls)
(g, stackmaps) <- {-# SCC "layoutStack" #-}
runUniqSM $ cmmLayoutStack procPoints entry_off g
runUniqSM $ cmmLayoutStack dflags procPoints entry_off g
dump Opt_D_dump_cmmz_sp "Layout Stack" g
g <- if optLevel dflags >= 99
......
compiler/cmm/SMRep.lhs
View file @ 229e9fc5
......@@ -44,7 +44,7 @@ module SMRep (
#include "../HsVersions.h"
#include "../includes/MachDeps.h"
import StaticFlags
import DynFlags
import Constants
import Outputable
import FastString
......@@ -161,8 +161,9 @@ data ArgDescr
-----------------------------------------------------------------------------
-- Construction
mkHeapRep :: IsStatic -> WordOff -> WordOff -> ClosureTypeInfo -> SMRep
mkHeapRep is_static ptr_wds nonptr_wds cl_type_info
mkHeapRep :: DynFlags -> IsStatic -> WordOff -> WordOff -> ClosureTypeInfo
-> SMRep
mkHeapRep dflags is_static ptr_wds nonptr_wds cl_type_info
= HeapRep is_static
ptr_wds
(nonptr_wds + slop_wds)
......@@ -170,9 +171,9 @@ mkHeapRep is_static ptr_wds nonptr_wds cl_type_info
where
slop_wds
| is_static = 0
| otherwise = max 0 (minClosureSize - (hdr_size + payload_size))
| otherwise = max 0 (minClosureSize dflags - (hdr_size + payload_size))
hdr_size = closureTypeHdrSize cl_type_info
hdr_size = closureTypeHdrSize dflags cl_type_info
payload_size = ptr_wds + nonptr_wds
mkRTSRep :: StgHalfWord -> SMRep -> SMRep
......@@ -217,29 +218,33 @@ isStaticNoCafCon _ = False
-- Size-related things
-- | Size of a closure header (StgHeader in includes/rts/storage/Closures.h)
fixedHdrSize :: WordOff
fixedHdrSize = sTD_HDR_SIZE + profHdrSize
fixedHdrSize :: DynFlags -> WordOff
fixedHdrSize dflags = sTD_HDR_SIZE + profHdrSize dflags
-- | Size of the profiling part of a closure header
-- (StgProfHeader in includes/rts/storage/Closures.h)
profHdrSize :: WordOff
profHdrSize | opt_SccProfilingOn = pROF_HDR_SIZE
| otherwise = 0
profHdrSize :: DynFlags -> WordOff
profHdrSize dflags
| dopt Opt_SccProfilingOn dflags = pROF_HDR_SIZE
| otherwise = 0
-- | The garbage collector requires that every closure is at least as big as this.
minClosureSize :: WordOff
minClosureSize = fixedHdrSize + mIN_PAYLOAD_SIZE
-- | The garbage collector requires that every closure is at least as
-- big as this.
minClosureSize :: DynFlags -> WordOff
minClosureSize dflags = fixedHdrSize dflags + mIN_PAYLOAD_SIZE
arrWordsHdrSize :: ByteOff
arrWordsHdrSize = fixedHdrSize*wORD_SIZE + sIZEOF_StgArrWords_NoHdr
arrWordsHdrSize :: DynFlags -> ByteOff
arrWordsHdrSize dflags
= fixedHdrSize dflags * wORD_SIZE + sIZEOF_StgArrWords_NoHdr
arrPtrsHdrSize :: ByteOff
arrPtrsHdrSize = fixedHdrSize*wORD_SIZE + sIZEOF_StgMutArrPtrs_NoHdr
arrPtrsHdrSize :: DynFlags -> ByteOff
arrPtrsHdrSize dflags
= fixedHdrSize dflags * wORD_SIZE + sIZEOF_StgMutArrPtrs_NoHdr
-- Thunks have an extra header word on SMP, so the update doesn't
-- splat the payload.
thunkHdrSize :: WordOff
thunkHdrSize = fixedHdrSize + smp_hdr
thunkHdrSize :: DynFlags -> WordOff
thunkHdrSize dflags = fixedHdrSize dflags + smp_hdr
where smp_hdr = sIZEOF_StgSMPThunkHeader `quot` wORD_SIZE
......@@ -248,16 +253,17 @@ nonHdrSize (HeapRep _ p np _) = p + np
nonHdrSize (StackRep bs) = length bs
nonHdrSize (RTSRep _ rep) = nonHdrSize rep
heapClosureSize :: SMRep -> WordOff
heapClosureSize (HeapRep _ p np ty) = closureTypeHdrSize ty + p + np
heapClosureSize _ = panic "SMRep.heapClosureSize"
closureTypeHdrSize :: ClosureTypeInfo -> WordOff
closureTypeHdrSize ty = case ty of
Thunk{} -> thunkHdrSize
ThunkSelector{} -> thunkHdrSize
BlackHole{} -> thunkHdrSize
_ -> fixedHdrSize
heapClosureSize :: DynFlags -> SMRep -> WordOff
heapClosureSize dflags (HeapRep _ p np ty)
= closureTypeHdrSize dflags ty + p + np
heapClosureSize _ _ = panic "SMRep.heapClosureSize"
closureTypeHdrSize :: DynFlags -> ClosureTypeInfo -> WordOff
closureTypeHdrSize dflags ty = case ty of
Thunk{} -> thunkHdrSize dflags
ThunkSelector{} -> thunkHdrSize dflags
BlackHole{} -> thunkHdrSize dflags
_ -> fixedHdrSize dflags
-- All thunks use thunkHdrSize, even if they are non-updatable.
-- this is because we don't have separate closure types for
-- updatable vs. non-updatable thunks, so the GC can't tell the
......
compiler/codeGen/CgCallConv.hs
View file @ 229e9fc5
......@@ -42,6 +42,7 @@ import Maybes
import Id
import Name
import Util
import DynFlags
import StaticFlags
import Module
import FastString
......@@ -159,11 +160,11 @@ constructSlowCall amodes
-- | 'slowArgs' takes a list of function arguments and prepares them for
-- pushing on the stack for "extra" arguments to a function which requires
-- fewer arguments than we currently have.
slowArgs :: [(CgRep,CmmExpr)] -> [(CgRep,CmmExpr)]
slowArgs [] = []
slowArgs amodes
| opt_SccProfilingOn = save_cccs ++ this_pat ++ slowArgs rest
| otherwise = this_pat ++ slowArgs rest
slowArgs :: DynFlags -> [(CgRep,CmmExpr)] -> [(CgRep,CmmExpr)]
slowArgs _ [] = []
slowArgs dflags amodes
| dopt Opt_SccProfilingOn dflags = save_cccs ++ this_pat ++ slowArgs dflags rest
| otherwise = this_pat ++ slowArgs dflags rest
where
(arg_pat, args, rest) = matchSlowPattern amodes
stg_ap_pat = mkCmmRetInfoLabel rtsPackageId arg_pat
......
compiler/codeGen/CgCase.lhs
View file @ 229e9fc5
......@@ -32,8 +32,8 @@ import ClosureInfo
import OldCmmUtils
import OldCmm
import DynFlags
import StgSyn
import StaticFlags
import Id
import ForeignCall
import VarSet
......@@ -650,13 +650,13 @@ saveCurrentCostCentre ::
CmmStmts) -- Assignment to save it
saveCurrentCostCentre
| not opt_SccProfilingOn
= returnFC (Nothing, noStmts)
| otherwise
= do { slot <- allocPrimStack PtrArg
; sp_rel <- getSpRelOffset slot
; returnFC (Just slot,
oneStmt (CmmStore sp_rel curCCS)) }
= do dflags <- getDynFlags
if not (dopt Opt_SccProfilingOn dflags)
then returnFC (Nothing, noStmts)
else do slot <- allocPrimStack PtrArg
sp_rel <- getSpRelOffset slot
returnFC (Just slot,
oneStmt (CmmStore sp_rel curCCS))
-- Sometimes we don't free the slot containing the cost centre after restoring it
-- (see CgLetNoEscape.cgLetNoEscapeBody).
......
compiler/codeGen/CgClosure.lhs
View file @ 229e9fc5
......@@ -49,7 +49,6 @@ import Module
import ListSetOps
import Util
import BasicTypes
import StaticFlags
import DynFlags
import Outputable
import FastString
......@@ -83,10 +82,10 @@ cgTopRhsClosure id ccs binder_info upd_flag args body = do
; mod_name <- getModuleName
; dflags <- getDynFlags
; let descr = closureDescription dflags mod_name name
closure_info = mkClosureInfo True id lf_info 0 0 srt_info descr
closure_info = mkClosureInfo dflags True id lf_info 0 0 srt_info descr
closure_label = mkLocalClosureLabel name $ idCafInfo id
cg_id_info = stableIdInfo id (mkLblExpr closure_label) lf_info
closure_rep = mkStaticClosureFields closure_info ccs True []
closure_rep = mkStaticClosureFields dflags closure_info ccs True []
-- BUILD THE OBJECT, AND GENERATE INFO TABLE (IF NECESSARY)
; emitDataLits closure_label closure_rep
......@@ -123,10 +122,10 @@ cgStdRhsClosure bndr _cc _bndr_info _fvs _args _body lf_info payload
; mod_name <- getModuleName
; dflags <- getDynFlags
; let (tot_wds, ptr_wds, amodes_w_offsets)
= mkVirtHeapOffsets (isLFThunk lf_info) amodes
= mkVirtHeapOffsets dflags (isLFThunk lf_info) amodes
descr = closureDescription dflags mod_name (idName bndr)
closure_info = mkClosureInfo False -- Not static
closure_info = mkClosureInfo dflags False -- Not static
bndr lf_info tot_wds ptr_wds
NoC_SRT -- No SRT for a std-form closure
descr
......@@ -174,12 +173,12 @@ cgRhsClosure bndr cc bndr_info fvs upd_flag args body = do
; dflags <- getDynFlags
; let bind_details :: [(CgIdInfo, VirtualHpOffset)]
(tot_wds, ptr_wds, bind_details)
= mkVirtHeapOffsets (isLFThunk lf_info) (map add_rep fv_infos)
= mkVirtHeapOffsets dflags (isLFThunk lf_info) (map add_rep fv_infos)
add_rep info = (cgIdInfoArgRep info, info)
descr = closureDescription dflags mod_name name
closure_info = mkClosureInfo False -- Not static
closure_info = mkClosureInfo dflags False -- Not static
bndr lf_info tot_wds ptr_wds
srt_info descr
......@@ -392,7 +391,8 @@ mkSlowEntryCode cl_info reg_args
\begin{code}
thunkWrapper:: ClosureInfo -> Code -> Code
thunkWrapper closure_info thunk_code = do
{ let node_points = nodeMustPointToIt (closureLFInfo closure_info)
{ dflags <- getDynFlags
; let node_points = nodeMustPointToIt dflags (closureLFInfo closure_info)
-- HWL: insert macros for GrAnSim; 2 versions depending on liveness of node
-- (we prefer fetchAndReschedule-style context switches to yield ones)
......@@ -416,7 +416,8 @@ funWrapper :: ClosureInfo -- Closure whose code body this is
-> Code -- Body of function being compiled
-> Code
funWrapper closure_info arg_regs reg_save_code fun_body = do
{ let node_points = nodeMustPointToIt (closureLFInfo closure_info)
{ dflags <- getDynFlags
; let node_points = nodeMustPointToIt dflags (closureLFInfo closure_info)
live = Just $ map snd arg_regs
{-
......@@ -477,7 +478,7 @@ emitBlackHoleCode is_single_entry = do
-- Note the eager-blackholing check is here rather than in blackHoleOnEntry,
-- because emitBlackHoleCode is called from CmmParse.
let eager_blackholing = not opt_SccProfilingOn
let eager_blackholing = not (dopt Opt_SccProfilingOn dflags)
&& dopt Opt_EagerBlackHoling dflags
-- Profiling needs slop filling (to support LDV
-- profiling), so currently eager blackholing doesn't
......@@ -486,7 +487,7 @@ emitBlackHoleCode is_single_entry = do
whenC eager_blackholing $ do
tickyBlackHole (not is_single_entry)
stmtsC [
CmmStore (cmmOffsetW (CmmReg nodeReg) fixedHdrSize)
CmmStore (cmmOffsetW (CmmReg nodeReg) (fixedHdrSize dflags))
(CmmReg (CmmGlobal CurrentTSO)),
CmmCall (CmmPrim MO_WriteBarrier Nothing) [] [] CmmMayReturn,
CmmStore (CmmReg nodeReg) (CmmReg (CmmGlobal EagerBlackholeInfo))
......@@ -510,7 +511,8 @@ setupUpdate closure_info code
tickyPushUpdateFrame
dflags <- getDynFlags
if blackHoleOnEntry closure_info &&
not opt_SccProfilingOn && dopt Opt_EagerBlackHoling dflags
not (dopt Opt_SccProfilingOn dflags) &&
dopt Opt_EagerBlackHoling dflags
then pushBHUpdateFrame (CmmReg nodeReg) code
else pushUpdateFrame (CmmReg nodeReg) code
......@@ -575,7 +577,9 @@ link_caf cl_info _is_upd = do
; let use_cc = costCentreFrom (CmmReg nodeReg)
blame_cc = use_cc
tso = CmmReg (CmmGlobal CurrentTSO)
; hp_offset <- allocDynClosure bh_cl_info use_cc blame_cc [(tso,fixedHdrSize)]
; dflags <- getDynFlags
; hp_offset <- allocDynClosure bh_cl_info use_cc blame_cc
[(tso, fixedHdrSize dflags)]
; hp_rel <- getHpRelOffset hp_offset
-- Call the RTS function newCAF to add the CAF to the CafList
......
compiler/codeGen/CgCon.lhs
View file @ 229e9fc5
......@@ -50,7 +50,6 @@ import Module
import DynFlags
import FastString
import Platform
import StaticFlags
import Control.Monad
\end{code}
......@@ -82,8 +81,9 @@ cgTopRhsCon id con args
lf_info = mkConLFInfo con
closure_label = mkClosureLabel name $ idCafInfo id
caffy = any stgArgHasCafRefs args
(closure_info, amodes_w_offsets) = layOutStaticConstr con amodes
(closure_info, amodes_w_offsets) = layOutStaticConstr dflags con amodes
closure_rep = mkStaticClosureFields
dflags
closure_info
dontCareCCS -- Because it's static data
caffy -- Has CAF refs
......@@ -191,7 +191,7 @@ buildDynCon' dflags platform binder _ con [arg_amode]
, let val_int = (fromIntegral val) :: Int
, val_int <= mAX_INTLIKE && val_int >= mIN_INTLIKE
= do { let intlike_lbl = mkCmmGcPtrLabel rtsPackageId (fsLit "stg_INTLIKE_closure")
offsetW = (val_int - mIN_INTLIKE) * (fixedHdrSize + 1)
offsetW = (val_int - mIN_INTLIKE) * (fixedHdrSize dflags + 1)
-- INTLIKE closures consist of a header and one word payload
intlike_amode = CmmLit (cmmLabelOffW intlike_lbl offsetW)
; returnFC (taggedStableIdInfo binder intlike_amode (mkConLFInfo con) con) }
......@@ -203,7 +203,7 @@ buildDynCon' dflags platform binder _ con [arg_amode]
, let val_int = (fromIntegral val) :: Int
, val_int <= mAX_CHARLIKE && val_int >= mIN_CHARLIKE
= do { let charlike_lbl = mkCmmGcPtrLabel rtsPackageId (fsLit "stg_CHARLIKE_closure")
offsetW = (val_int - mIN_CHARLIKE) * (fixedHdrSize + 1)
offsetW = (val_int - mIN_CHARLIKE) * (fixedHdrSize dflags + 1)
-- CHARLIKE closures consist of a header and one word payload
charlike_amode = CmmLit (cmmLabelOffW charlike_lbl offsetW)
; returnFC (taggedStableIdInfo binder charlike_amode (mkConLFInfo con) con) }
......@@ -213,10 +213,10 @@ buildDynCon' dflags platform binder _ con [arg_amode]
Now the general case.
\begin{code}
buildDynCon' _ _ binder ccs con args
buildDynCon' dflags _ binder ccs con args
= do {
; let
(closure_info, amodes_w_offsets) = layOutDynConstr con args
(closure_info, amodes_w_offsets) = layOutDynConstr dflags con args