Commit 229e9fc5 authored by Ian Lynagh's avatar Ian Lynagh

Make -fscc-profiling a dynamic flag

All the flags that 'ways' imply are now dynamic
parent 4b18cc53
...@@ -24,8 +24,8 @@ import qualified Stream ...@@ -24,8 +24,8 @@ import qualified Stream
import Maybes import Maybes
import Constants import Constants
import DynFlags
import Panic import Panic
import Platform
import StaticFlags import StaticFlags
import UniqSupply import UniqSupply
import MonadUtils import MonadUtils
...@@ -42,12 +42,12 @@ mkEmptyContInfoTable info_lbl ...@@ -42,12 +42,12 @@ mkEmptyContInfoTable info_lbl
, cit_prof = NoProfilingInfo , cit_prof = NoProfilingInfo
, cit_srt = NoC_SRT } , cit_srt = NoC_SRT }
cmmToRawCmm :: Platform -> Stream IO Old.CmmGroup () cmmToRawCmm :: DynFlags -> Stream IO Old.CmmGroup ()
-> IO (Stream IO Old.RawCmmGroup ()) -> IO (Stream IO Old.RawCmmGroup ())
cmmToRawCmm platform cmms cmmToRawCmm dflags cmms
= do { uniqs <- mkSplitUniqSupply 'i' = do { uniqs <- mkSplitUniqSupply 'i'
; let do_one uniqs cmm = do ; 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) (b,uniqs') -> return (uniqs',b)
-- NB. strictness fixes a space leak. DO NOT REMOVE. -- NB. strictness fixes a space leak. DO NOT REMOVE.
; return (Stream.mapAccumL do_one uniqs cmms >> return ()) ; return (Stream.mapAccumL do_one uniqs cmms >> return ())
...@@ -86,16 +86,16 @@ cmmToRawCmm platform cmms ...@@ -86,16 +86,16 @@ cmmToRawCmm platform cmms
-- --
-- * The SRT slot is only there if there is SRT info to record -- * 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) mkInfoTable _ (CmmData sec dat)
= return [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. | CmmNonInfoTable <- info -- Code without an info table. Easy.
= return [CmmProc Nothing entry_label blocks] = return [CmmProc Nothing entry_label blocks]
| CmmInfoTable { cit_lbl = info_lbl } <- info | 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 ++ ; return (top_decls ++
mkInfoTableAndCode info_lbl info_cts mkInfoTableAndCode info_lbl info_cts
entry_label blocks) } entry_label blocks) }
...@@ -107,20 +107,20 @@ type InfoTableContents = ( [CmmLit] -- The standard part ...@@ -107,20 +107,20 @@ type InfoTableContents = ( [CmmLit] -- The standard part
, [CmmLit] ) -- The "extra bits" , [CmmLit] ) -- The "extra bits"
-- These Lits have *not* had mkRelativeTo applied to them -- These Lits have *not* had mkRelativeTo applied to them
mkInfoTableContents :: Platform mkInfoTableContents :: DynFlags
-> CmmInfoTable -> CmmInfoTable
-> Maybe StgHalfWord -- Override default RTS type tag? -> Maybe StgHalfWord -- Override default RTS type tag?
-> UniqSM ([RawCmmDecl], -- Auxiliary top decls -> UniqSM ([RawCmmDecl], -- Auxiliary top decls
InfoTableContents) -- Info tbl + extra bits InfoTableContents) -- Info tbl + extra bits
mkInfoTableContents platform mkInfoTableContents dflags
info@(CmmInfoTable { cit_lbl = info_lbl info@(CmmInfoTable { cit_lbl = info_lbl
, cit_rep = smrep , cit_rep = smrep
, cit_prof = prof , cit_prof = prof
, cit_srt = srt }) , cit_srt = srt })
mb_rts_tag mb_rts_tag
| RTSRep rts_tag rep <- smrep | 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 -- Completely override the rts_tag that mkInfoTableContents would
-- otherwise compute, with the rts_tag stored in the RTSRep -- otherwise compute, with the rts_tag stored in the RTSRep
-- (which in turn came from a handwritten .cmm file) -- (which in turn came from a handwritten .cmm file)
...@@ -130,7 +130,7 @@ mkInfoTableContents platform ...@@ -130,7 +130,7 @@ mkInfoTableContents platform
; let (srt_label, srt_bitmap) = mkSRTLit srt ; let (srt_label, srt_bitmap) = mkSRTLit srt
; (liveness_lit, liveness_data) <- mkLivenessBits frame ; (liveness_lit, liveness_data) <- mkLivenessBits frame
; let ; 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 rts_tag | Just tag <- mb_rts_tag = tag
| null liveness_data = rET_SMALL -- Fits in extra_bits | null liveness_data = rET_SMALL -- Fits in extra_bits
| otherwise = rET_BIG -- Does not; extra_bits is | otherwise = rET_BIG -- Does not; extra_bits is
...@@ -143,7 +143,7 @@ mkInfoTableContents platform ...@@ -143,7 +143,7 @@ mkInfoTableContents platform
; let (srt_label, srt_bitmap) = mkSRTLit srt ; let (srt_label, srt_bitmap) = mkSRTLit srt
; (mb_srt_field, mb_layout, extra_bits, ct_data) ; (mb_srt_field, mb_layout, extra_bits, ct_data)
<- mk_pieces closure_type srt_label <- 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_rts_tag `orElse` rtsClosureType smrep)
(mb_srt_field `orElse` srt_bitmap) (mb_srt_field `orElse` srt_bitmap)
(mb_layout `orElse` layout) (mb_layout `orElse` layout)
...@@ -326,13 +326,14 @@ mkLivenessBits liveness ...@@ -326,13 +326,14 @@ mkLivenessBits liveness
-- so we can't use constant offsets from Constants -- so we can't use constant offsets from Constants
mkStdInfoTable 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 -- Closure RTS tag
-> StgHalfWord -- SRT length -> StgHalfWord -- SRT length
-> CmmLit -- layout field -> CmmLit -- layout field
-> [CmmLit] -> [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 = -- Parallel revertible-black hole field
prof_info prof_info
-- Ticky info (none at present) -- Ticky info (none at present)
...@@ -341,8 +342,8 @@ mkStdInfoTable (type_descr, closure_descr) cl_type srt_len layout_lit ...@@ -341,8 +342,8 @@ mkStdInfoTable (type_descr, closure_descr) cl_type srt_len layout_lit
where where
prof_info prof_info
| opt_SccProfilingOn = [type_descr, closure_descr] | dopt Opt_SccProfilingOn dflags = [type_descr, closure_descr]
| otherwise = [] | otherwise = []
type_lit = packHalfWordsCLit cl_type srt_len type_lit = packHalfWordsCLit cl_type srt_len
......
...@@ -23,6 +23,7 @@ import Maybes ...@@ -23,6 +23,7 @@ import Maybes
import UniqFM import UniqFM
import Util import Util
import DynFlags
import FastString import FastString
import Outputable import Outputable
import Data.Map (Map) import Data.Map (Map)
...@@ -103,9 +104,9 @@ instance Outputable StackMap where ...@@ -103,9 +104,9 @@ instance Outputable StackMap where
text "sm_regs = " <> ppr (eltsUFM sm_regs) text "sm_regs = " <> ppr (eltsUFM sm_regs)
cmmLayoutStack :: ProcPointSet -> ByteOff -> CmmGraph cmmLayoutStack :: DynFlags -> ProcPointSet -> ByteOff -> CmmGraph
-> UniqSM (CmmGraph, BlockEnv StackMap) -> UniqSM (CmmGraph, BlockEnv StackMap)
cmmLayoutStack procpoints entry_args cmmLayoutStack dflags procpoints entry_args
graph0@(CmmGraph { g_entry = entry }) graph0@(CmmGraph { g_entry = entry })
= do = do
-- pprTrace "cmmLayoutStack" (ppr entry_args) $ return () -- pprTrace "cmmLayoutStack" (ppr entry_args) $ return ()
...@@ -118,7 +119,7 @@ cmmLayoutStack procpoints entry_args ...@@ -118,7 +119,7 @@ cmmLayoutStack procpoints entry_args
layout procpoints liveness entry entry_args layout procpoints liveness entry entry_args
rec_stackmaps rec_high_sp blocks 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 () -- pprTrace ("Sp HWM") (ppr _final_high_sp) $ return ()
return (ofBlockList entry new_blocks', final_stackmaps) return (ofBlockList entry new_blocks', final_stackmaps)
...@@ -870,8 +871,8 @@ Note the copyOut, which saves the results in the places that L1 is ...@@ -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]). expecting them (see Note {safe foreign call convention]).
-} -}
lowerSafeForeignCall :: CmmBlock -> UniqSM CmmBlock lowerSafeForeignCall :: DynFlags -> CmmBlock -> UniqSM CmmBlock
lowerSafeForeignCall block lowerSafeForeignCall dflags block
| (entry, middle, CmmForeignCall { .. }) <- blockSplit block | (entry, middle, CmmForeignCall { .. }) <- blockSplit block
= do = do
-- Both 'id' and 'new_base' are KindNonPtr because they're -- Both 'id' and 'new_base' are KindNonPtr because they're
...@@ -881,7 +882,7 @@ lowerSafeForeignCall block ...@@ -881,7 +882,7 @@ lowerSafeForeignCall block
let (caller_save, caller_load) = callerSaveVolatileRegs let (caller_save, caller_load) = callerSaveVolatileRegs
load_tso <- newTemp gcWord load_tso <- newTemp gcWord
load_stack <- newTemp gcWord load_stack <- newTemp gcWord
let suspend = saveThreadState <*> let suspend = saveThreadState dflags <*>
caller_save <*> caller_save <*>
mkMiddle (callSuspendThread id intrbl) mkMiddle (callSuspendThread id intrbl)
midCall = mkUnsafeCall tgt res args midCall = mkUnsafeCall tgt res args
...@@ -890,7 +891,7 @@ lowerSafeForeignCall block ...@@ -890,7 +891,7 @@ lowerSafeForeignCall block
-- might now have a different Capability! -- might now have a different Capability!
mkAssign (CmmGlobal BaseReg) (CmmReg (CmmLocal new_base)) <*> mkAssign (CmmGlobal BaseReg) (CmmReg (CmmLocal new_base)) <*>
caller_load <*> 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, -- Note: The successor must be a procpoint, and we have already split,
-- so we use a jump, not a branch. -- so we use a jump, not a branch.
succLbl = CmmLit (CmmLabel (infoTblLbl succ)) succLbl = CmmLit (CmmLabel (infoTblLbl succ))
......
...@@ -216,12 +216,13 @@ static :: { ExtFCode [CmmStatic] } ...@@ -216,12 +216,13 @@ static :: { ExtFCode [CmmStatic] }
(widthInBytes (typeWidth $1) * (widthInBytes (typeWidth $1) *
fromIntegral $3)] } fromIntegral $3)] }
| 'CLOSURE' '(' NAME lits ')' | 'CLOSURE' '(' NAME lits ')'
{ do lits <- sequence $4; { do { lits <- sequence $4
return $ map CmmStaticLit $ ; dflags <- getDynFlags
mkStaticClosure (mkForeignLabel $3 Nothing ForeignLabelInExternalPackage IsData) ; return $ map CmmStaticLit $
mkStaticClosure dflags (mkForeignLabel $3 Nothing ForeignLabelInExternalPackage IsData)
-- mkForeignLabel because these are only used -- mkForeignLabel because these are only used
-- for CHARLIKE and INTLIKE closures in the RTS. -- 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 -- arrays of closures required for the CHARLIKE & INTLIKE arrays
lits :: { [ExtFCode CmmExpr] } lits :: { [ExtFCode CmmExpr] }
...@@ -260,9 +261,10 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) } ...@@ -260,9 +261,10 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) }
: 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')' : 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
-- ptrs, nptrs, closure type, description, type -- ptrs, nptrs, closure type, description, type
{% withThisPackage $ \pkg -> {% withThisPackage $ \pkg ->
do let prof = profilingInfo $11 $13 do dflags <- getDynFlags
let prof = profilingInfo dflags $11 $13
rep = mkRTSRep (fromIntegral $9) $ rep = mkRTSRep (fromIntegral $9) $
mkHeapRep False (fromIntegral $5) mkHeapRep dflags False (fromIntegral $5)
(fromIntegral $7) Thunk (fromIntegral $7) Thunk
-- not really Thunk, but that makes the info table -- not really Thunk, but that makes the info table
-- we want. -- we want.
...@@ -275,11 +277,12 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) } ...@@ -275,11 +277,12 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) }
| 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ')' | 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ')'
-- ptrs, nptrs, closure type, description, type, fun type -- ptrs, nptrs, closure type, description, type, fun type
{% withThisPackage $ \pkg -> {% withThisPackage $ \pkg ->
do let prof = profilingInfo $11 $13 do dflags <- getDynFlags
let prof = profilingInfo dflags $11 $13
ty = Fun 0 (ArgSpec (fromIntegral $15)) ty = Fun 0 (ArgSpec (fromIntegral $15))
-- Arity zero, arg_type $15 -- Arity zero, arg_type $15
rep = mkRTSRep (fromIntegral $9) $ rep = mkRTSRep (fromIntegral $9) $
mkHeapRep False (fromIntegral $5) mkHeapRep dflags False (fromIntegral $5)
(fromIntegral $7) ty (fromIntegral $7) ty
return (mkCmmEntryLabel pkg $3, return (mkCmmEntryLabel pkg $3,
CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3 CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
...@@ -292,11 +295,12 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) } ...@@ -292,11 +295,12 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) }
| 'INFO_TABLE_CONSTR' '(' NAME ',' INT ',' INT ',' INT ',' INT ',' STRING ',' STRING ')' | 'INFO_TABLE_CONSTR' '(' NAME ',' INT ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
-- ptrs, nptrs, tag, closure type, description, type -- ptrs, nptrs, tag, closure type, description, type
{% withThisPackage $ \pkg -> {% withThisPackage $ \pkg ->
do let prof = profilingInfo $13 $15 do dflags <- getDynFlags
let prof = profilingInfo dflags $13 $15
ty = Constr (fromIntegral $9) -- Tag ty = Constr (fromIntegral $9) -- Tag
(stringToWord8s $13) (stringToWord8s $13)
rep = mkRTSRep (fromIntegral $11) $ rep = mkRTSRep (fromIntegral $11) $
mkHeapRep False (fromIntegral $5) mkHeapRep dflags False (fromIntegral $5)
(fromIntegral $7) ty (fromIntegral $7) ty
return (mkCmmEntryLabel pkg $3, return (mkCmmEntryLabel pkg $3,
CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3 CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
...@@ -310,10 +314,11 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) } ...@@ -310,10 +314,11 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) }
| 'INFO_TABLE_SELECTOR' '(' NAME ',' INT ',' INT ',' STRING ',' STRING ')' | 'INFO_TABLE_SELECTOR' '(' NAME ',' INT ',' INT ',' STRING ',' STRING ')'
-- selector, closure type, description, type -- selector, closure type, description, type
{% withThisPackage $ \pkg -> {% withThisPackage $ \pkg ->
do let prof = profilingInfo $9 $11 do dflags <- getDynFlags
let prof = profilingInfo dflags $9 $11
ty = ThunkSelector (fromIntegral $5) ty = ThunkSelector (fromIntegral $5)
rep = mkRTSRep (fromIntegral $7) $ rep = mkRTSRep (fromIntegral $7) $
mkHeapRep False 0 0 ty mkHeapRep dflags False 0 0 ty
return (mkCmmEntryLabel pkg $3, return (mkCmmEntryLabel pkg $3,
CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3 CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
, cit_rep = rep , cit_rep = rep
...@@ -639,8 +644,9 @@ nameToMachOp name = ...@@ -639,8 +644,9 @@ nameToMachOp name =
Just m -> return m Just m -> return m
exprOp :: FastString -> [ExtFCode CmmExpr] -> P (ExtFCode CmmExpr) exprOp :: FastString -> [ExtFCode CmmExpr] -> P (ExtFCode CmmExpr)
exprOp name args_code = exprOp name args_code = do
case lookupUFM exprMacros name of dflags <- getDynFlags
case lookupUFM (exprMacros dflags) name of
Just f -> return $ do Just f -> return $ do
args <- sequence args_code args <- sequence args_code
return (f args) return (f args)
...@@ -648,18 +654,18 @@ exprOp name args_code = ...@@ -648,18 +654,18 @@ exprOp name args_code =
mo <- nameToMachOp name mo <- nameToMachOp name
return $ mkMachOp mo args_code return $ mkMachOp mo args_code
exprMacros :: UniqFM ([CmmExpr] -> CmmExpr) exprMacros :: DynFlags -> UniqFM ([CmmExpr] -> CmmExpr)
exprMacros = listToUFM [ exprMacros dflags = listToUFM [
( fsLit "ENTRY_CODE", \ [x] -> entryCode x ), ( fsLit "ENTRY_CODE", \ [x] -> entryCode x ),
( fsLit "INFO_PTR", \ [x] -> closureInfoPtr x ), ( fsLit "INFO_PTR", \ [x] -> closureInfoPtr x ),
( fsLit "STD_INFO", \ [x] -> infoTable x ), ( fsLit "STD_INFO", \ [x] -> infoTable dflags x ),
( fsLit "FUN_INFO", \ [x] -> funInfoTable x ), ( fsLit "FUN_INFO", \ [x] -> funInfoTable dflags x ),
( fsLit "GET_ENTRY", \ [x] -> entryCode (closureInfoPtr x) ), ( fsLit "GET_ENTRY", \ [x] -> entryCode (closureInfoPtr x) ),
( fsLit "GET_STD_INFO", \ [x] -> infoTable (closureInfoPtr x) ), ( fsLit "GET_STD_INFO", \ [x] -> infoTable dflags (closureInfoPtr x) ),
( fsLit "GET_FUN_INFO", \ [x] -> funInfoTable (closureInfoPtr x) ), ( fsLit "GET_FUN_INFO", \ [x] -> funInfoTable dflags (closureInfoPtr x) ),
( fsLit "INFO_TYPE", \ [x] -> infoTableClosureType x ), ( fsLit "INFO_TYPE", \ [x] -> infoTableClosureType dflags x ),
( fsLit "INFO_PTRS", \ [x] -> infoTablePtrs x ), ( fsLit "INFO_PTRS", \ [x] -> infoTablePtrs dflags x ),
( fsLit "INFO_NPTRS", \ [x] -> infoTableNonPtrs x ) ( fsLit "INFO_NPTRS", \ [x] -> infoTableNonPtrs dflags x )
] ]
-- we understand a subset of C-- primitives: -- we understand a subset of C-- primitives:
...@@ -824,15 +830,17 @@ stmtMacros = listToUFM [ ...@@ -824,15 +830,17 @@ stmtMacros = listToUFM [
] ]
profilingInfo desc_str ty_str profilingInfo dflags desc_str ty_str
| not opt_SccProfilingOn = NoProfilingInfo = if not (dopt Opt_SccProfilingOn dflags)
| otherwise = ProfilingInfo (stringToWord8s desc_str) then NoProfilingInfo
(stringToWord8s ty_str) else ProfilingInfo (stringToWord8s desc_str)
(stringToWord8s ty_str)
staticClosure :: PackageId -> FastString -> FastString -> [CmmLit] -> ExtCode staticClosure :: PackageId -> FastString -> FastString -> [CmmLit] -> ExtCode
staticClosure pkg cl_label info payload staticClosure pkg cl_label info payload
= code $ emitDataLits (mkCmmDataLabel pkg cl_label) lits = do dflags <- getDynFlags
where lits = mkStaticClosure (mkCmmInfoLabel pkg info) dontCareCCS payload [] [] [] let lits = mkStaticClosure dflags (mkCmmInfoLabel pkg info) dontCareCCS payload [] [] []
code $ emitDataLits (mkCmmDataLabel pkg cl_label) lits
foreignCall foreignCall
:: String :: String
...@@ -1036,12 +1044,12 @@ doSwitch mb_range scrut arms deflt ...@@ -1036,12 +1044,12 @@ doSwitch mb_range scrut arms deflt
-- The initial environment: we define some constants that the compiler -- The initial environment: we define some constants that the compiler
-- knows about here. -- knows about here.
initEnv :: Env initEnv :: DynFlags -> Env
initEnv = listToUFM [ initEnv dflags = listToUFM [
( fsLit "SIZEOF_StgHeader", ( fsLit "SIZEOF_StgHeader",
VarN (CmmLit (CmmInt (fromIntegral (fixedHdrSize * wORD_SIZE)) wordWidth) )), VarN (CmmLit (CmmInt (fromIntegral (fixedHdrSize dflags * wORD_SIZE)) wordWidth) )),
( fsLit "SIZEOF_StgInfoTable", ( fsLit "SIZEOF_StgInfoTable",
VarN (CmmLit (CmmInt (fromIntegral stdInfoTableSizeB) wordWidth) )) VarN (CmmLit (CmmInt (fromIntegral (stdInfoTableSizeB dflags)) wordWidth) ))
] ]
parseCmmFile :: DynFlags -> FilePath -> IO (Messages, Maybe CmmGroup) parseCmmFile :: DynFlags -> FilePath -> IO (Messages, Maybe CmmGroup)
...@@ -1059,7 +1067,7 @@ parseCmmFile dflags filename = do ...@@ -1059,7 +1067,7 @@ parseCmmFile dflags filename = do
return ((emptyBag, unitBag msg), Nothing) return ((emptyBag, unitBag msg), Nothing)
POk pst code -> do POk pst code -> do
st <- initC 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 let ms = getMessages pst
if (errorsFound dflags ms) if (errorsFound dflags ms)
then return (ms, Nothing) then return (ms, Nothing)
......
...@@ -72,7 +72,7 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}}) ...@@ -72,7 +72,7 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}})
----------- Layout the stack and manifest Sp --------------- ----------- Layout the stack and manifest Sp ---------------
-- (also does: removeDeadAssignments, and lowerSafeForeignCalls) -- (also does: removeDeadAssignments, and lowerSafeForeignCalls)
(g, stackmaps) <- {-# SCC "layoutStack" #-} (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 dump Opt_D_dump_cmmz_sp "Layout Stack" g
g <- if optLevel dflags >= 99 g <- if optLevel dflags >= 99
......
...@@ -44,7 +44,7 @@ module SMRep ( ...@@ -44,7 +44,7 @@ module SMRep (
#include "../HsVersions.h" #include "../HsVersions.h"
#include "../includes/MachDeps.h" #include "../includes/MachDeps.h"
import StaticFlags import DynFlags
import Constants import Constants
import Outputable import Outputable
import FastString import FastString
...@@ -161,8 +161,9 @@ data ArgDescr ...@@ -161,8 +161,9 @@ data ArgDescr
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- Construction -- Construction
mkHeapRep :: IsStatic -> WordOff -> WordOff -> ClosureTypeInfo -> SMRep mkHeapRep :: DynFlags -> IsStatic -> WordOff -> WordOff -> ClosureTypeInfo
mkHeapRep is_static ptr_wds nonptr_wds cl_type_info -> SMRep
mkHeapRep dflags is_static ptr_wds nonptr_wds cl_type_info
= HeapRep is_static = HeapRep is_static
ptr_wds ptr_wds
(nonptr_wds + slop_wds) (nonptr_wds + slop_wds)
...@@ -170,9 +171,9 @@ mkHeapRep is_static ptr_wds nonptr_wds cl_type_info ...@@ -170,9 +171,9 @@ mkHeapRep is_static ptr_wds nonptr_wds cl_type_info
where where
slop_wds slop_wds
| is_static = 0 | 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 payload_size = ptr_wds + nonptr_wds
mkRTSRep :: StgHalfWord -> SMRep -> SMRep mkRTSRep :: StgHalfWord -> SMRep -> SMRep
...@@ -217,29 +218,33 @@ isStaticNoCafCon _ = False ...@@ -217,29 +218,33 @@ isStaticNoCafCon _ = False
-- Size-related things -- Size-related things
-- | Size of a closure header (StgHeader in includes/rts/storage/Closures.h) -- | Size of a closure header (StgHeader in includes/rts/storage/Closures.h)
fixedHdrSize :: WordOff fixedHdrSize :: DynFlags -> WordOff
fixedHdrSize = sTD_HDR_SIZE + profHdrSize fixedHdrSize dflags = sTD_HDR_SIZE + profHdrSize dflags
-- | Size of the profiling part of a closure header -- | Size of the profiling part of a closure header
-- (StgProfHeader in includes/rts/storage/Closures.h) -- (StgProfHeader in includes/rts/storage/Closures.h)
profHdrSize :: WordOff profHdrSize :: DynFlags -> WordOff
profHdrSize | opt_SccProfilingOn = pROF_HDR_SIZE profHdrSize dflags
| otherwise = 0 | dopt Opt_SccProfilingOn dflags = pROF_HDR_SIZE
| otherwise = 0
-- | The garbage collector requires that every closure is at least as big as this. -- | The garbage collector requires that every closure is at least as
minClosureSize :: WordOff -- big as this.
minClosureSize = fixedHdrSize + mIN_PAYLOAD_SIZE minClosureSize :: DynFlags -> WordOff
minClosureSize dflags = fixedHdrSize dflags + mIN_PAYLOAD_SIZE
arrWordsHdrSize :: ByteOff arrWordsHdrSize :: DynFlags -> ByteOff
arrWordsHdrSize = fixedHdrSize*wORD_SIZE + sIZEOF_StgArrWords_NoHdr arrWordsHdrSize dflags
= fixedHdrSize dflags * wORD_SIZE + sIZEOF_StgArrWords_NoHdr
arrPtrsHdrSize :: ByteOff arrPtrsHdrSize :: DynFlags -> ByteOff
arrPtrsHdrSize = fixedHdrSize*wORD_SIZE + sIZEOF_StgMutArrPtrs_NoHdr arrPtrsHdrSize dflags
= fixedHdrSize dflags * wORD_SIZE + sIZEOF_StgMutArrPtrs_NoHdr
-- Thunks have an extra header word on SMP, so the update doesn't -- Thunks have an extra header word on SMP, so the update doesn't
-- splat the payload. -- splat the payload.
thunkHdrSize :: WordOff thunkHdrSize :: DynFlags -> WordOff
thunkHdrSize = fixedHdrSize + smp_hdr thunkHdrSize dflags = fixedHdrSize dflags + smp_hdr
where smp_hdr = sIZEOF_StgSMPThunkHeader `quot` wORD_SIZE where smp_hdr = sIZEOF_StgSMPThunkHeader `quot` wORD_SIZE
...@@ -248,16 +253,17 @@ nonHdrSize (HeapRep _ p np _) = p + np ...@@ -248,16 +253,17 @@ nonHdrSize (HeapRep _ p np _) = p + np
nonHdrSize (StackRep bs) = length bs nonHdrSize (StackRep bs) = length bs
nonHdrSize (RTSRep _ rep) = nonHdrSize rep nonHdrSize (RTSRep _ rep) = nonHdrSize rep
heapClosureSize :: SMRep -> WordOff heapClosureSize :: DynFlags -> SMRep -> WordOff
heapClosureSize (HeapRep _ p np ty) = closureTypeHdrSize ty + p + np heapClosureSize dflags (HeapRep _ p np ty)
heapClosureSize _ = panic "SMRep.heapClosureSize" = closureTypeHdrSize dflags ty + p + np
heapClosureSize _ _ = panic "SMRep.heapClosureSize"
closureTypeHdrSize :: ClosureTypeInfo -> WordOff
closureTypeHdrSize ty = case ty of closureTypeHdrSize :: DynFlags -> ClosureTypeInfo -> WordOff
Thunk{} -> thunkHdrSize closureTypeHdrSize dflags ty = case ty of
ThunkSelector{} -> thunkHdrSize Thunk{} -> thunkHdrSize dflags
BlackHole{} -> thunkHdrSize ThunkSelector{} -> thunkHdrSize dflags
_ -> fixedHdrSize BlackHole{} -> thunkHdrSize dflags
_ -> fixedHdrSize dflags
-- All thunks use thunkHdrSize, even if they are non-updatable. -- All thunks use thunkHdrSize, even if they are non-updatable.
-- this is because we don't have separate closure types for -- this is because we don't have separate closure types for
-- updatable vs. non-updatable thunks, so the GC can't tell the -- updatable vs. non-updatable thunks, so the GC can't tell the
......
...@@ -42,6 +42,7 @@ import Maybes ...@@ -42,6 +42,7 @@ import Maybes
import Id import Id
import Name import Name
import Util import Util
import DynFlags
import StaticFlags import StaticFlags
import Module import Module
import FastString import FastString
...@@ -159,11 +160,11 @@ constructSlowCall amodes ...@@ -159,11 +160,11 @@ constructSlowCall amodes
-- | 'slowArgs' takes a list of function arguments and prepares them for -- | 'slowArgs' takes a list of function arguments and prepares them for
-- pushing on the stack for "extra" arguments to a function which requires -- pushing on the stack for "extra" arguments to a function which requires
-- fewer arguments than we currently have. -- fewer arguments than we currently have.
slowArgs :: [(CgRep,CmmExpr)] -> [(CgRep,CmmExpr)]