diff options
Diffstat (limited to 'compiler/codeGen')
| -rw-r--r-- | compiler/codeGen/StgCmm.hs | 36 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmBind.hs | 84 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmClosure.hs | 532 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmCon.hs | 18 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmEnv.hs | 69 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmExpr.hs | 92 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmExtCode.hs | 61 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmForeign.hs | 3 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmGran.hs | 120 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmHeap.hs | 14 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmLayout.hs | 173 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmMonad.hs | 185 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmPrim.hs | 40 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmProf.hs | 96 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmTicky.hs | 43 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmUtils.hs | 11 |
16 files changed, 703 insertions, 874 deletions
diff --git a/compiler/codeGen/StgCmm.hs b/compiler/codeGen/StgCmm.hs index 6098e615ae..8b3bac3b4f 100644 --- a/compiler/codeGen/StgCmm.hs +++ b/compiler/codeGen/StgCmm.hs @@ -50,12 +50,12 @@ import Control.Monad (when,void) import Util codeGen :: DynFlags - -> Module - -> [TyCon] - -> CollectedCCs -- (Local/global) cost-centres needing declaring/registering. - -> [StgBinding] -- Bindings to convert - -> HpcInfo - -> Stream IO CmmGroup () -- Output as a stream, so codegen can + -> Module + -> [TyCon] + -> CollectedCCs -- (Local/global) cost-centres needing declaring/registering. + -> [StgBinding] -- Bindings to convert + -> HpcInfo + -> Stream IO CmmGroup () -- Output as a stream, so codegen can -- be interleaved with output codeGen dflags this_mod data_tycons @@ -118,33 +118,33 @@ variable. -} cgTopBinding :: DynFlags -> StgBinding -> FCode () cgTopBinding dflags (StgNonRec id rhs) = do { id' <- maybeExternaliseId dflags id - ; (info, fcode) <- cgTopRhs NonRecursive id' rhs + ; let (info, fcode) = cgTopRhs dflags NonRecursive id' rhs ; fcode - ; addBindC (cg_id info) info -- Add the *un-externalised* Id to the envt, - -- so we find it when we look up occurrences + ; addBindC info -- Add the *un-externalised* Id to the envt, + -- so we find it when we look up occurrences } cgTopBinding dflags (StgRec pairs) = do { let (bndrs, rhss) = unzip pairs ; bndrs' <- Prelude.mapM (maybeExternaliseId dflags) bndrs ; let pairs' = zip bndrs' rhss - ; r <- sequence $ unzipWith (cgTopRhs Recursive) pairs' - ; let (infos, fcodes) = unzip r + r = unzipWith (cgTopRhs dflags Recursive) pairs' + (infos, fcodes) = unzip r ; addBindsC infos ; sequence_ fcodes } -cgTopRhs :: RecFlag -> Id -> StgRhs -> FCode (CgIdInfo, FCode ()) +cgTopRhs :: DynFlags -> RecFlag -> Id -> StgRhs -> (CgIdInfo, FCode ()) -- The Id is passed along for setting up a binding... -- It's already been externalised if necessary -cgTopRhs _rec bndr (StgRhsCon _cc con args) - = forkStatics (cgTopRhsCon bndr con args) +cgTopRhs dflags _rec bndr (StgRhsCon _cc con args) + = cgTopRhsCon dflags bndr con args -cgTopRhs rec bndr (StgRhsClosure cc bi fvs upd_flag _srt args body) +cgTopRhs dflags rec bndr (StgRhsClosure cc bi fvs upd_flag _srt args body) = ASSERT(null fvs) -- There should be no free variables - forkStatics (cgTopRhsClosure rec bndr cc bi upd_flag args body) + cgTopRhsClosure dflags rec bndr cc bi upd_flag args body --------------------------------------------------------------- @@ -178,13 +178,13 @@ cgTopRhs rec bndr (StgRhsClosure cc bi fvs upd_flag _srt args body) module in the program, and we don't want to require that this name has the version and way info appended to it. -We initialise the module tree by keeping a work-stack, +We initialise the module tree by keeping a work-stack, * pointed to by Sp * that grows downward * Sp points to the last occupied slot -} -mkModuleInit +mkModuleInit :: CollectedCCs -- cost centre info -> Module -> HpcInfo diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs index 0ba99aed36..ce5491dc10 100644 --- a/compiler/codeGen/StgCmmBind.hs +++ b/compiler/codeGen/StgCmmBind.hs @@ -22,7 +22,6 @@ import StgCmmCon import StgCmmHeap import StgCmmProf import StgCmmTicky -import StgCmmGran import StgCmmLayout import StgCmmUtils import StgCmmClosure @@ -58,22 +57,21 @@ import Control.Monad -- For closures bound at top level, allocate in static space. -- They should have no free variables. -cgTopRhsClosure :: RecFlag -- member of a recursive group? +cgTopRhsClosure :: DynFlags + -> RecFlag -- member of a recursive group? -> Id -> CostCentreStack -- Optional cost centre annotation -> StgBinderInfo -> UpdateFlag -> [Id] -- Args -> StgExpr - -> FCode (CgIdInfo, FCode ()) - -cgTopRhsClosure rec id ccs _ upd_flag args body - = do { dflags <- getDynFlags - ; lf_info <- mkClosureLFInfo id TopLevel [] upd_flag args - ; let closure_label = mkLocalClosureLabel (idName id) (idCafInfo id) - cg_id_info = litIdInfo dflags id lf_info (CmmLabel closure_label) - ; return (cg_id_info, gen_code dflags lf_info closure_label) - } + -> (CgIdInfo, FCode ()) + +cgTopRhsClosure dflags rec id ccs _ upd_flag args body = + let closure_label = mkLocalClosureLabel (idName id) (idCafInfo id) + cg_id_info = litIdInfo dflags id lf_info (CmmLabel closure_label) + lf_info = mkClosureLFInfo dflags id TopLevel [] upd_flag args + in (cg_id_info, gen_code dflags lf_info closure_label) where -- special case for a indirection (f = g). We create an IND_STATIC -- closure pointing directly to the indirectee. This is exactly @@ -106,7 +104,7 @@ cgTopRhsClosure rec id ccs _ upd_flag args body caffy = idCafInfo id info_tbl = mkCmmInfo closure_info -- XXX short-cut closure_rep = mkStaticClosureFields dflags info_tbl ccs caffy [] - + -- BUILD THE OBJECT, AND GENERATE INFO TABLE (IF NECESSARY) ; emitDataLits closure_label closure_rep ; let fv_details :: [(NonVoid Id, VirtualHpOffset)] @@ -115,7 +113,7 @@ cgTopRhsClosure rec id ccs _ upd_flag args body -- Don't drop the non-void args until the closure info has been made ; forkClosureBody (closureCodeBody True id closure_info ccs (nonVoidIds args) (length args) body fv_details) - + ; return () } unLit (CmmLit l) = l @@ -128,10 +126,9 @@ cgTopRhsClosure rec id ccs _ upd_flag args body cgBind :: StgBinding -> FCode () cgBind (StgNonRec name rhs) = do { (info, fcode) <- cgRhs name rhs - ; addBindC (cg_id info) info + ; addBindC info ; init <- fcode - ; emit init - } + ; emit init } -- init cannot be used in body, so slightly better to sink it eagerly cgBind (StgRec pairs) @@ -205,9 +202,10 @@ cgRhs :: Id ) cgRhs id (StgRhsCon cc con args) - = withNewTickyCounterThunk (idName id) $ + = withNewTickyCounterThunk False (idName id) $ -- False for "not static" buildDynCon id True cc con args +{- See Note [GC recovery] in compiler/codeGen/StgCmmClosure.hs -} cgRhs name (StgRhsClosure cc bi fvs upd_flag _srt args body) = do dflags <- getDynFlags mkRhsClosure dflags name cc bi (nonVoidIds fvs) upd_flag args body @@ -316,8 +314,8 @@ mkRhsClosure dflags bndr _cc _bi arity = length fvs ---------- Default case ------------------ -mkRhsClosure _ bndr cc _ fvs upd_flag args body - = do { lf_info <- mkClosureLFInfo bndr NotTopLevel fvs upd_flag args +mkRhsClosure dflags bndr cc _ fvs upd_flag args body + = do { let lf_info = mkClosureLFInfo dflags bndr NotTopLevel fvs upd_flag args ; (id_info, reg) <- rhsIdInfo bndr lf_info ; return (id_info, gen_code lf_info reg) } where @@ -383,7 +381,7 @@ cgRhsStdThunk bndr lf_info payload } where gen_code reg -- AHA! A STANDARD-FORM THUNK - = withNewTickyCounterStdThunk (idName bndr) $ + = withNewTickyCounterStdThunk False (idName bndr) $ -- False for "not static" do { -- LAY OUT THE OBJECT mod_name <- getModuleName @@ -399,7 +397,7 @@ cgRhsStdThunk bndr lf_info payload -- ; (use_cc, blame_cc) <- chooseDynCostCentres cc [{- no args-}] body ; let use_cc = curCCS; blame_cc = curCCS - ; tickyEnterStdThunk + ; tickyEnterStdThunk closure_info -- BUILD THE OBJECT ; let info_tbl = mkCmmInfo closure_info @@ -410,21 +408,22 @@ cgRhsStdThunk bndr lf_info payload ; return (mkRhsInit dflags reg lf_info hp_plus_n) } -mkClosureLFInfo :: Id -- The binder +mkClosureLFInfo :: DynFlags + -> Id -- The binder -> TopLevelFlag -- True of top level -> [NonVoid Id] -- Free vars -> UpdateFlag -- Update flag -> [Id] -- Args - -> FCode LambdaFormInfo -mkClosureLFInfo bndr top fvs upd_flag args - | null args = return (mkLFThunk (idType bndr) top (map unsafe_stripNV fvs) upd_flag) + -> LambdaFormInfo +mkClosureLFInfo dflags bndr top fvs upd_flag args + | null args = + mkLFThunk (idType bndr) top (map unsafe_stripNV fvs) upd_flag | otherwise = - do { arg_descr <- mkArgDescr (idName bndr) args - ; return (mkLFReEntrant top (map unsafe_stripNV fvs) args arg_descr) } + mkLFReEntrant top (map unsafe_stripNV fvs) args (mkArgDescr dflags args) ------------------------------------------------------------------------ --- The code for closures} +-- The code for closures ------------------------------------------------------------------------ closureCodeBody :: Bool -- whether this is a top-level binding @@ -452,8 +451,7 @@ closureCodeBody :: Bool -- whether this is a top-level binding closureCodeBody top_lvl bndr cl_info cc _args arity body fv_details | arity == 0 -- No args i.e. thunk - = ASSERT ( not (isStaticClosure cl_info) ) - withNewTickyCounterThunk (closureName cl_info) $ + = withNewTickyCounterThunk (isStaticClosure cl_info) (closureName cl_info) $ emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl [] $ \(_, node, _) -> thunkCode cl_info fv_details cc node arity body where @@ -478,7 +476,6 @@ closureCodeBody top_lvl bndr cl_info cc args arity body fv_details ; let node_points = nodeMustPointToIt dflags lf_info node' = if node_points then Just node else Nothing ; when node_points (ldvEnterClosure cl_info) - ; granYield arg_regs node_points -- Main payload ; entryHeapCheck cl_info node' arity arg_regs $ do @@ -542,14 +539,14 @@ thunkCode cl_info fv_details _cc node arity body ; let node_points = nodeMustPointToIt dflags (closureLFInfo cl_info) node' = if node_points then Just node else Nothing ; ldvEnterClosure cl_info -- NB: Node always points when profiling - ; granThunk node_points -- Heap overflow check ; entryHeapCheck cl_info node' arity [] $ do { -- Overwrite with black hole if necessary -- but *after* the heap-overflow check + ; tickyEnterThunk cl_info ; when (blackHoleOnEntry cl_info && node_points) - (blackHoleIt cl_info node) + (blackHoleIt node) -- Push update frame ; setupUpdate cl_info node $ @@ -557,7 +554,7 @@ thunkCode cl_info fv_details _cc node arity body -- that cc of enclosing scope will be recorded -- in update frame CAF/DICT functions will be -- subsumed by this enclosing cc - do { tickyEnterThunk + do { tickyEnterThunk cl_info ; enterCostCentreThunk (CmmReg nodeReg) ; let lf_info = closureLFInfo cl_info ; fv_bindings <- mapM bind_fv fv_details @@ -569,20 +566,20 @@ thunkCode cl_info fv_details _cc node arity body -- Update and black-hole wrappers ------------------------------------------------------------------------ -blackHoleIt :: ClosureInfo -> LocalReg -> FCode () +blackHoleIt :: LocalReg -> FCode () -- Only called for closures with no args -- Node points to the closure -blackHoleIt closure_info node - = emitBlackHoleCode (closureSingleEntry closure_info) (CmmReg (CmmLocal node)) +blackHoleIt node_reg + = emitBlackHoleCode (CmmReg (CmmLocal node_reg)) -emitBlackHoleCode :: Bool -> CmmExpr -> FCode () -emitBlackHoleCode is_single_entry node = do +emitBlackHoleCode :: CmmExpr -> FCode () +emitBlackHoleCode node = do dflags <- getDynFlags -- Eager blackholing is normally disabled, but can be turned on with -- -feager-blackholing. When it is on, we replace the info pointer -- of the thunk with stg_EAGER_BLACKHOLE_info on entry. - + -- If we wanted to do eager blackholing with slop filling, we'd need -- to do it at the *end* of a basic block, otherwise we overwrite -- the free variables in the thunk that we still need. We have a @@ -593,7 +590,7 @@ emitBlackHoleCode is_single_entry node = do -- on. But it didn't work, and it wasn't strictly necessary to bring -- back minimal ticky-ticky, so now EAGER_BLACKHOLING is -- unconditionally disabled. -- krc 1/2007 - + -- Note the eager-blackholing check is here rather than in blackHoleOnEntry, -- because emitBlackHoleCode is called from CmmParse. @@ -604,7 +601,6 @@ emitBlackHoleCode is_single_entry node = do -- work with profiling. when eager_blackholing $ do - tickyBlackHole (not is_single_entry) emitStore (cmmOffsetW dflags node (fixedHdrSize dflags)) (CmmReg (CmmGlobal CurrentTSO)) emitPrimCall [] MO_WriteBarrier [] @@ -615,7 +611,7 @@ setupUpdate :: ClosureInfo -> LocalReg -> FCode () -> FCode () -- so that the cost centre in the original closure can still be -- extracted by a subsequent enterCostCentre setupUpdate closure_info node body - | closureReEntrant closure_info + | not (lfUpdatable (closureLFInfo closure_info)) = body | not (isStaticClosure closure_info) @@ -736,7 +732,7 @@ link_caf node _is_upd = do -- This must be done *before* the info table pointer is overwritten, -- because the old info table ptr is needed for reversion ; ret <- newTemp (bWord dflags) - ; emitRtsCallGen [(ret,NoHint)] rtsPackageId (fsLit "newCAF") + ; emitRtsCallGen [(ret,NoHint)] (mkForeignLabel (fsLit "newCAF") Nothing ForeignLabelInExternalPackage IsFunction) [ (CmmReg (CmmGlobal BaseReg), AddrHint), (CmmReg (CmmLocal node), AddrHint), (hp_rel, AddrHint) ] diff --git a/compiler/codeGen/StgCmmClosure.hs b/compiler/codeGen/StgCmmClosure.hs index a057484d39..611a570d70 100644 --- a/compiler/codeGen/StgCmmClosure.hs +++ b/compiler/codeGen/StgCmmClosure.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- -- Stg to C-- code generation: --- +-- -- The types LambdaFormInfo -- ClosureInfo -- @@ -10,25 +10,19 @@ ----------------------------------------------------------------------------- {-# LANGUAGE RecordWildCards #-} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details module StgCmmClosure ( DynTag, tagForCon, isSmallFamily, - ConTagZ, dataConTagZ, + ConTagZ, dataConTagZ, idPrimRep, isVoidRep, isGcPtrRep, addIdReps, addArgReps, - argPrimRep, + argPrimRep, -- * LambdaFormInfo LambdaFormInfo, -- Abstract - StandardFormInfo, -- ...ditto... - mkLFThunk, mkLFReEntrant, mkConLFInfo, mkSelectorLFInfo, - mkApLFInfo, mkLFImported, mkLFArgument, mkLFLetNoEscape, + StandardFormInfo, -- ...ditto... + mkLFThunk, mkLFReEntrant, mkConLFInfo, mkSelectorLFInfo, + mkApLFInfo, mkLFImported, mkLFArgument, mkLFLetNoEscape, mkLFBlackHole, lfDynTag, maybeIsLFCon, isLFThunk, isLFReEntrant, lfUpdatable, @@ -39,7 +33,7 @@ module StgCmmClosure ( isKnownFun, funTag, tagForArity, -- * ClosureInfo - ClosureInfo, + ClosureInfo, mkClosureInfo, mkCmmInfo, @@ -91,7 +85,7 @@ import DynFlags import Util ----------------------------------------------------------------------------- --- Representations +-- Representations ----------------------------------------------------------------------------- -- Why are these here? @@ -119,7 +113,7 @@ isGcPtrRep _ = False ----------------------------------------------------------------------------- --- LambdaFormInfo +-- LambdaFormInfo ----------------------------------------------------------------------------- -- Information about an identifier, from the code generator's point of @@ -128,81 +122,81 @@ isGcPtrRep _ = False -- tail call or return that identifier. data LambdaFormInfo - = LFReEntrant -- Reentrant closure (a function) - TopLevelFlag -- True if top level - !RepArity -- Arity. Invariant: always > 0 - !Bool -- True <=> no fvs - ArgDescr -- Argument descriptor (should really be in ClosureInfo) - - | LFThunk -- Thunk (zero arity) - TopLevelFlag - !Bool -- True <=> no free vars - !Bool -- True <=> updatable (i.e., *not* single-entry) - StandardFormInfo - !Bool -- True <=> *might* be a function type - - | LFCon -- A saturated constructor application - DataCon -- The constructor - - | LFUnknown -- Used for function arguments and imported things. - -- We know nothing about this closure. - -- Treat like updatable "LFThunk"... - -- Imported things which we *do* know something about use - -- one of the other LF constructors (eg LFReEntrant for - -- known functions) - !Bool -- True <=> *might* be a function type - -- The False case is good when we want to enter it, - -- because then we know the entry code will do - -- For a function, the entry code is the fast entry point - - | LFUnLifted -- A value of unboxed type; - -- always a value, neeeds evaluation - - | LFLetNoEscape -- See LetNoEscape module for precise description - - | LFBlackHole -- Used for the closures allocated to hold the result - -- of a CAF. We want the target of the update frame to - -- be in the heap, so we make a black hole to hold it. + = LFReEntrant -- Reentrant closure (a function) + TopLevelFlag -- True if top level + !RepArity -- Arity. Invariant: always > 0 + !Bool -- True <=> no fvs + ArgDescr -- Argument descriptor (should really be in ClosureInfo) + + | LFThunk -- Thunk (zero arity) + TopLevelFlag + !Bool -- True <=> no free vars + !Bool -- True <=> updatable (i.e., *not* single-entry) + StandardFormInfo + !Bool -- True <=> *might* be a function type + + | LFCon -- A saturated constructor application + DataCon -- The constructor + + | LFUnknown -- Used for function arguments and imported things. + -- We know nothing about this closure. + -- Treat like updatable "LFThunk"... + -- Imported things which we *do* know something about use + -- one of the other LF constructors (eg LFReEntrant for + -- known functions) + !Bool -- True <=> *might* be a function type + -- The False case is good when we want to enter it, + -- because then we know the entry code will do + -- For a function, the entry code is the fast entry point + + | LFUnLifted -- A value of unboxed type; + -- always a value, needs evaluation + + | LFLetNoEscape -- See LetNoEscape module for precise description + + | LFBlackHole -- Used for the closures allocated to hold the result + -- of a CAF. We want the target of the update frame to + -- be in the heap, so we make a black hole to hold it. -- XXX we can very nearly get rid of this, but -- allocDynClosure needs a LambdaFormInfo ------------------------- --- StandardFormInfo tells whether this thunk has one of +-- StandardFormInfo tells whether this thunk has one of -- a small number of standard forms data StandardFormInfo = NonStandardThunk - -- Not of of the standard forms + -- The usual case: not of the standard forms | SelectorThunk - -- A SelectorThunk is of form - -- case x of - -- con a1,..,an -> ak - -- and the constructor is from a single-constr type. - WordOff -- 0-origin offset of ak within the "goods" of - -- constructor (Recall that the a1,...,an may be laid - -- out in the heap in a non-obvious order.) - - | ApThunk - -- An ApThunk is of form - -- x1 ... xn - -- The code for the thunk just pushes x2..xn on the stack and enters x1. - -- There are a few of these (for 1 <= n <= MAX_SPEC_AP_SIZE) pre-compiled - -- in the RTS to save space. - RepArity -- Arity, n + -- A SelectorThunk is of form + -- case x of + -- con a1,..,an -> ak + -- and the constructor is from a single-constr type. + WordOff -- 0-origin offset of ak within the "goods" of + -- constructor (Recall that the a1,...,an may be laid + -- out in the heap in a non-obvious order.) + + | ApThunk + -- An ApThunk is of form + -- x1 ... xn + -- The code for the thunk just pushes x2..xn on the stack and enters x1. + -- There are a few of these (for 1 <= n <= MAX_SPEC_AP_SIZE) pre-compiled + -- in the RTS to save space. + RepArity -- Arity, n ------------------------------------------------------ --- Building LambdaFormInfo +-- Building LambdaFormInfo ------------------------------------------------------ mkLFArgument :: Id -> LambdaFormInfo -mkLFArgument id - | isUnLiftedType ty = LFUnLifted +mkLFArgument id + | isUnLiftedType ty = LFUnLifted | might_be_a_function ty = LFUnknown True - | otherwise = LFUnknown False + | otherwise = LFUnknown False where ty = idType id @@ -211,23 +205,23 @@ mkLFLetNoEscape :: LambdaFormInfo mkLFLetNoEscape = LFLetNoEscape ------------- -mkLFReEntrant :: TopLevelFlag -- True of top level - -> [Id] -- Free vars - -> [Id] -- Args - -> ArgDescr -- Argument descriptor - -> LambdaFormInfo +mkLFReEntrant :: TopLevelFlag -- True of top level + -> [Id] -- Free vars + -> [Id] -- Args + -> ArgDescr -- Argument descriptor + -> LambdaFormInfo -mkLFReEntrant top fvs args arg_descr +mkLFReEntrant top fvs args arg_descr = LFReEntrant top (length args) (null fvs) arg_descr ------------- mkLFThunk :: Type -> TopLevelFlag -> [Id] -> UpdateFlag -> LambdaFormInfo mkLFThunk thunk_ty top fvs upd_flag = ASSERT( not (isUpdatable upd_flag) || not (isUnLiftedType thunk_ty) ) - LFThunk top (null fvs) - (isUpdatable upd_flag) - NonStandardThunk - (might_be_a_function thunk_ty) + LFThunk top (null fvs) + (isUpdatable upd_flag) + NonStandardThunk + (might_be_a_function thunk_ty) -------------- might_be_a_function :: Type -> Bool @@ -248,23 +242,23 @@ mkConLFInfo con = LFCon con ------------- mkSelectorLFInfo :: Id -> Int -> Bool -> LambdaFormInfo mkSelectorLFInfo id offset updatable - = LFThunk NotTopLevel False updatable (SelectorThunk offset) - (might_be_a_function (idType id)) + = LFThunk NotTopLevel False updatable (SelectorThunk offset) + (might_be_a_function (idType id)) ------------- mkApLFInfo :: Id -> UpdateFlag -> Arity -> LambdaFormInfo mkApLFInfo id upd_flag arity = LFThunk NotTopLevel (arity == 0) (isUpdatable upd_flag) (ApThunk arity) - (might_be_a_function (idType id)) + (might_be_a_function (idType id)) ------------- mkLFImported :: Id -> LambdaFormInfo mkLFImported id | Just con <- isDataConWorkId_maybe id , isNullaryRepDataCon con - = LFCon con -- An imported nullary constructor - -- We assume that the constructor is evaluated so that - -- the id really does point directly to the constructor + = LFCon con -- An imported nullary constructor + -- We assume that the constructor is evaluated so that + -- the id really does point directly to the constructor | arity > 0 = LFReEntrant TopLevel arity True (panic "arg_descr") @@ -279,25 +273,26 @@ mkLFBlackHole :: LambdaFormInfo mkLFBlackHole = LFBlackHole ----------------------------------------------------- --- Dynamic pointer tagging +-- Dynamic pointer tagging ----------------------------------------------------- -type ConTagZ = Int -- A *zero-indexed* contructor tag - -type DynTag = Int -- The tag on a *pointer* - -- (from the dynamic-tagging paper) +type ConTagZ = Int -- A *zero-indexed* contructor tag -{- Note [Data constructor dynamic tags] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The family size of a data type (the number of constructors -or the arity of a function) can be either: - * small, if the family size < 2**tag_bits - * big, otherwise. +type DynTag = Int -- The tag on a *pointer* + -- (from the dynamic-tagging paper) -Small families can have the constructor tag in the tag bits. -Big families only use the tag value 1 to represent evaluatedness. -We don't have very many tag bits: for example, we have 2 bits on -x86-32 and 3 bits on x86-64. -} +-- Note [Data constructor dynamic tags] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- The family size of a data type (the number of constructors +-- or the arity of a function) can be either: +-- * small, if the family size < 2**tag_bits +-- * big, otherwise. +-- +-- Small families can have the constructor tag in the tag bits. +-- Big families only use the tag value 1 to represent evaluatedness. +-- We don't have very many tag bits: for example, we have 2 bits on +-- x86-32 and 3 bits on x86-64. isSmallFamily :: DynFlags -> Int -> Bool isSmallFamily dflags fam_size = fam_size <= mAX_PTR_TAG dflags @@ -329,7 +324,7 @@ lfDynTag _ _other = 0 ----------------------------------------------------------------------------- --- Observing LambdaFormInfo +-- Observing LambdaFormInfo ----------------------------------------------------------------------------- ------------- @@ -341,9 +336,9 @@ maybeIsLFCon _ = Nothing isLFThunk :: LambdaFormInfo -> Bool isLFThunk (LFThunk {}) = True isLFThunk LFBlackHole = True - -- return True for a blackhole: this function is used to determine - -- whether to use the thunk header in SMP mode, and a blackhole - -- must have one. + -- return True for a blackhole: this function is used to determine + -- whether to use the thunk header in SMP mode, and a blackhole + -- must have one. isLFThunk _ = False isLFReEntrant :: LambdaFormInfo -> Bool @@ -351,7 +346,7 @@ isLFReEntrant (LFReEntrant {}) = True isLFReEntrant _ = False ----------------------------------------------------------------------------- --- Choosing SM reps +-- Choosing SM reps ----------------------------------------------------------------------------- lfClosureType :: LambdaFormInfo -> ClosureTypeInfo @@ -371,118 +366,137 @@ thunkClosureType _ = Thunk -- to FUN_STATIC in this case. ----------------------------------------------------------------------------- --- nodeMustPointToIt +-- nodeMustPointToIt ----------------------------------------------------------------------------- nodeMustPointToIt :: DynFlags -> LambdaFormInfo -> Bool -nodeMustPointToIt _ (LFReEntrant top _ no_fvs _) - = not no_fvs || -- Certainly if it has fvs we need to point to it - isNotTopLevel top - -- If it is not top level we will point to it - -- We can have a \r closure with no_fvs which - -- is not top level as special case cgRhsClosure - -- has been dissabled in favour of let floating +-- If nodeMustPointToIt is true, then the entry convention for +-- this closure has R1 (the "Node" register) pointing to the +-- closure itself --- the "self" argument - -- For lex_profiling we also access the cost centre for a - -- non-inherited function i.e. not top level - -- the not top case above ensures this is ok. +nodeMustPointToIt _ (LFReEntrant top _ no_fvs _) + = not no_fvs -- Certainly if it has fvs we need to point to it + || isNotTopLevel top -- See Note [GC recovery] + -- For lex_profiling we also access the cost centre for a + -- non-inherited (i.e. non-top-level) function. + -- The isNotTopLevel test above ensures this is ok. + +nodeMustPointToIt dflags (LFThunk top no_fvs updatable NonStandardThunk _) + = not no_fvs -- Self parameter + || isNotTopLevel top -- Note [GC recovery] + || updatable -- Need to push update frame + || gopt Opt_SccProfilingOn dflags + -- For the non-updatable (single-entry case): + -- + -- True if has fvs (in which case we need access to them, and we + -- should black-hole it) + -- or profiling (in which case we need to recover the cost centre + -- from inside it) ToDo: do we need this even for + -- top-level thunks? If not, + -- isNotTopLevel subsumes this + +nodeMustPointToIt _ (LFThunk {}) -- Node must point to a standard-form thunk + = True nodeMustPointToIt _ (LFCon _) = True - -- Strictly speaking, the above two don't need Node to point - -- to it if the arity = 0. But this is a *really* unlikely - -- situation. If we know it's nil (say) and we are entering - -- it. Eg: let x = [] in x then we will certainly have inlined - -- x, since nil is a simple atom. So we gain little by not - -- having Node point to known zero-arity things. On the other - -- hand, we do lose something; Patrick's code for figuring out - -- when something has been updated but not entered relies on - -- having Node point to the result of an update. SLPJ - -- 27/11/92. - -nodeMustPointToIt dflags (LFThunk _ no_fvs updatable NonStandardThunk _) - = updatable || not no_fvs || gopt Opt_SccProfilingOn dflags - -- For the non-updatable (single-entry case): - -- - -- True if has fvs (in which case we need access to them, and we - -- should black-hole it) - -- or profiling (in which case we need to recover the cost centre - -- from inside it) - -nodeMustPointToIt _ (LFThunk {}) -- Node must point to a standard-form thunk - = True + -- Strictly speaking, the above two don't need Node to point + -- to it if the arity = 0. But this is a *really* unlikely + -- situation. If we know it's nil (say) and we are entering + -- it. Eg: let x = [] in x then we will certainly have inlined + -- x, since nil is a simple atom. So we gain little by not + -- having Node point to known zero-arity things. On the other + -- hand, we do lose something; Patrick's code for figuring out + -- when something has been updated but not entered relies on + -- having Node point to the result of an update. SLPJ + -- 27/11/92. nodeMustPointToIt _ (LFUnknown _) = True nodeMustPointToIt _ LFUnLifted = False nodeMustPointToIt _ LFBlackHole = True -- BH entry may require Node to point -nodeMustPointToIt _ LFLetNoEscape = False +nodeMustPointToIt _ LFLetNoEscape = False + +{- Note [GC recovery] +~~~~~~~~~~~~~~~~~~~~~ +If we a have a local let-binding (function or thunk) + let f = <body> in ... +AND <body> allocates, then the heap-overflow check needs to know how +to re-start the evaluation. It uses the "self" pointer to do this. +So even if there are no free variables in <body>, we still make +nodeMustPointToIt be True for non-top-level bindings. + +Why do any such bindings exist? After all, let-floating should have +floated them out. Well, a clever optimiser might leave one there to +avoid a space leak, deliberately recomputing a thunk. Also (and this +really does happen occasionally) let-floating may make a function f smaller +so it can be inlined, so now (f True) may generate a local no-fv closure. +This actually happened during bootsrapping GHC itself, with f=mkRdrFunBind +in TcGenDeriv.) -} ----------------------------------------------------------------------------- --- getCallMethod +-- getCallMethod ----------------------------------------------------------------------------- {- The entry conventions depend on the type of closure being entered, whether or not it has free variables, and whether we're running sequentially or in parallel. -Closure Node Argument Enter -Characteristics Par Req'd Passing Via +Closure Node Argument Enter +Characteristics Par Req'd Passing Via ------------------------------------------------------------------------------- -Unknown & no & yes & stack & node -Known fun (>1 arg), no fvs & no & no & registers & fast entry (enough args) - & slow entry (otherwise) -Known fun (>1 arg), fvs & no & yes & registers & fast entry (enough args) -0 arg, no fvs \r,\s & no & no & n/a & direct entry -0 arg, no fvs \u & no & yes & n/a & node -0 arg, fvs \r,\s & no & yes & n/a & direct entry -0 arg, fvs \u & no & yes & n/a & node - -Unknown & yes & yes & stack & node -Known fun (>1 arg), no fvs & yes & no & registers & fast entry (enough args) - & slow entry (otherwise) -Known fun (>1 arg), fvs & yes & yes & registers & node -0 arg, no fvs \r,\s & yes & no & n/a & direct entry -0 arg, no fvs \u & yes & yes & n/a & node -0 arg, fvs \r,\s & yes & yes & n/a & node -0 arg, fvs \u & yes & yes & n/a & node -\end{tabular} +Unknown & no & yes & stack & node +Known fun (>1 arg), no fvs & no & no & registers & fast entry (enough args) + & slow entry (otherwise) +Known fun (>1 arg), fvs & no & yes & registers & fast entry (enough args) +0 arg, no fvs \r,\s & no & no & n/a & direct entry +0 arg, no fvs \u & no & yes & n/a & node +0 arg, fvs \r,\s & no & yes & n/a & direct entry +0 arg, fvs \u & no & yes & n/a & node +Unknown & yes & yes & stack & node +Known fun (>1 arg), no fvs & yes & no & registers & fast entry (enough args) + & slow entry (otherwise) +Known fun (>1 arg), fvs & yes & yes & registers & node +0 arg, no fvs \r,\s & yes & no & n/a & direct entry +0 arg, no fvs \u & yes & yes & n/a & node +0 arg, fvs \r,\s & yes & yes & n/a & node +0 arg, fvs \u & yes & yes & n/a & node When black-holing, single-entry closures could also be entered via node (rather than directly) to catch double-entry. -} data CallMethod - = EnterIt -- No args, not a function + = EnterIt -- No args, not a function - | JumpToIt -- A join point + | JumpToIt -- A join point - | ReturnIt -- It's a value (function, unboxed value, - -- or constructor), so just return it. + | ReturnIt -- It's a value (function, unboxed value, + -- or constructor), so just return it. - | SlowCall -- Unknown fun, or known fun with - -- too few args. + | SlowCall -- Unknown fun, or known fun with + -- too few args. - | DirectEntry -- Jump directly, with args in regs - CLabel -- The code label - RepArity -- Its arity + | DirectEntry -- Jump directly, with args in regs + CLabel -- The code label + RepArity -- Its arity getCallMethod :: DynFlags -> Name -- Function being applied -> CafInfo -- Can it refer to CAF's? - -> LambdaFormInfo -- Its info - -> RepArity -- Number of available arguments - -> CallMethod + -> LambdaFormInfo -- Its info + -> RepArity -- Number of available arguments + -> CallMethod getCallMethod dflags _name _ lf_info _n_args | nodeMustPointToIt dflags lf_info && gopt Opt_Parallel dflags - = -- If we're parallel, then we must always enter via node. - -- The reason is that the closure may have been - -- fetched since we allocated it. + = -- If we're parallel, then we must always enter via node. + -- The reason is that the closure may have been + -- fetched since we allocated it. EnterIt 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 + ReturnIt -- No args at all + | n_args < arity = SlowCall -- Not enough args | otherwise = DirectEntry (enterIdLabel dflags name caf) arity getCallMethod _ _name _ LFUnLifted n_args @@ -492,17 +506,17 @@ getCallMethod _ _name _ (LFCon _) n_args = ASSERT( n_args == 0 ) ReturnIt getCallMethod dflags name caf (LFThunk _ _ updatable std_form_info is_fun) n_args - | is_fun -- it *might* be a function, so we must "call" it (which is always safe) - = SlowCall -- We cannot just enter it [in eval/apply, the entry code - -- is the fast-entry code] + | is_fun -- it *might* be a function, so we must "call" it (which is always safe) + = SlowCall -- We cannot just enter it [in eval/apply, the entry code + -- is the fast-entry code] -- Since is_fun is False, we are *definitely* looking at a data value | updatable || gopt Opt_Ticky dflags -- to catch double entry {- OLD: || opt_SMP - I decided to remove this, because in SMP mode it doesn't matter - if we enter the same thunk multiple times, so the optimisation - of jumping directly to the entry code is still valid. --SDM - -} + I decided to remove this, because in SMP mode it doesn't matter + if we enter the same thunk multiple times, so the optimisation + of jumping directly to the entry code is still valid. --SDM + -} = EnterIt -- We used to have ASSERT( n_args == 0 ), but actually it is -- possible for the optimiser to generate @@ -511,7 +525,7 @@ getCallMethod dflags name caf (LFThunk _ _ updatable std_form_info is_fun) n_arg -- This happens as a result of the case-of-error transformation -- So the right thing to do is just to enter the thing - | otherwise -- Jump direct to code for single-entry thunks + | otherwise -- Jump direct to code for single-entry thunks = ASSERT( n_args == 0 ) DirectEntry (thunkEntryLabel dflags name caf std_form_info updatable) 0 @@ -519,24 +533,24 @@ getCallMethod _ _name _ (LFUnknown True) _n_args = SlowCall -- might be a function getCallMethod _ name _ (LFUnknown False) n_args - = ASSERT2 ( n_args == 0, ppr name <+> ppr n_args ) + = ASSERT2( n_args == 0, ppr name <+> ppr n_args ) EnterIt -- Not a function getCallMethod _ _name _ LFBlackHole _n_args - = SlowCall -- Presumably the black hole has by now - -- been updated, but we don't know with - -- what, so we slow call it + = SlowCall -- Presumably the black hole has by now + -- been updated, but we don't know with + -- what, so we slow call it getCallMethod _ _name _ LFLetNoEscape _n_args = JumpToIt isKnownFun :: LambdaFormInfo -> Bool isKnownFun (LFReEntrant _ _ _ _) = True -isKnownFun LFLetNoEscape = True +isKnownFun LFLetNoEscape = True isKnownFun _ = False ----------------------------------------------------------------------------- --- staticClosureRequired +-- staticClosureRequired ----------------------------------------------------------------------------- {- staticClosureRequired is never called (hence commented out) @@ -559,16 +573,16 @@ have closure, info table, and entry code.] * Fast-entry code ALWAYS NEEDED * Slow-entry code - Needed iff (a) we have any un-saturated calls to the function - OR (b) the function is passed as an arg - OR (c) we're in the parallel world and the function has free vars - [Reason: in parallel world, we always enter functions - with free vars via the closure.] + Needed iff (a) we have any un-saturated calls to the function + OR (b) the function is passed as an arg + OR (c) we're in the parallel world and the function has free vars + [Reason: in parallel world, we always enter functions + with free vars via the closure.] * The function closure - Needed iff (a) we have any un-saturated calls to the function - OR (b) the function is passed as an arg - OR (c) if the function has free vars (ie not top level) + Needed iff (a) we have any un-saturated calls to the function + OR (b) the function is passed as an arg + OR (c) if the function has free vars (ie not top level) Why case (a) here? Because if the arg-satis check fails, UpdatePAP stuffs a pointer to the function closure in the PAP. @@ -578,9 +592,9 @@ have closure, info table, and entry code.] [NB: these conditions imply that we might need the closure without the slow-entry code. Here's how. - f x y = let g w = ...x..y..w... - in - ...(g t)... + f x y = let g w = ...x..y..w... + in + ...(g t)... Here we need a closure for g which contains x and y, but since the calls are all saturated we just jump to the @@ -588,35 +602,35 @@ have closure, info table, and entry code.] * Standard info table - Needed iff (a) we have any un-saturated calls to the function - OR (b) the function is passed as an arg - OR (c) the function has free vars (ie not top level) - - NB. In the sequential world, (c) is only required so that the function closure has - an info table to point to, to keep the storage manager happy. - If (c) alone is true we could fake up an info table by choosing - one of a standard family of info tables, whose entry code just - bombs out. - - [NB In the parallel world (c) is needed regardless because - we enter functions with free vars via the closure.] - - If (c) is retained, then we'll sometimes generate an info table - (for storage mgr purposes) without slow-entry code. Then we need - to use an error label in the info table to substitute for the absent - slow entry code. + Needed iff (a) we have any un-saturated calls to the function + OR (b) the function is passed as an arg + OR (c) the function has free vars (ie not top level) + + NB. In the sequential world, (c) is only required so that the function closure has + an info table to point to, to keep the storage manager happy. + If (c) alone is true we could fake up an info table by choosing + one of a standard family of info tables, whose entry code just + bombs out. + + [NB In the parallel world (c) is needed regardless because + we enter functions with free vars via the closure.] + + If (c) is retained, then we'll sometimes generate an info table + (for storage mgr purposes) without slow-entry code. Then we need + to use an error label in the info table to substitute for the absent + slow entry code. -} staticClosureRequired - :: Name - -> StgBinderInfo - -> LambdaFormInfo - -> Bool + :: Name + -> StgBinderInfo + -> LambdaFormInfo + -> Bool staticClosureRequired binder bndr_info - (LFReEntrant top_level _ _ _) -- It's a function + (LFReEntrant top_level _ _ _) -- It's a function = ASSERT( isTopLevel top_level ) - -- Assumption: it's a top-level, no-free-var binding - not (satCallsOnly bndr_info) + -- Assumption: it's a top-level, no-free-var binding + not (satCallsOnly bndr_info) staticClosureRequired binder other_binder_info other_lf_info = True -} @@ -639,7 +653,7 @@ staticClosureRequired binder other_binder_info other_lf_info = True a) to construct the info table itself, and build other things related to the binding (e.g. slow entry points for a function) b) to allocate a closure containing that info pointer (i.e. - it knows the info table label) + it knows the info table label) -} data ClosureInfo @@ -668,22 +682,22 @@ mkCmmInfo ClosureInfo {..} -------------------------------------- --- Building ClosureInfos +-- Building ClosureInfos -------------------------------------- mkClosureInfo :: DynFlags - -> Bool -- Is static - -> Id - -> LambdaFormInfo - -> Int -> Int -- Total and pointer words + -> Bool -- Is static + -> Id + -> LambdaFormInfo + -> Int -> Int -- Total and pointer words -> String -- String descriptor - -> ClosureInfo + -> ClosureInfo mkClosureInfo dflags is_static id lf_info tot_wds ptr_wds val_descr - = ClosureInfo { closureName = name, - closureLFInfo = lf_info, - closureInfoLabel = info_lbl, -- These three fields are - closureSMRep = sm_rep, -- (almost) an info table - closureProf = prof } -- (we don't have an SRT yet) + = ClosureInfo { closureName = name + , closureLFInfo = lf_info + , closureInfoLabel = info_lbl -- These three fields are + , closureSMRep = sm_rep -- (almost) an info table + , closureProf = prof } -- (we don't have an SRT yet) where name = idName id sm_rep = mkHeapRep dflags is_static ptr_wds nonptr_wds (lfClosureType lf_info) @@ -708,8 +722,8 @@ mkClosureInfo dflags is_static id lf_info tot_wds ptr_wds val_descr -- -- -- Previously, eager blackholing was enabled when ticky-ticky --- was on. But it didn't work, and it wasn't strictly necessary --- to bring back minimal ticky-ticky, so now EAGER_BLACKHOLING +-- was on. But it didn't work, and it wasn't strictly necessary +-- to bring back minimal ticky-ticky, so now EAGER_BLACKHOLING -- is unconditionally disabled. -- krc 1/2007 -- Static closures are never themselves black-holed. @@ -717,12 +731,12 @@ mkClosureInfo dflags is_static id lf_info tot_wds ptr_wds val_descr blackHoleOnEntry :: ClosureInfo -> Bool blackHoleOnEntry cl_info | isStaticRep (closureSMRep cl_info) - = False -- Never black-hole a static closure + = False -- Never black-hole a static closure | otherwise = case closureLFInfo cl_info of - LFReEntrant _ _ _ _ -> False - LFLetNoEscape -> False + LFReEntrant _ _ _ _ -> False + LFLetNoEscape -> False LFThunk _ _no_fvs _updatable _ _ -> True _other -> panic "blackHoleOnEntry" -- Should never happen @@ -734,9 +748,9 @@ closureUpdReqd ClosureInfo{ closureLFInfo = lf_info } = lfUpdatable lf_info lfUpdatable :: LambdaFormInfo -> Bool lfUpdatable (LFThunk _ _ upd _ _) = upd -lfUpdatable LFBlackHole = True - -- Black-hole closures are allocated to receive the results of an - -- alg case with a named default... so they need to be updated. +lfUpdatable LFBlackHole = True + -- Black-hole closures are allocated to receive the results of an + -- alg case with a named default... so they need to be updated. lfUpdatable _ = False closureSingleEntry :: ClosureInfo -> Bool @@ -763,7 +777,7 @@ isToplevClosure (ClosureInfo { closureLFInfo = lf_info }) = case lf_info of LFReEntrant TopLevel _ _ _ -> True LFThunk TopLevel _ _ _ _ -> True - _other -> False + _other -> False -------------------------------------- -- Label generation @@ -785,17 +799,17 @@ mkClosureInfoTableLabel id lf_info = case lf_info of LFBlackHole -> mkCAFBlackHoleInfoTableLabel - LFThunk _ _ upd_flag (SelectorThunk offset) _ + LFThunk _ _ upd_flag (SelectorThunk offset) _ -> mkSelectorInfoLabel upd_flag offset - LFThunk _ _ upd_flag (ApThunk arity) _ + LFThunk _ _ upd_flag (ApThunk arity) _ -> mkApInfoTableLabel upd_flag arity LFThunk{} -> std_mk_lbl name cafs LFReEntrant{} -> std_mk_lbl name cafs _other -> panic "closureInfoTableLabel" - where + where name = idName id std_mk_lbl | is_local = mkLocalInfoTableLabel @@ -860,16 +874,16 @@ getTyDescription :: Type -> String getTyDescription ty = case (tcSplitSigmaTy ty) of { (_, _, tau_ty) -> case tau_ty of - TyVarTy _ -> "*" - AppTy fun _ -> getTyDescription fun - FunTy _ res -> '-' : '>' : fun_result res - TyConApp tycon _ -> getOccString tycon + TyVarTy _ -> "*" + AppTy fun _ -> getTyDescription fun + FunTy _ res -> '-' : '>' : fun_result res + TyConApp tycon _ -> getOccString tycon ForAllTy _ ty -> getTyDescription ty LitTy n -> getTyLitDescription n } where fun_result (FunTy _ res) = '>' : fun_result res - fun_result other = getTyDescription other + fun_result other = getTyDescription other getTyLitDescription :: TyLit -> String getTyLitDescription l = @@ -923,8 +937,8 @@ indStaticInfoTable staticClosureNeedsLink :: Bool -> CmmInfoTable -> Bool -- A static closure needs a link field to aid the GC when traversing -- the static closure graph. But it only needs such a field if either --- a) it has an SRT --- b) it's a constructor with one or more pointer fields +-- a) it has an SRT +-- b) it's a constructor with one or more pointer fields -- In case (b), the constructor's fields themselves play the role -- of the SRT. -- diff --git a/compiler/codeGen/StgCmmCon.hs b/compiler/codeGen/StgCmmCon.hs index d2a25ebd6c..57d4759346 100644 --- a/compiler/codeGen/StgCmmCon.hs +++ b/compiler/codeGen/StgCmmCon.hs @@ -50,24 +50,24 @@ import Data.Char -- Top-level constructors --------------------------------------------------------------- -cgTopRhsCon :: Id -- Name of thing bound to this RHS +cgTopRhsCon :: DynFlags + -> Id -- Name of thing bound to this RHS -> DataCon -- Id -> [StgArg] -- Args - -> FCode (CgIdInfo, FCode ()) -cgTopRhsCon id con args - = do dflags <- getDynFlags - let id_info = litIdInfo dflags id (mkConLFInfo con) (CmmLabel closure_label) - return ( id_info, gen_code ) + -> (CgIdInfo, FCode ()) +cgTopRhsCon dflags id con args = + let id_info = litIdInfo dflags id (mkConLFInfo con) (CmmLabel closure_label) + in (id_info, gen_code) where name = idName id caffy = idCafInfo id -- any stgArgHasCafRefs args closure_label = mkClosureLabel name caffy gen_code = - do { dflags <- getDynFlags + do { this_mod <- getModuleName ; when (platformOS (targetPlatform dflags) == OSMinGW32) $ -- Windows DLLs have a problem with static cross-DLL refs. - ASSERT( not (isDllConApp dflags con args) ) return () + ASSERT( not (isDllConApp dflags this_mod con args) ) return () ; ASSERT( args `lengthIs` dataConRepRepArity con ) return () -- LAY IT OUT @@ -234,7 +234,7 @@ buildDynCon' dflags _ binder actually_bound ccs con args use_cc -- cost-centre to stick in the object | isCurrentCCS ccs = curCCS | otherwise = panic "buildDynCon: non-current CCS not implemented" - + blame_cc = use_cc -- cost-centre on which to blame the alloc (same) diff --git a/compiler/codeGen/StgCmmEnv.hs b/compiler/codeGen/StgCmmEnv.hs index 1fdb364b56..353fec5a5f 100644 --- a/compiler/codeGen/StgCmmEnv.hs +++ b/compiler/codeGen/StgCmmEnv.hs @@ -8,8 +8,6 @@ module StgCmmEnv ( CgIdInfo, - cgIdInfoId, cgIdInfoLF, - litIdInfo, lneIdInfo, rhsIdInfo, mkRhsInit, idInfoToAmode, @@ -20,8 +18,8 @@ module StgCmmEnv ( bindArgsToRegs, bindToReg, rebindToReg, bindArgToReg, idToReg, getArgAmode, getNonVoidArgAmodes, - getCgIdInfo, - maybeLetNoEscape, + getCgIdInfo, + maybeLetNoEscape, ) where #include "HsVersions.h" @@ -113,12 +111,6 @@ addDynTag :: DynFlags -> CmmExpr -> DynTag -> CmmExpr -- A tag adds a byte offset to the pointer addDynTag dflags expr tag = cmmOffsetB dflags expr tag -cgIdInfoId :: CgIdInfo -> Id -cgIdInfoId = cg_id - -cgIdInfoLF :: CgIdInfo -> LambdaFormInfo -cgIdInfoLF = cg_lf - maybeLetNoEscape :: CgIdInfo -> Maybe (BlockId, [LocalReg]) maybeLetNoEscape (CgIdInfo { cg_loc = LneLoc blk_id args}) = Just (blk_id, args) maybeLetNoEscape _other = Nothing @@ -127,15 +119,15 @@ maybeLetNoEscape _other = Nothing --------------------------------------------------------- -- The binding environment --- --- There are three basic routines, for adding (addBindC), +-- +-- There are three basic routines, for adding (addBindC), -- modifying(modifyBindC) and looking up (getCgIdInfo) bindings. --------------------------------------------------------- -addBindC :: Id -> CgIdInfo -> FCode () -addBindC name stuff_to_bind = do +addBindC :: CgIdInfo -> FCode () +addBindC stuff_to_bind = do binds <- getBinds - setBinds $ extendVarEnv binds name stuff_to_bind + setBinds $ extendVarEnv binds (cg_id stuff_to_bind) stuff_to_bind addBindsC :: [CgIdInfo] -> FCode () addBindsC new_bindings = do @@ -147,39 +139,26 @@ addBindsC new_bindings = do getCgIdInfo :: Id -> FCode CgIdInfo getCgIdInfo id - = do { -- Try local bindings first - ; local_binds <- getBinds + = do { dflags <- getDynFlags + ; local_binds <- getBinds -- Try local bindings first ; case lookupVarEnv local_binds id of { Just info -> return info ; - Nothing -> do - - { -- Try top-level bindings - static_binds <- getStaticBinds - ; case lookupVarEnv static_binds id of { - Just info -> return info ; - Nothing -> + Nothing -> do { -- Should be imported; make up a CgIdInfo for it - let - name = idName id - in - if isExternalName name then do - let ext_lbl = CmmLabel (mkClosureLabel name $ idCafInfo id) - dflags <- getDynFlags - return (litIdInfo dflags id (mkLFImported id) ext_lbl) - else - -- Bug - cgLookupPanic id - }}}} - + let name = idName id + ; if isExternalName name then + let ext_lbl = CmmLabel (mkClosureLabel name $ idCafInfo id) + in return (litIdInfo dflags id (mkLFImported id) ext_lbl) + else + cgLookupPanic id -- Bug + }}} + cgLookupPanic :: Id -> FCode a cgLookupPanic id - = do static_binds <- getStaticBinds - local_binds <- getBinds + = do local_binds <- getBinds pprPanic "StgCmmEnv: variable not found" (vcat [ppr id, - ptext (sLit "static binds for:"), - vcat [ ppr (cg_id info) | info <- varEnvElts static_binds ], ptext (sLit "local binds for:"), vcat [ ppr (cg_id info) | info <- varEnvElts local_binds ] ]) @@ -192,7 +171,7 @@ getArgAmode (NonVoid (StgVarArg var)) = getArgAmode (NonVoid (StgLitArg lit)) = liftM CmmLit $ cgLit lit getNonVoidArgAmodes :: [StgArg] -> FCode [CmmExpr] --- NB: Filters out void args, +-- NB: Filters out void args, -- so the result list may be shorter than the argument list getNonVoidArgAmodes [] = return [] getNonVoidArgAmodes (arg:args) @@ -210,15 +189,15 @@ bindToReg :: NonVoid Id -> LambdaFormInfo -> FCode LocalReg bindToReg nvid@(NonVoid id) lf_info = do dflags <- getDynFlags let reg = idToReg dflags nvid - addBindC id (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg))) + addBindC (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg))) return reg rebindToReg :: NonVoid Id -> FCode LocalReg --- Like bindToReg, but the Id is already in scope, so +-- Like bindToReg, but the Id is already in scope, so -- get its LF info from the envt rebindToReg nvid@(NonVoid id) = do { info <- getCgIdInfo id - ; bindToReg nvid (cgIdInfoLF info) } + ; bindToReg nvid (cg_lf info) } bindArgToReg :: NonVoid Id -> FCode LocalReg bindArgToReg nvid@(NonVoid id) = bindToReg nvid (mkLFArgument id) @@ -233,7 +212,7 @@ idToReg :: DynFlags -> NonVoid Id -> LocalReg -- We re-use the Unique from the Id to make it easier to see what is going on -- -- By now the Ids should be uniquely named; else one would worry --- about accidental collision +-- about accidental collision idToReg dflags (NonVoid id) = LocalReg (idUnique id) (case idPrimRep id of VoidRep -> pprPanic "idToReg" (ppr id) diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs index d7edf8e193..24b12f7237 100644 --- a/compiler/codeGen/StgCmmExpr.hs +++ b/compiler/codeGen/StgCmmExpr.hs @@ -43,7 +43,6 @@ import Maybes import Util import FastString import Outputable -import UniqSupply import Control.Monad (when,void) @@ -70,8 +69,8 @@ cgExpr (StgLit lit) = do cmm_lit <- cgLit lit cgExpr (StgLet binds expr) = do { cgBind binds; cgExpr expr } cgExpr (StgLetNoEscape _ _ binds expr) = - do { us <- newUniqSupply - ; let join_id = mkBlockId (uniqFromSupply us) + do { u <- newUnique + ; let join_id = mkBlockId u ; cgLneBinds join_id binds ; r <- cgExpr expr ; emitLabel join_id @@ -107,7 +106,7 @@ cgLneBinds join_id (StgNonRec bndr rhs) -- See Note [Saving the current cost centre] ; (info, fcode) <- cgLetNoEscapeRhs join_id local_cc bndr rhs ; fcode - ; addBindC (cg_id info) info } + ; addBindC info } cgLneBinds join_id (StgRec pairs) = do { local_cc <- saveCurrentCostCentre @@ -142,9 +141,9 @@ cgLetNoEscapeRhsBody local_cc bndr (StgRhsClosure cc _bi _ _upd _ args body) = cgLetNoEscapeClosure bndr local_cc cc (nonVoidIds args) body cgLetNoEscapeRhsBody local_cc bndr (StgRhsCon cc con args) = cgLetNoEscapeClosure bndr local_cc cc [] (StgConApp con args) - -- For a constructor RHS we want to generate a single chunk of - -- code which can be jumped to from many places, which will - -- return the constructor. It's easy; just behave as if it + -- For a constructor RHS we want to generate a single chunk of + -- code which can be jumped to from many places, which will + -- return the constructor. It's easy; just behave as if it -- was an StgRhsClosure with a ConApp inside! ------------------------- @@ -194,9 +193,9 @@ heapcheck will take their worst case into account. In favour of omitting !Q!, !R!: - *May* save a heap overflow test, - if ...P... allocates anything. + if ...P... allocates anything. - - We can use relative addressing from a single Hp to + - We can use relative addressing from a single Hp to get at all the closures so allocated. - No need to save volatile vars etc across heap checks @@ -204,7 +203,7 @@ In favour of omitting !Q!, !R!: Against omitting !Q!, !R! - - May put a heap-check into the inner loop. Suppose + - May put a heap-check into the inner loop. Suppose the main loop is P -> R -> P -> R... Q is the loop exit, and only it does allocation. This only hurts us if P does no allocation. If P allocates, @@ -213,7 +212,7 @@ Against omitting !Q!, !R! - May do more allocation than reqd. This sometimes bites us badly. For example, nfib (ha!) allocates about 30\% more space if the worst-casing is done, because many many calls to nfib are leaf calls - which don't need to allocate anything. + which don't need to allocate anything. We can un-allocate, but that costs an instruction @@ -249,7 +248,7 @@ Hence: two basic plans for ...save current cost centre... - ...code for e, + ...code for e, with sequel (SetLocals r) ...restore current cost centre... @@ -314,13 +313,20 @@ cgCase (StgOpApp (StgPrimOp op) args _) bndr (AlgAlt tycon) alts {- Note [case on bool] - +~~~~~~~~~~~~~~~~~~~ This special case handles code like case a <# b of True -> False -> +--> case tagToEnum# (a <$# b) of + True -> .. ; False -> ... + +--> case (a <$# b) of r -> + case tagToEnum# r of + True -> .. ; False -> ... + If we let the ordinary case code handle it, we'll get something like tmp1 = a < b @@ -339,8 +345,12 @@ So we add a special case to generate and later optimisations will further improve this. -We should really change all these primops to return Int# instead, that -would make this special case go away. +Now that #6135 has been resolved it should be possible to remove that +special case. The idea behind this special case and pre-6135 implementation +of Bool-returning primops was that tagToEnum# was added implicitly in the +codegen and then optimized away. Now the call to tagToEnum# is explicit +in the source code, which allows to optimize it away at the earlier stages +of compilation (i.e. at the Core level). -} @@ -499,7 +509,7 @@ cgAlts gc_plan bndr (PrimAlt _) alts -- PrimAlts always have a DEFAULT case -- and it always comes first - tagged_cmms' = [(lit,code) + tagged_cmms' = [(lit,code) | (LitAlt lit, code) <- tagged_cmms] ; emitCmmLitSwitch (CmmReg bndr_reg) tagged_cmms' deflt ; return AssignedDirectly } @@ -619,34 +629,21 @@ cgConApp con stg_args ; emit =<< fcode_init ; emitReturn [idInfoToAmode idinfo] } - cgIdApp :: Id -> [StgArg] -> FCode ReturnKind cgIdApp fun_id [] | isVoidId fun_id = emitReturn [] -cgIdApp fun_id args - = do { fun_info <- getCgIdInfo fun_id - ; case maybeLetNoEscape fun_info of - Just (blk_id, lne_regs) -> cgLneJump blk_id lne_regs args - Nothing -> cgTailCall (cg_id fun_info) fun_info args } - -- NB. use (cg_id fun_info) instead of fun_id, because the former - -- may be externalised for -split-objs. - -- See StgCmm.maybeExternaliseId. - -cgLneJump :: BlockId -> [LocalReg] -> [StgArg] -> FCode ReturnKind -cgLneJump blk_id lne_regs args -- Join point; discard sequel - = do { adjustHpBackwards -- always do this before a tail-call - ; cmm_args <- getNonVoidArgAmodes args - ; emitMultiAssign lne_regs cmm_args - ; emit (mkBranch blk_id) - ; return AssignedDirectly } - -cgTailCall :: Id -> CgIdInfo -> [StgArg] -> FCode ReturnKind -cgTailCall fun_id fun_info args = do - dflags <- getDynFlags +cgIdApp fun_id args = do + dflags <- getDynFlags + fun_info <- getCgIdInfo fun_id + let fun_arg = StgVarArg fun_id + fun_name = idName fun_id + fun = idInfoToAmode fun_info + lf_info = cg_lf fun_info + node_points dflags = nodeMustPointToIt dflags lf_info case (getCallMethod dflags fun_name (idCafInfo fun_id) lf_info (length args)) of -- A value in WHNF, so we can just return it. ReturnIt -> emitReturn [fun] -- ToDo: does ReturnIt guarantee tagged? - + EnterIt -> ASSERT( null args ) -- Discarding arguments emitEnter fun @@ -654,7 +651,7 @@ cgTailCall fun_id fun_info args = do { tickySlowCall lf_info args ; emitComment $ mkFastString "slowCall" ; slowCall fun args } - + -- A direct function call (possibly with some left-over arguments) DirectEntry lbl arity -> do { tickyDirectCall arity args @@ -662,15 +659,14 @@ cgTailCall fun_id fun_info args = do then directCall NativeNodeCall lbl arity (fun_arg:args) else directCall NativeDirectCall lbl arity args } - JumpToIt {} -> panic "cgTailCall" -- ??? - - where - fun_arg = StgVarArg fun_id - fun_name = idName fun_id - fun = idInfoToAmode fun_info - lf_info = cgIdInfoLF fun_info - node_points dflags = nodeMustPointToIt dflags lf_info - + -- Let-no-escape call + JumpToIt -> let (LneLoc blk_id lne_regs) = cg_loc fun_info + in do + { adjustHpBackwards -- always do this before a tail-call + ; cmm_args <- getNonVoidArgAmodes args + ; emitMultiAssign lne_regs cmm_args + ; emit (mkBranch blk_id) + ; return AssignedDirectly } emitEnter :: CmmExpr -> FCode ReturnKind emitEnter fun = do diff --git a/compiler/codeGen/StgCmmExtCode.hs b/compiler/codeGen/StgCmmExtCode.hs index f73122bf89..e710204222 100644 --- a/compiler/codeGen/StgCmmExtCode.hs +++ b/compiler/codeGen/StgCmmExtCode.hs @@ -10,9 +10,9 @@ -- back in circularly (to avoid a two-pass algorithm). module StgCmmExtCode ( - CmmParse(..), + CmmParse, unEC, Named(..), Env, - + loopDecls, getEnv, @@ -50,13 +50,13 @@ import Unique -- | The environment contains variable definitions or blockids. -data Named +data Named = VarN CmmExpr -- ^ Holds CmmLit(CmmLabel ..) which gives the label type, - -- eg, RtsLabel, ForeignLabel, CmmLabel etc. + -- eg, RtsLabel, ForeignLabel, CmmLabel etc. | FunN PackageId -- ^ A function name from this package | LabelN BlockId -- ^ A blockid of some code or data. - + -- | An environment of named things. type Env = UniqFM Named @@ -65,7 +65,7 @@ type Decls = [(FastString,Named)] -- | Does a computation in the FCode monad, with a current environment -- and a list of local declarations. Returns the resulting list of declarations. -newtype CmmParse a +newtype CmmParse a = EC { unEC :: Env -> Decls -> FCode (Decls, a) } type ExtCode = CmmParse () @@ -86,7 +86,7 @@ instance HasDynFlags CmmParse where -- | Takes the variable decarations and imports from the monad --- and makes an environment, which is looped back into the computation. +-- and makes an environment, which is looped back into the computation. -- In this way, we can have embedded declarations that scope over the whole -- procedure, and imports that scope over the entire module. -- Discards the local declaration contained within decl' @@ -94,7 +94,7 @@ instance HasDynFlags CmmParse where loopDecls :: CmmParse a -> CmmParse a loopDecls (EC fcode) = EC $ \e globalDecls -> do - (_, a) <- F.fixC (\ ~(decls, _) -> fcode (addListToUFM e (decls ++ globalDecls)) globalDecls) + (_, a) <- F.fixC (\ ~(decls, _) -> fcode (addListToUFM e decls) globalDecls) return (globalDecls, a) @@ -103,24 +103,26 @@ getEnv :: CmmParse Env getEnv = EC $ \e s -> return (s, e) --- | Add a new variable to the list of local declarations. --- The CmmExpr says where the value is stored. +addDecl :: FastString -> Named -> ExtCode +addDecl name named = EC $ \_ s -> return ((name, named) : s, ()) + + +-- | Add a new variable to the list of local declarations. +-- The CmmExpr says where the value is stored. addVarDecl :: FastString -> CmmExpr -> ExtCode -addVarDecl var expr - = EC $ \_ s -> return ((var, VarN expr):s, ()) +addVarDecl var expr = addDecl var (VarN expr) -- | Add a new label to the list of local declarations. addLabel :: FastString -> BlockId -> ExtCode -addLabel name block_id - = EC $ \_ s -> return ((name, LabelN block_id):s, ()) +addLabel name block_id = addDecl name (LabelN block_id) -- | Create a fresh local variable of a given type. -newLocal +newLocal :: CmmType -- ^ data type -> FastString -- ^ name of variable -> CmmParse LocalReg -- ^ register holding the value - + newLocal ty name = do u <- code newUnique let reg = LocalReg u ty @@ -139,33 +141,32 @@ newBlockId :: CmmParse BlockId newBlockId = code F.newLabelC -- | Add add a local function to the environment. -newFunctionName - :: FastString -- ^ name of the function +newFunctionName + :: FastString -- ^ name of the function -> PackageId -- ^ package of the current module -> ExtCode - -newFunctionName name pkg - = EC $ \_ s -> return ((name, FunN pkg):s, ()) - - + +newFunctionName name pkg = addDecl name (FunN pkg) + + -- | Add an imported foreign label to the list of local declarations. -- If this is done at the start of the module the declaration will scope -- over the whole module. -newImport - :: (FastString, CLabel) +newImport + :: (FastString, CLabel) -> CmmParse () -newImport (name, cmmLabel) +newImport (name, cmmLabel) = addVarDecl name (CmmLit (CmmLabel cmmLabel)) -- | Lookup the BlockId bound to the label with this name. --- If one hasn't been bound yet, create a fresh one based on the +-- If one hasn't been bound yet, create a fresh one based on the -- Unique of the name. lookupLabel :: FastString -> CmmParse BlockId lookupLabel name = do env <- getEnv - return $ + return $ case lookupUFM env name of Just (LabelN l) -> l _other -> mkBlockId (newTagUnique (getUnique name) 'L') @@ -178,7 +179,7 @@ lookupLabel name = do lookupName :: FastString -> CmmParse CmmExpr lookupName name = do env <- getEnv - return $ + return $ case lookupUFM env name of Just (VarN e) -> e Just (FunN pkg) -> CmmLit (CmmLabel (mkCmmCodeLabel pkg name)) @@ -187,7 +188,7 @@ lookupName name = do -- | Lift an FCode computation into the CmmParse monad code :: FCode a -> CmmParse a -code fc = EC $ \_ s -> do +code fc = EC $ \_ s -> do r <- fc return (s, r) diff --git a/compiler/codeGen/StgCmmForeign.hs b/compiler/codeGen/StgCmmForeign.hs index 30bd46318a..0b782fffcc 100644 --- a/compiler/codeGen/StgCmmForeign.hs +++ b/compiler/codeGen/StgCmmForeign.hs @@ -225,7 +225,8 @@ emitForeignCall safety results target args , res = results , args = args' , succ = k - , updfr = updfr_off + , ret_args = off + , ret_off = updfr_off , intrbl = playInterruptible safety }) <*> mkLabel k <*> copyout diff --git a/compiler/codeGen/StgCmmGran.hs b/compiler/codeGen/StgCmmGran.hs deleted file mode 100644 index 91b0c8ba04..0000000000 --- a/compiler/codeGen/StgCmmGran.hs +++ /dev/null @@ -1,120 +0,0 @@ ------------------------------------------------------------------------------ --- --- (c) The University of Glasgow -2006 --- --- Code generation relaed to GpH --- (a) parallel --- (b) GranSim --- ------------------------------------------------------------------------------ - -module StgCmmGran ( - staticGranHdr,staticParHdr, - granThunk, granYield, - doGranAllocate - ) where - --- This entire module consists of no-op stubs at the moment --- GranSim worked once, but it certainly doesn't any more --- I've left the calls, though, in case anyone wants to resurrect it - -import StgCmmMonad -import CmmExpr - -staticGranHdr :: [CmmLit] -staticGranHdr = [] - -staticParHdr :: [CmmLit] -staticParHdr = [] - -doGranAllocate :: VirtualHpOffset -> FCode () --- Must be lazy in the amount of allocation -doGranAllocate _ = return () - -granYield :: [LocalReg] -> Bool -> FCode () -granYield _regs _node_reqd = return () - -granThunk :: Bool -> FCode () -granThunk _node_points = return () - ------------------------------------------------------------------ -{- ------- Everything below here is commented out ------------- ------------------------------------------------------------------ - --- Parallel header words in a static closure -staticParHdr :: [CmmLit] --- Parallel header words in a static closure -staticParHdr = [] - -staticGranHdr :: [CmmLit] --- Gransim header words in a static closure -staticGranHdr = [] - -doGranAllocate :: CmmExpr -> Code --- macro DO_GRAN_ALLOCATE -doGranAllocate hp - | not opt_GranMacros = return () - | otherwise = panic "doGranAllocate" - - - -------------------------- -granThunk :: Bool -> FCode () --- HWL: insert macros for GrAnSim; 2 versions depending on liveness of node --- (we prefer fetchAndReschedule-style context switches to yield ones) -granThunk node_points - | node_points = granFetchAndReschedule [] node_points - | otherwise = granYield [] node_points - -granFetchAndReschedule :: [(Id,GlobalReg)] -- Live registers - -> Bool -- Node reqd? - -> Code --- Emit code for simulating a fetch and then reschedule. -granFetchAndReschedule regs node_reqd - | opt_GranMacros && (node `elem` map snd regs || node_reqd) - = do { fetch - ; reschedule liveness node_reqd } - | otherwise - = return () - where - liveness = mkRegLiveness regs 0 0 - -fetch = panic "granFetch" - -- Was: absC (CMacroStmt GRAN_FETCH []) - --HWL: generate GRAN_FETCH macro for GrAnSim - -- currently GRAN_FETCH and GRAN_FETCH_AND_RESCHEDULE are miai - -reschedule liveness node_reqd = panic "granReschedule" - -- Was: absC (CMacroStmt GRAN_RESCHEDULE [ - -- mkIntCLit (I# (word2Int# liveness_mask)), - -- mkIntCLit (if node_reqd then 1 else 0)]) - - -------------------------- --- The @GRAN_YIELD@ macro is taken from JSM's code for Concurrent Haskell. It --- allows to context-switch at places where @node@ is not alive (it uses the --- @Continue@ rather than the @EnterNodeCode@ function in the RTS). We emit --- this kind of macro at the beginning of the following kinds of basic bocks: --- \begin{itemize} --- \item Slow entry code where node is not alive (see @StgCmmClosure.lhs@). Normally --- we use @fetchAndReschedule@ at a slow entry code. --- \item Fast entry code (see @CgClosure.lhs@). --- \item Alternatives in case expressions (@CLabelledCode@ structures), provided --- that they are not inlined (see @CgCases.lhs@). These alternatives will --- be turned into separate functions. - -granYield :: [(Id,GlobalReg)] -- Live registers - -> Bool -- Node reqd? - -> Code - -granYield regs node_reqd - | opt_GranMacros && node_reqd = yield liveness - | otherwise = return () - where - liveness = mkRegLiveness regs 0 0 - -yield liveness = panic "granYield" - -- Was : absC (CMacroStmt GRAN_YIELD - -- [mkIntCLit (I# (word2Int# liveness_mask))]) - --} diff --git a/compiler/codeGen/StgCmmHeap.hs b/compiler/codeGen/StgCmmHeap.hs index b8962cedb4..97233aa500 100644 --- a/compiler/codeGen/StgCmmHeap.hs +++ b/compiler/codeGen/StgCmmHeap.hs @@ -30,7 +30,6 @@ import StgCmmUtils import StgCmmMonad import StgCmmProf import StgCmmTicky -import StgCmmGran import StgCmmClosure import StgCmmEnv @@ -135,8 +134,7 @@ emitSetDynHdr base info_ptr ccs where header :: DynFlags -> [CmmExpr] header dflags = [info_ptr] ++ dynProfHdr dflags ccs - -- ToDo: Gransim stuff - -- ToDo: Parallel stuff + -- ToDof: Parallel stuff -- No ticky header hpStore :: CmmExpr -> [CmmExpr] -> [VirtualHpOffset] -> FCode () @@ -207,16 +205,11 @@ mkStaticClosure :: DynFlags -> CLabel -> CostCentreStack -> [CmmLit] -> [CmmLit] -> [CmmLit] -> [CmmLit] -> [CmmLit] mkStaticClosure dflags info_lbl ccs payload padding static_link_field saved_info_field = [CmmLabel info_lbl] - ++ variable_header_words + ++ staticProfHdr dflags ccs ++ concatMap (padLitToWord dflags) payload ++ padding ++ static_link_field ++ saved_info_field - where - variable_header_words - = staticGranHdr - ++ staticParHdr - ++ staticProfHdr dflags ccs -- JD: Simon had ellided this padding, but without it the C back end asserts -- failure. Maybe it's a bad assertion, and this padding is indeed unnecessary? @@ -469,7 +462,7 @@ cannedGCEntryPoint dflags regs W32 -> Just (mkGcLabel "stg_gc_f1") W64 -> Just (mkGcLabel "stg_gc_d1") _ -> Nothing - + | width == wordWidth dflags -> Just (mkGcLabel "stg_gc_unbx_r1") | width == W64 -> Just (mkGcLabel "stg_gc_l1") | otherwise -> Nothing @@ -529,7 +522,6 @@ heapCheck checkStack checkYield do_gc code | otherwise = Nothing ; codeOnly $ do_checks stk_hwm checkYield mb_alloc_bytes do_gc ; tickyAllocHeap True hpHw - ; doGranAllocate hpHw ; setRealHp hpHw ; code } diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs index 06a47c151b..6c6e49dafa 100644 --- a/compiler/codeGen/StgCmmLayout.hs +++ b/compiler/codeGen/StgCmmLayout.hs @@ -6,23 +6,16 @@ -- ----------------------------------------------------------------------------- -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module StgCmmLayout ( - mkArgDescr, + mkArgDescr, emitCall, emitReturn, adjustHpBackwards, - emitClosureProcAndInfoTable, - emitClosureAndInfoTable, + emitClosureProcAndInfoTable, + emitClosureAndInfoTable, - slowCall, directCall, + slowCall, directCall, - mkVirtHeapOffsets, mkVirtConstrOffsets, getHpRelOffset, hpRel, + mkVirtHeapOffsets, mkVirtConstrOffsets, getHpRelOffset, hpRel, ArgRep(..), toArgRep, argRepSizeW -- re-exported from StgCmmArgRep ) where @@ -46,9 +39,8 @@ import CmmInfo import CLabel import StgSyn import Id -import Name -import TyCon ( PrimRep(..) ) -import BasicTypes ( RepArity ) +import TyCon ( PrimRep(..) ) +import BasicTypes ( RepArity ) import DynFlags import Module @@ -59,7 +51,7 @@ import FastString import Control.Monad ------------------------------------------------------------------------ --- Call and return sequences +-- Call and return sequences ------------------------------------------------------------------------ -- | Return multiple values to the sequel @@ -108,10 +100,10 @@ emitCallWithExtraStack :: (Convention, Convention) -> CmmExpr -> [CmmExpr] -> [CmmExpr] -> FCode ReturnKind emitCallWithExtraStack (callConv, retConv) fun args extra_stack - = do { dflags <- getDynFlags + = do { dflags <- getDynFlags ; adjustHpBackwards - ; sequel <- getSequel - ; updfr_off <- getUpdFrameOff + ; sequel <- getSequel + ; updfr_off <- getUpdFrameOff ; case sequel of Return _ -> do emit $ mkJumpExtra dflags callConv fun args updfr_off extra_stack @@ -129,33 +121,33 @@ emitCallWithExtraStack (callConv, retConv) fun args extra_stack adjustHpBackwards :: FCode () -- This function adjusts and heap pointers just before a tail call or --- return. At a call or return, the virtual heap pointer may be less --- than the real Hp, because the latter was advanced to deal with --- the worst-case branch of the code, and we may be in a better-case --- branch. In that case, move the real Hp *back* and retract some +-- return. At a call or return, the virtual heap pointer may be less +-- than the real Hp, because the latter was advanced to deal with +-- the worst-case branch of the code, and we may be in a better-case +-- branch. In that case, move the real Hp *back* and retract some -- ticky allocation count. -- -- It *does not* deal with high-water-mark adjustment. -- That's done by functions which allocate heap. adjustHpBackwards - = do { hp_usg <- getHpUsage - ; let rHp = realHp hp_usg - vHp = virtHp hp_usg - adjust_words = vHp -rHp - ; new_hp <- getHpRelOffset vHp + = do { hp_usg <- getHpUsage + ; let rHp = realHp hp_usg + vHp = virtHp hp_usg + adjust_words = vHp -rHp + ; new_hp <- getHpRelOffset vHp - ; emit (if adjust_words == 0 - then mkNop - else mkAssign hpReg new_hp) -- Generates nothing when vHp==rHp + ; emit (if adjust_words == 0 + then mkNop + else mkAssign hpReg new_hp) -- Generates nothing when vHp==rHp - ; tickyAllocHeap False adjust_words -- ...ditto + ; tickyAllocHeap False adjust_words -- ...ditto - ; setRealHp vHp - } + ; setRealHp vHp + } ------------------------------------------------------------------------- --- Making calls: directCall and slowCall +-- Making calls: directCall and slowCall ------------------------------------------------------------------------- -- General plan is: @@ -183,7 +175,7 @@ directCall conv lbl arity stg_args slowCall :: CmmExpr -> [StgArg] -> FCode ReturnKind -- (slowCall fun args) applies fun to args, returning the results to Sequel -slowCall fun stg_args +slowCall fun stg_args = do { dflags <- getDynFlags ; argsreps <- getArgRepsAmodes stg_args ; let (rts_fun, arity) = slowCallPattern (map fst argsreps) @@ -299,13 +291,13 @@ slowArgs dflags args -- careful: reps contains voids (V), but args does not save_cccs_lbl = mkCmmRetInfoLabel rtsPackageId (fsLit "stg_restore_cccs") ------------------------------------------------------------------------- ----- Laying out objects on the heap and stack +---- Laying out objects on the heap and stack ------------------------------------------------------------------------- -- The heap always grows upwards, so hpRel is easy -hpRel :: VirtualHpOffset -- virtual offset of Hp - -> VirtualHpOffset -- virtual offset of The Thing - -> WordOff -- integer word offset +hpRel :: VirtualHpOffset -- virtual offset of Hp + -> VirtualHpOffset -- virtual offset of The Thing + -> WordOff -- integer word offset hpRel hp off = off - hp getHpRelOffset :: VirtualHpOffset -> FCode CmmExpr @@ -316,10 +308,10 @@ getHpRelOffset virtual_offset mkVirtHeapOffsets :: DynFlags - -> Bool -- True <=> is a thunk - -> [(PrimRep,a)] -- Things to make offsets for - -> (WordOff, -- _Total_ number of words allocated - WordOff, -- Number of words allocated for *pointers* + -> Bool -- True <=> is a thunk + -> [(PrimRep,a)] -- Things to make offsets for + -> (WordOff, -- _Total_ number of words allocated + WordOff, -- Number of words allocated for *pointers* [(NonVoid a, VirtualHpOffset)]) -- Things with their offsets from start of object in order of @@ -333,10 +325,10 @@ mkVirtHeapOffsets -- than the unboxed things mkVirtHeapOffsets dflags is_thunk things - = let non_void_things = filterOut (isVoidRep . fst) things - (ptrs, non_ptrs) = partition (isGcPtrRep . fst) non_void_things - (wds_of_ptrs, ptrs_w_offsets) = mapAccumL computeOffset 0 ptrs - (tot_wds, non_ptrs_w_offsets) = mapAccumL computeOffset wds_of_ptrs non_ptrs + = let non_void_things = filterOut (isVoidRep . fst) things + (ptrs, non_ptrs) = partition (isGcPtrRep . fst) non_void_things + (wds_of_ptrs, ptrs_w_offsets) = mapAccumL computeOffset 0 ptrs + (tot_wds, non_ptrs_w_offsets) = mapAccumL computeOffset wds_of_ptrs non_ptrs in (tot_wds, wds_of_ptrs, ptrs_w_offsets ++ non_ptrs_w_offsets) where @@ -344,8 +336,8 @@ mkVirtHeapOffsets dflags is_thunk things | otherwise = fixedHdrSize dflags computeOffset wds_so_far (rep, thing) - = (wds_so_far + argRepSizeW dflags (toArgRep rep), - (NonVoid thing, hdr_size + wds_so_far)) + = (wds_so_far + argRepSizeW dflags (toArgRep rep), + (NonVoid thing, hdr_size + wds_so_far)) mkVirtConstrOffsets :: DynFlags -> [(PrimRep,a)] -> (WordOff, WordOff, [(NonVoid a, VirtualHpOffset)]) -- Just like mkVirtHeapOffsets, but for constructors @@ -354,11 +346,11 @@ mkVirtConstrOffsets dflags = mkVirtHeapOffsets dflags False ------------------------------------------------------------------------- -- --- Making argument descriptors +-- Making argument descriptors -- -- An argument descriptor describes the layout of args on the stack, --- both for * GC (stack-layout) purposes, and --- * saving/restoring registers when a heap-check fails +-- both for * GC (stack-layout) purposes, and +-- * saving/restoring registers when a heap-check fails -- -- Void arguments aren't important, therefore (contrast constructSlowCall) -- @@ -367,17 +359,16 @@ mkVirtConstrOffsets dflags = mkVirtHeapOffsets dflags False -- bring in ARG_P, ARG_N, etc. #include "../includes/rts/storage/FunTypes.h" -mkArgDescr :: Name -> [Id] -> FCode ArgDescr -mkArgDescr _nm args - = do dflags <- getDynFlags - let arg_bits = argBits dflags arg_reps - arg_reps = filter isNonV (map idArgRep args) +mkArgDescr :: DynFlags -> [Id] -> ArgDescr +mkArgDescr dflags args + = let arg_bits = argBits dflags arg_reps + arg_reps = filter isNonV (map idArgRep args) -- Getting rid of voids eases matching of standard patterns - case stdPattern arg_reps of - Just spec_id -> return (ArgSpec spec_id) - Nothing -> return (ArgGen arg_bits) + in case stdPattern arg_reps of + Just spec_id -> ArgSpec spec_id + Nothing -> ArgGen arg_bits -argBits :: DynFlags -> [ArgRep] -> [Bool] -- True for non-ptr, False for ptr +argBits :: DynFlags -> [ArgRep] -> [Bool] -- True for non-ptr, False for ptr argBits _ [] = [] argBits dflags (P : args) = False : argBits dflags args argBits dflags (arg : args) = take (argRepSizeW dflags arg) (repeat True) @@ -387,37 +378,37 @@ argBits dflags (arg : args) = take (argRepSizeW dflags arg) (repeat True) stdPattern :: [ArgRep] -> Maybe Int stdPattern reps = case reps of - [] -> Just ARG_NONE -- just void args, probably - [N] -> Just ARG_N - [P] -> Just ARG_P - [F] -> Just ARG_F - [D] -> Just ARG_D - [L] -> Just ARG_L - [V16] -> Just ARG_V16 - - [N,N] -> Just ARG_NN - [N,P] -> Just ARG_NP - [P,N] -> Just ARG_PN - [P,P] -> Just ARG_PP - - [N,N,N] -> Just ARG_NNN - [N,N,P] -> Just ARG_NNP - [N,P,N] -> Just ARG_NPN - [N,P,P] -> Just ARG_NPP - [P,N,N] -> Just ARG_PNN - [P,N,P] -> Just ARG_PNP - [P,P,N] -> Just ARG_PPN - [P,P,P] -> Just ARG_PPP - - [P,P,P,P] -> Just ARG_PPPP - [P,P,P,P,P] -> Just ARG_PPPPP - [P,P,P,P,P,P] -> Just ARG_PPPPPP - - _ -> Nothing + [] -> Just ARG_NONE -- just void args, probably + [N] -> Just ARG_N + [P] -> Just ARG_P + [F] -> Just ARG_F + [D] -> Just ARG_D + [L] -> Just ARG_L + [V16] -> Just ARG_V16 + + [N,N] -> Just ARG_NN + [N,P] -> Just ARG_NP + [P,N] -> Just ARG_PN + [P,P] -> Just ARG_PP + + [N,N,N] -> Just ARG_NNN + [N,N,P] -> Just ARG_NNP + [N,P,N] -> Just ARG_NPN + [N,P,P] -> Just ARG_NPP + [P,N,N] -> Just ARG_PNN + [P,N,P] -> Just ARG_PNP + [P,P,N] -> Just ARG_PPN + [P,P,P] -> Just ARG_PPP + + [P,P,P,P] -> Just ARG_PPPP + [P,P,P,P,P] -> Just ARG_PPPPP + [P,P,P,P,P,P] -> Just ARG_PPPPPP + + _ -> Nothing ------------------------------------------------------------------------- -- --- Generating the info table and code for a closure +-- Generating the info table and code for a closure -- ------------------------------------------------------------------------- @@ -427,7 +418,7 @@ stdPattern reps -- When loading the free variables, a function closure pointer may be tagged, -- so we must take it into account. -emitClosureProcAndInfoTable :: Bool -- top-level? +emitClosureProcAndInfoTable :: Bool -- top-level? -> Id -- name of the closure -> LambdaFormInfo -> CmmInfoTable diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs index 1f3d5c4886..17bad247e2 100644 --- a/compiler/codeGen/StgCmmMonad.hs +++ b/compiler/codeGen/StgCmmMonad.hs @@ -12,7 +12,7 @@ module StgCmmMonad ( initC, runC, thenC, thenFC, listCs, returnFC, fixC, - newUnique, newUniqSupply, + newUnique, newUniqSupply, newLabelC, emitLabel, @@ -26,7 +26,7 @@ module StgCmmMonad ( mkCmmIfThenElse, mkCmmIfThen, mkCmmIfGoto, mkCall, mkCmmCall, - forkClosureBody, forkStatics, forkAlts, forkProc, codeOnly, + forkClosureBody, forkAlts, forkProc, codeOnly, ConTagZ, @@ -46,9 +46,9 @@ module StgCmmMonad ( -- ideally we wouldn't export these, but some other modules access internal state getState, setState, getInfoDown, getDynFlags, getThisPackage, - -- more localised access to monad state + -- more localised access to monad state CgIdInfo(..), CgLoc(..), - getBinds, setBinds, getStaticBinds, + getBinds, setBinds, -- out of general friendliness, we also export ... CgInfoDownwards(..), CgState(..) -- non-abstract @@ -76,7 +76,6 @@ import Outputable import Control.Monad import Data.List import Prelude hiding( sequence, succ ) -import qualified Prelude( sequence ) infixr 9 `thenC` -- Right-associative! infixr 9 `thenFC` @@ -133,7 +132,7 @@ returnFC :: a -> FCode a returnFC val = FCode (\_info_down state -> (# val, state #)) thenC :: FCode () -> FCode a -> FCode a -thenC (FCode m) (FCode k) = +thenC (FCode m) (FCode k) = FCode $ \info_down state -> case m info_down state of (# _,new_state #) -> k info_down new_state @@ -142,7 +141,7 @@ listCs [] = return () listCs (fc:fcs) = do fc listCs fcs - + thenFC :: FCode a -> (a -> FCode c) -> FCode c thenFC (FCode m) k = FCode $ \info_down state -> @@ -153,7 +152,7 @@ thenFC (FCode m) k = FCode $ fixC :: (a -> FCode a) -> FCode a fixC fcode = FCode ( - \info_down state -> + \info_down state -> let (v,s) = doFCode (fcode v) info_down state in @@ -164,15 +163,14 @@ fixC fcode = FCode ( -- The code generator environment -------------------------------------------------------- --- This monadery has some information that it only passes --- *downwards*, as well as some ``state'' which is modified +-- This monadery has some information that it only passes +-- *downwards*, as well as some ``state'' which is modified -- as we go along. data CgInfoDownwards -- information only passed *downwards* by the monad = MkCgInfoDown { cgd_dflags :: DynFlags, cgd_mod :: Module, -- Module being compiled - cgd_statics :: CgBindings, -- [Id -> info] : static environment cgd_updfr_off :: UpdFrameOffset, -- Size of current update frame cgd_ticky :: CLabel, -- Current destination for ticky counts cgd_sequel :: Sequel -- What to do at end of basic block @@ -181,11 +179,11 @@ data CgInfoDownwards -- information only passed *downwards* by the monad type CgBindings = IdEnv CgIdInfo data CgIdInfo - = CgIdInfo + = CgIdInfo { cg_id :: Id -- Id that this is the info for - -- Can differ from the Id at occurrence sites by + -- Can differ from the Id at occurrence sites by -- virtue of being externalised, for splittable C - , cg_lf :: LambdaFormInfo + , cg_lf :: LambdaFormInfo , cg_loc :: CgLoc -- CmmExpr for the *tagged* value } @@ -194,9 +192,9 @@ data CgLoc -- Hp, so that it remains valid across calls | LneLoc BlockId [LocalReg] -- A join point - -- A join point (= let-no-escape) should only + -- A join point (= let-no-escape) should only -- be tail-called, and in a saturated way. - -- To tail-call it, assign to these locals, + -- To tail-call it, assign to these locals, -- and branch to the block id instance Outputable CgIdInfo where @@ -213,7 +211,7 @@ data Sequel = Return Bool -- Return result(s) to continuation found on the stack -- True <=> the continuation is update code (???) - | AssignTo + | AssignTo [LocalReg] -- Put result(s) in these regs and fall through -- NB: no void arguments here -- @@ -298,12 +296,11 @@ data ReturnKind initCgInfoDown :: DynFlags -> Module -> CgInfoDownwards initCgInfoDown dflags mod - = MkCgInfoDown { cgd_dflags = dflags, - cgd_mod = mod, - cgd_statics = emptyVarEnv, - cgd_updfr_off = initUpdFrameOff dflags, - cgd_ticky = mkTopTickyCtrLabel, - cgd_sequel = initSequel } + = MkCgInfoDown { cgd_dflags = dflags + , cgd_mod = mod + , cgd_updfr_off = initUpdFrameOff dflags + , cgd_ticky = mkTopTickyCtrLabel + , cgd_sequel = initSequel } initSequel :: Sequel initSequel = Return False @@ -322,12 +319,10 @@ data CgState cgs_tops :: OrdList CmmDecl, -- Other procedures and data blocks in this compilation unit - -- Both are ordered only so that we can + -- Both are ordered only so that we can -- reduce forward references, when it's easy to do so - - cgs_binds :: CgBindings, -- [Id -> info] : *local* bindings environment - -- Bindings for top-level things are given in - -- the info-down part + + cgs_binds :: CgBindings, cgs_hp_usg :: HeapUsage, @@ -347,18 +342,19 @@ type VirtualHpOffset = WordOff initCgState :: UniqSupply -> CgState initCgState uniqs - = MkCgState { cgs_stmts = mkNop, cgs_tops = nilOL, - cgs_binds = emptyVarEnv, - cgs_hp_usg = initHpUsage, - cgs_uniqs = uniqs } + = MkCgState { cgs_stmts = mkNop + , cgs_tops = nilOL + , cgs_binds = emptyVarEnv + , cgs_hp_usg = initHpUsage + , cgs_uniqs = uniqs } stateIncUsage :: CgState -> CgState -> CgState --- stateIncUsage@ e1 e2 incorporates in e1 +-- stateIncUsage@ e1 e2 incorporates in e1 -- the heap high water mark found in e2. stateIncUsage s1 s2@(MkCgState { cgs_hp_usg = hp_usg }) = s1 { cgs_hp_usg = cgs_hp_usg s1 `maxHpHw` virtHp hp_usg } `addCodeBlocksFrom` s2 - + addCodeBlocksFrom :: CgState -> CgState -> CgState -- Add code blocks from the latter to the former -- (The cgs_stmts will often be empty, but not always; see codeOnly) @@ -371,13 +367,13 @@ s1 `addCodeBlocksFrom` s2 -- only records the high water marks of forked-off branches, so to find the -- heap high water mark you have to take the max of virtHp and hwHp. Remember, -- virtHp never retreats! --- +-- -- Note Jan 04: ok, so why do we only look at the virtual Hp?? heapHWM :: HeapUsage -> VirtualHpOffset heapHWM = virtHp -initHpUsage :: HeapUsage +initHpUsage :: HeapUsage initHpUsage = HeapUsage { virtHp = 0, realHp = 0 } maxHpHw :: HeapUsage -> VirtualHpOffset -> HeapUsage @@ -397,7 +393,7 @@ getHpUsage :: FCode HeapUsage getHpUsage = do state <- getState return $ cgs_hp_usg state - + setHpUsage :: HeapUsage -> FCode () setHpUsage new_hp_usg = do state <- getState @@ -405,36 +401,31 @@ setHpUsage new_hp_usg = do setVirtHp :: VirtualHpOffset -> FCode () setVirtHp new_virtHp - = do { hp_usage <- getHpUsage + = do { hp_usage <- getHpUsage ; setHpUsage (hp_usage {virtHp = new_virtHp}) } getVirtHp :: FCode VirtualHpOffset -getVirtHp - = do { hp_usage <- getHpUsage +getVirtHp + = do { hp_usage <- getHpUsage ; return (virtHp hp_usage) } setRealHp :: VirtualHpOffset -> FCode () setRealHp new_realHp - = do { hp_usage <- getHpUsage + = do { hp_usage <- getHpUsage ; setHpUsage (hp_usage {realHp = new_realHp}) } getBinds :: FCode CgBindings getBinds = do state <- getState return $ cgs_binds state - + setBinds :: CgBindings -> FCode () setBinds new_binds = do state <- getState setState $ state {cgs_binds = new_binds} -getStaticBinds :: FCode CgBindings -getStaticBinds = do - info <- getInfoDown - return (cgd_statics info) - withState :: FCode a -> CgState -> FCode (a,CgState) -withState (FCode fcode) newstate = FCode $ \info_down state -> +withState (FCode fcode) newstate = FCode $ \info_down state -> case fcode info_down newstate of (# retval, state2 #) -> (# (retval,state2), state #) @@ -447,8 +438,10 @@ newUniqSupply = do newUnique :: FCode Unique newUnique = do - us <- newUniqSupply - return (uniqFromSupply us) + state <- getState + let (u,us') = takeUniqFromSupply (cgs_uniqs state) + setState $ state { cgs_uniqs = us' } + return u ------------------ getInfoDown :: FCode CgInfoDownwards @@ -461,7 +454,7 @@ getThisPackage :: FCode PackageId getThisPackage = liftM thisPackage getDynFlags withInfoDown :: FCode a -> CgInfoDownwards -> FCode a -withInfoDown (FCode fcode) info_down = FCode $ \_ state -> fcode info_down state +withInfoDown (FCode fcode) info_down = FCode $ \_ state -> fcode info_down state doFCode :: FCode a -> CgInfoDownwards -> CgState -> (a,CgState) doFCode (FCode fcode) info_down state = @@ -479,7 +472,7 @@ getModuleName = do { info <- getInfoDown; return (cgd_mod info) } withSequel :: Sequel -> FCode a -> FCode a withSequel sequel code - = do { info <- getInfoDown + = do { info <- getInfoDown ; withInfoDown code (info {cgd_sequel = sequel }) } getSequel :: FCode Sequel @@ -498,12 +491,12 @@ getSequel = do { info <- getInfoDown withUpdFrameOff :: UpdFrameOffset -> FCode a -> FCode a withUpdFrameOff size code - = do { info <- getInfoDown + = do { info <- getInfoDown ; withInfoDown code (info {cgd_updfr_off = size }) } getUpdFrameOff :: FCode UpdFrameOffset getUpdFrameOff - = do { info <- getInfoDown + = do { info <- getInfoDown ; return $ cgd_updfr_off info } -- ---------------------------------------------------------------------------- @@ -525,61 +518,43 @@ setTickyCtrLabel ticky code = do -------------------------------------------------------- forkClosureBody :: FCode () -> FCode () --- forkClosureBody takes a code, $c$, and compiles it in a +-- forkClosureBody takes a code, $c$, and compiles it in a -- fresh environment, except that: -- - compilation info and statics are passed in unchanged. -- - local bindings are passed in unchanged -- (it's up to the enclosed code to re-bind the -- free variables to a field of the closure) --- +-- -- The current state is passed on completely unaltered, except that -- C-- from the fork is incorporated. forkClosureBody body_code - = do { dflags <- getDynFlags - ; info <- getInfoDown - ; us <- newUniqSupply - ; state <- getState - ; let body_info_down = info { cgd_sequel = initSequel - , cgd_updfr_off = initUpdFrameOff dflags } - fork_state_in = (initCgState us) { cgs_binds = cgs_binds state } - ((),fork_state_out) - = doFCode body_code body_info_down fork_state_in + = do { dflags <- getDynFlags + ; info <- getInfoDown + ; us <- newUniqSupply + ; state <- getState + ; let body_info_down = info { cgd_sequel = initSequel + , cgd_updfr_off = initUpdFrameOff dflags } + fork_state_in = (initCgState us) { cgs_binds = cgs_binds state } + ((),fork_state_out) = doFCode body_code body_info_down fork_state_in ; setState $ state `addCodeBlocksFrom` fork_state_out } - -forkStatics :: FCode a -> FCode a --- @forkStatics@ $fc$ compiles $fc$ in an environment whose *statics* come --- from the current *local bindings*, but which is otherwise freshly initialised. --- The Abstract~C returned is attached to the current state, but the --- bindings and usage information is otherwise unchanged. -forkStatics body_code - = do { dflags <- getDynFlags - ; info <- getInfoDown - ; us <- newUniqSupply - ; state <- getState - ; let rhs_info_down = info { cgd_statics = cgs_binds state - , cgd_sequel = initSequel - , cgd_updfr_off = initUpdFrameOff dflags } - (result, fork_state_out) = doFCode body_code rhs_info_down - (initCgState us) - ; setState (state `addCodeBlocksFrom` fork_state_out) - ; return result } forkProc :: FCode a -> FCode a -- 'forkProc' takes a code and compiles it in the *current* environment, --- returning the graph thus constructed. +-- returning the graph thus constructed. -- -- The current environment is passed on completely unchanged to -- the successor. In particular, any heap usage from the enclosed --- code is discarded; it should deal with its own heap consumption +-- code is discarded; it should deal with its own heap consumption. +-- forkProc is used to compile let-no-escape bindings. forkProc body_code - = do { info_down <- getInfoDown - ; us <- newUniqSupply - ; state <- getState - ; let info_down' = info_down -- { cgd_sequel = initSequel } - fork_state_in = (initCgState us) { cgs_binds = cgs_binds state } - (result, fork_state_out) = doFCode body_code info_down' fork_state_in - ; setState $ state `addCodeBlocksFrom` fork_state_out + = do { info_down <- getInfoDown + ; us <- newUniqSupply + ; state <- getState + ; let info_down' = info_down -- { cgd_sequel = initSequel } + fork_state_in = (initCgState us) { cgs_binds = cgs_binds state } + (result, fork_state_out) = doFCode body_code info_down' fork_state_in + ; setState $ state `addCodeBlocksFrom` fork_state_out ; return result } codeOnly :: FCode () -> FCode () @@ -587,7 +562,7 @@ codeOnly :: FCode () -> FCode () -- Do not affect anything else in the outer state -- Used in almost-circular code to prevent false loop dependencies codeOnly body_code - = do { info_down <- getInfoDown + = do { info_down <- getInfoDown ; us <- newUniqSupply ; state <- getState ; let fork_state_in = (initCgState us) { cgs_binds = cgs_binds state, @@ -622,7 +597,7 @@ forkAlts branch_fcodes -- collect the code emitted by an FCode computation getCodeR :: FCode a -> FCode (a, CmmAGraph) getCodeR fcode - = do { state1 <- getState + = do { state1 <- getState ; (a, state2) <- withState fcode (state1 { cgs_stmts = mkNop }) ; setState $ state2 { cgs_stmts = cgs_stmts state1 } ; return (a, cgs_stmts state2) } @@ -632,21 +607,21 @@ getCode fcode = do { (_,stmts) <- getCodeR fcode; return stmts } -- 'getHeapUsage' applies a function to the amount of heap that it uses. -- It initialises the heap usage to zeros, and passes on an unchanged --- heap usage. +-- heap usage. -- -- It is usually a prelude to performing a GC check, so everything must -- be in a tidy and consistent state. --- +-- -- Note the slightly subtle fixed point behaviour needed here getHeapUsage :: (VirtualHpOffset -> FCode a) -> FCode a getHeapUsage fcode - = do { info_down <- getInfoDown + = do { info_down <- getInfoDown ; state <- getState ; let fstate_in = state { cgs_hp_usg = initHpUsage } (r, fstate_out) = doFCode (fcode hp_hw) info_down fstate_in hp_hw = heapHWM (cgs_hp_usg fstate_out) -- Loop here! - + ; setState $ fstate_out { cgs_hp_usg = cgs_hp_usg state } ; return r } @@ -682,12 +657,12 @@ newLabelC = do { u <- newUnique emit :: CmmAGraph -> FCode () emit ag - = do { state <- getState + = do { state <- getState ; setState $ state { cgs_stmts = cgs_stmts state <*> ag } } emitDecl :: CmmDecl -> FCode () emitDecl decl - = do { state <- getState + = do { state <- getState ; setState $ state { cgs_tops = cgs_tops state `snocOL` decl } } emitOutOfLine :: BlockId -> CmmAGraph -> FCode () @@ -752,10 +727,10 @@ getCmm :: FCode () -> FCode CmmGroup -- Get all the CmmTops (there should be no stmts) -- Return a single Cmm which may be split from other Cmms by -- object splitting (at a later stage) -getCmm code - = do { state1 <- getState +getCmm code + = do { state1 <- getState ; ((), state2) <- withState code (state1 { cgs_tops = nilOL }) - ; setState $ state2 { cgs_tops = cgs_tops state1 } + ; setState $ state2 { cgs_tops = cgs_tops state1 } ; return (fromOL (cgs_tops state2)) } @@ -776,7 +751,7 @@ mkCmmIfGoto e tid = do mkCmmIfThen :: CmmExpr -> CmmAGraph -> FCode CmmAGraph mkCmmIfThen e tbranch = do endif <- newLabelC - tid <- newLabelC + tid <- newLabelC return $ mkCbranch e tid endif <*> mkLabel tid <*> tbranch <*> mkLabel endif @@ -785,7 +760,7 @@ mkCall :: CmmExpr -> (Convention, Convention) -> [CmmFormal] -> [CmmActual] -> UpdFrameOffset -> [CmmActual] -> FCode CmmAGraph mkCall f (callConv, retConv) results actuals updfr_off extra_stack = do dflags <- getDynFlags - k <- newLabelC + k <- newLabelC let area = Young k (off, _, copyin) = copyInOflow dflags retConv area results [] copyout = mkCallReturnsTo dflags f callConv actuals k off updfr_off extra_stack diff --git a/compiler/codeGen/StgCmmPrim.hs b/compiler/codeGen/StgCmmPrim.hs index fb5acde956..c11df7009c 100644 --- a/compiler/codeGen/StgCmmPrim.hs +++ b/compiler/codeGen/StgCmmPrim.hs @@ -36,7 +36,6 @@ import CLabel import CmmUtils import PrimOp import SMRep -import Module import FastString import Outputable import Util @@ -108,15 +107,6 @@ cgOpApp (StgPrimOp primop) args res_ty cgPrimOp regs primop args emitReturn (map (CmmReg . CmmLocal) regs) - | ReturnsAlg tycon <- result_info - , isEnumerationTyCon tycon - -- c.f. cgExpr (...TagToEnumOp...) - = do dflags <- getDynFlags - tag_reg <- newTemp (bWord dflags) - cgPrimOp [tag_reg] primop args - emitReturn [tagToClosure dflags tycon - (CmmReg (CmmLocal tag_reg))] - | otherwise = panic "cgPrimop" where result_info = getPrimOpResultInfo primop @@ -214,7 +204,7 @@ emitPrimOp _ [res] ParOp [arg] -- later, we might want to inline it. emitCCall [(res,NoHint)] - (CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "newSpark")))) + (CmmLit (CmmLabel (mkForeignLabel (fsLit "newSpark") Nothing ForeignLabelInExternalPackage IsFunction))) [(CmmReg (CmmGlobal BaseReg), AddrHint), (arg,AddrHint)] emitPrimOp dflags [res] SparkOp [arg] @@ -226,7 +216,7 @@ emitPrimOp dflags [res] SparkOp [arg] tmp2 <- newTemp (bWord dflags) emitCCall [(tmp2,NoHint)] - (CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "newSpark")))) + (CmmLit (CmmLabel (mkForeignLabel (fsLit "newSpark") Nothing ForeignLabelInExternalPackage IsFunction))) [(CmmReg (CmmGlobal BaseReg), AddrHint), ((CmmReg (CmmLocal tmp)), AddrHint)] emitAssign (CmmLocal res) (CmmReg (CmmLocal tmp)) @@ -542,6 +532,11 @@ emitPrimOp _ [] CopyMutableByteArrayOp [src,src_off,dst,dst_off,n] = emitPrimOp _ [] SetByteArrayOp [ba,off,len,c] = doSetByteArrayOp ba off len c +emitPrimOp _ [res] BSwap16Op [w] = emitBSwapCall res w W16 +emitPrimOp _ [res] BSwap32Op [w] = emitBSwapCall res w W32 +emitPrimOp _ [res] BSwap64Op [w] = emitBSwapCall res w W64 +emitPrimOp dflags [res] BSwapOp [w] = emitBSwapCall res w (wordWidth dflags) + -- Population count emitPrimOp _ [res] PopCnt8Op [w] = emitPopCntCall res w W8 emitPrimOp _ [res] PopCnt16Op [w] = emitPopCntCall res w W16 @@ -1043,7 +1038,7 @@ doIndexOffAddrOp _ _ _ _ doIndexOffAddrOpAs :: Maybe MachOp -> CmmType - -> CmmType + -> CmmType -> [LocalReg] -> [CmmExpr] -> FCode () @@ -1060,19 +1055,19 @@ doIndexByteArrayOp :: Maybe MachOp doIndexByteArrayOp maybe_post_read_cast rep [res] [addr,idx] = do dflags <- getDynFlags mkBasicIndexedRead (arrWordsHdrSize dflags) maybe_post_read_cast rep res addr rep idx -doIndexByteArrayOp _ _ _ _ +doIndexByteArrayOp _ _ _ _ = panic "StgCmmPrim: doIndexByteArrayOp" doIndexByteArrayOpAs :: Maybe MachOp -> CmmType - -> CmmType + -> CmmType -> [LocalReg] -> [CmmExpr] -> FCode () doIndexByteArrayOpAs maybe_post_read_cast rep idx_rep [res] [addr,idx] = do dflags <- getDynFlags mkBasicIndexedRead (arrWordsHdrSize dflags) maybe_post_read_cast rep res addr idx_rep idx -doIndexByteArrayOpAs _ _ _ _ _ +doIndexByteArrayOpAs _ _ _ _ _ = panic "StgCmmPrim: doIndexByteArrayOpAs" doReadPtrArrayOp :: LocalReg @@ -1217,7 +1212,7 @@ doVecPackOp maybe_pre_write_cast ty z es res = do Just cast -> CmmMachOp cast [val] len :: Length - len = vecLength ty + len = vecLength ty wid :: Width wid = typeWidth (vecElemType ty) @@ -1251,7 +1246,7 @@ doVecUnpackOp maybe_post_read_cast ty e res = Just cast -> CmmMachOp cast [val] len :: Length - len = vecLength ty + len = vecLength ty wid :: Width wid = typeWidth (vecElemType ty) @@ -1278,7 +1273,7 @@ doVecInsertOp maybe_pre_write_cast ty src e idx res = do Just cast -> CmmMachOp cast [val] len :: Length - len = vecLength ty + len = vecLength ty wid :: Width wid = typeWidth (vecElemType ty) @@ -1569,6 +1564,13 @@ emitAllocateCall res cap n = do allocate = CmmLit (CmmLabel (mkForeignLabel (fsLit "allocate") Nothing ForeignLabelInExternalPackage IsFunction)) +emitBSwapCall :: LocalReg -> CmmExpr -> Width -> FCode () +emitBSwapCall res x width = do + emitPrimCall + [ res ] + (MO_BSwap width) + [ x ] + emitPopCntCall :: LocalReg -> CmmExpr -> Width -> FCode () emitPopCntCall res x width = do emitPrimCall diff --git a/compiler/codeGen/StgCmmProf.hs b/compiler/codeGen/StgCmmProf.hs index 3307604a87..5044d763a4 100644 --- a/compiler/codeGen/StgCmmProf.hs +++ b/compiler/codeGen/StgCmmProf.hs @@ -6,28 +6,21 @@ -- ----------------------------------------------------------------------------- -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module StgCmmProf ( - initCostCentres, ccType, ccsType, - mkCCostCentre, mkCCostCentreStack, + initCostCentres, ccType, ccsType, + mkCCostCentre, mkCCostCentreStack, - -- Cost-centre Profiling - dynProfHdr, profDynAlloc, profAlloc, staticProfHdr, initUpdFrameProf, + -- Cost-centre Profiling + dynProfHdr, profDynAlloc, profAlloc, staticProfHdr, initUpdFrameProf, enterCostCentreThunk, enterCostCentreFun, costCentreFrom, curCCS, storeCurCCS, emitSetCCC, - saveCurrentCostCentre, restoreCurrentCostCentre, + saveCurrentCostCentre, restoreCurrentCostCentre, - -- Lag/drag/void stuff - ldvEnter, ldvEnterClosure, ldvRecordCreate + -- Lag/drag/void stuff + ldvEnter, ldvEnterClosure, ldvRecordCreate ) where #include "HsVersions.h" @@ -78,8 +71,8 @@ mkCCostCentreStack :: CostCentreStack -> CmmLit mkCCostCentreStack ccs = CmmLabel (mkCCSLabel ccs) costCentreFrom :: DynFlags - -> CmmExpr -- A closure pointer - -> CmmExpr -- The cost centre from that closure + -> CmmExpr -- A closure pointer + -> CmmExpr -- The cost centre from that closure costCentreFrom dflags cl = CmmLoad (cmmOffsetB dflags cl (oFFSET_StgHeader_ccs dflags)) (ccsType dflags) -- | The profiling header words in a static closure @@ -94,43 +87,43 @@ dynProfHdr dflags ccs = ifProfilingL dflags [ccs, dynLdvInit dflags] -- | Initialise the profiling field of an update frame initUpdFrameProf :: CmmExpr -> FCode () initUpdFrameProf frame - = ifProfiling $ -- frame->header.prof.ccs = CCCS + = ifProfiling $ -- frame->header.prof.ccs = CCCS do dflags <- getDynFlags emitStore (cmmOffset dflags frame (oFFSET_StgHeader_ccs dflags)) curCCS -- frame->header.prof.hp.rs = NULL (or frame-header.prof.hp.ldvw = 0) - -- is unnecessary because it is not used anyhow. + -- is unnecessary because it is not used anyhow. --------------------------------------------------------------------------- --- Saving and restoring the current cost centre +-- Saving and restoring the current cost centre --------------------------------------------------------------------------- -{- Note [Saving the current cost centre] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The current cost centre is like a global register. Like other +{- Note [Saving the current cost centre] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The current cost centre is like a global register. Like other global registers, it's a caller-saves one. But consider - case (f x) of (p,q) -> rhs -Since 'f' may set the cost centre, we must restore it + case (f x) of (p,q) -> rhs +Since 'f' may set the cost centre, we must restore it before resuming rhs. So we want code like this: - local_cc = CCC -- save - r = f( x ) - CCC = local_cc -- restore + local_cc = CCC -- save + r = f( x ) + CCC = local_cc -- restore That is, we explicitly "save" the current cost centre in a LocalReg, local_cc; and restore it after the call. The C-- infrastructure will arrange to save local_cc across the -call. +call. The same goes for join points; - let j x = join-stuff - in blah-blah + let j x = join-stuff + in blah-blah We want this kind of code: - local_cc = CCC -- save - blah-blah - J: + local_cc = CCC -- save + blah-blah + J: CCC = local_cc -- restore -} saveCurrentCostCentre :: FCode (Maybe LocalReg) - -- Returns Nothing if profiling is off + -- Returns Nothing if profiling is off saveCurrentCostCentre = do dflags <- getDynFlags if not (gopt Opt_SccProfilingOn dflags) @@ -140,7 +133,7 @@ saveCurrentCostCentre return (Just local_cc) restoreCurrentCostCentre :: Maybe LocalReg -> FCode () -restoreCurrentCostCentre Nothing +restoreCurrentCostCentre Nothing = return () restoreCurrentCostCentre (Just local_cc) = emit (storeCurCCS (CmmReg (CmmLocal local_cc))) @@ -178,7 +171,7 @@ profAlloc words ccs -- Setting the current cost centre on entry to a closure enterCostCentreThunk :: CmmExpr -> FCode () -enterCostCentreThunk closure = +enterCostCentreThunk closure = ifProfiling $ do dflags <- getDynFlags emit $ storeCurCCS (costCentreFrom dflags closure) @@ -207,7 +200,7 @@ ifProfilingL dflags xs --------------------------------------------------------------- --- Initialising Cost Centres & CCSs +-- Initialising Cost Centres & CCSs --------------------------------------------------------------- initCostCentres :: CollectedCCs -> FCode () @@ -220,7 +213,7 @@ initCostCentres (local_CCs, ___extern_CCs, singleton_CCSs) emitCostCentreDecl :: CostCentre -> FCode () -emitCostCentreDecl cc = do +emitCostCentreDecl cc = do { dflags <- getDynFlags ; let is_caf | isCafCC cc = mkIntCLit dflags (ord 'c') -- 'c' == is a CAF | otherwise = zero dflags @@ -233,20 +226,20 @@ emitCostCentreDecl cc = do showPpr dflags (costCentreSrcSpan cc) -- XXX going via FastString to get UTF-8 encoding is silly ; let - lits = [ zero dflags, -- StgInt ccID, - label, -- char *label, - modl, -- char *module, + lits = [ zero dflags, -- StgInt ccID, + label, -- char *label, + modl, -- char *module, loc, -- char *srcloc, zero64, -- StgWord64 mem_alloc zero dflags, -- StgWord time_ticks is_caf, -- StgInt is_caf zero dflags -- struct _CostCentre *link - ] + ] ; emitDataLits (mkCCLabel cc) lits } emitCostCentreStackDecl :: CostCentreStack -> FCode () -emitCostCentreStackDecl ccs +emitCostCentreStackDecl ccs = case maybeSingletonCCS ccs of Just cc -> do dflags <- getDynFlags @@ -290,19 +283,19 @@ emitSetCCC cc tick push pushCostCentre :: LocalReg -> CmmExpr -> CostCentre -> FCode () pushCostCentre result ccs cc = emitRtsCallWithResult result AddrHint - rtsPackageId + rtsPackageId (fsLit "pushCostCentre") [(ccs,AddrHint), - (CmmLit (mkCCostCentre cc), AddrHint)] + (CmmLit (mkCCostCentre cc), AddrHint)] False bumpSccCount :: DynFlags -> CmmExpr -> CmmAGraph bumpSccCount dflags ccs = addToMem (rEP_CostCentreStack_scc_count dflags) - (cmmOffsetB dflags ccs (oFFSET_CostCentreStack_scc_count dflags)) 1 + (cmmOffsetB dflags ccs (oFFSET_CostCentreStack_scc_count dflags)) 1 ----------------------------------------------------------------------------- -- --- Lag/drag/void stuff +-- Lag/drag/void stuff -- ----------------------------------------------------------------------------- @@ -316,12 +309,12 @@ staticLdvInit = zeroCLit -- Initial value of the LDV field in a dynamic closure -- dynLdvInit :: DynFlags -> CmmExpr -dynLdvInit dflags = -- (era << LDV_SHIFT) | LDV_STATE_CREATE +dynLdvInit dflags = -- (era << LDV_SHIFT) | LDV_STATE_CREATE CmmMachOp (mo_wordOr dflags) [ CmmMachOp (mo_wordShl dflags) [loadEra dflags, mkIntExpr dflags (lDV_SHIFT dflags)], CmmLit (mkWordCLit dflags (iLDV_STATE_CREATE dflags)) ] - + -- -- Initialise the LDV word of a new closure -- @@ -340,7 +333,7 @@ ldvEnterClosure closure_info = do dflags <- getDynFlags let tag = funTag dflags closure_info ldvEnter (cmmOffsetB dflags (CmmReg nodeReg) (-tag)) -- don't forget to substract node's tag - + ldvEnter :: CmmExpr -> FCode () -- Argument is a closure pointer ldvEnter cl_ptr = do @@ -364,8 +357,7 @@ loadEra dflags = CmmMachOp (MO_UU_Conv (cIntWidth dflags) (wordWidth dflags)) (cInt dflags)] ldvWord :: DynFlags -> CmmExpr -> CmmExpr --- Takes the address of a closure, and returns +-- Takes the address of a closure, and returns -- the address of the LDV word in the closure ldvWord dflags closure_ptr = cmmOffsetB dflags closure_ptr (oFFSET_StgHeader_ldvw dflags) - diff --git a/compiler/codeGen/StgCmmTicky.hs b/compiler/codeGen/StgCmmTicky.hs index 79afe0b17e..3b06d3ba62 100644 --- a/compiler/codeGen/StgCmmTicky.hs +++ b/compiler/codeGen/StgCmmTicky.hs @@ -133,7 +133,7 @@ import TyCon import Data.Maybe import qualified Data.Char -import Control.Monad ( when ) +import Control.Monad ( unless, when ) ----------------------------------------------------------------------------- -- @@ -150,10 +150,13 @@ withNewTickyCounterLNE nm args code = do b <- tickyLNEIsOn if not b then code else withNewTickyCounter TickyLNE nm args code -withNewTickyCounterThunk,withNewTickyCounterStdThunk :: Name -> FCode a -> FCode a -withNewTickyCounterThunk name code = do +withNewTickyCounterThunk,withNewTickyCounterStdThunk :: + Bool -> Name -> FCode a -> FCode a +withNewTickyCounterThunk isStatic name code = do b <- tickyDynThunkIsOn - if not b then code else withNewTickyCounter TickyThunk name [] code + if isStatic || not b -- ignore static thunks + then code + else withNewTickyCounter TickyThunk name [] code withNewTickyCounterStdThunk = withNewTickyCounterThunk @@ -235,15 +238,24 @@ tickyEnterDynCon = ifTicky $ bumpTickyCounter (fsLit "ENT_DYN_CON_ctr") tickyEnterStaticCon = ifTicky $ bumpTickyCounter (fsLit "ENT_STATIC_CON_ctr") tickyEnterViaNode = ifTicky $ bumpTickyCounter (fsLit "ENT_VIA_NODE_ctr") -tickyEnterThunk :: FCode () -tickyEnterThunk = ifTicky $ do - bumpTickyCounter (fsLit "ENT_DYN_THK_ctr") - ifTickyDynThunk $ do - ticky_ctr_lbl <- getTickyCtrLabel - registerTickyCtrAtEntryDyn ticky_ctr_lbl - bumpTickyEntryCount ticky_ctr_lbl +tickyEnterThunk :: ClosureInfo -> FCode () +tickyEnterThunk cl_info + = ifTicky $ do + { bumpTickyCounter ctr + ; unless static $ do + ticky_ctr_lbl <- getTickyCtrLabel + registerTickyCtrAtEntryDyn ticky_ctr_lbl + bumpTickyEntryCount ticky_ctr_lbl } + where + updatable = closureSingleEntry cl_info + static = isStaticClosure cl_info + + ctr | static = if updatable then fsLit "ENT_STATIC_THK_SINGLE_ctr" + else fsLit "ENT_STATIC_THK_MANY_ctr" + | otherwise = if updatable then fsLit "ENT_DYN_THK_SINGLE_ctr" + else fsLit "ENT_DYN_THK_MANY_ctr" -tickyEnterStdThunk :: FCode () +tickyEnterStdThunk :: ClosureInfo -> FCode () tickyEnterStdThunk = tickyEnterThunk tickyBlackHole :: Bool{-updatable-} -> FCode () @@ -558,19 +570,18 @@ bumpTickyLit lhs = bumpTickyLitBy lhs 1 bumpTickyLitBy :: CmmLit -> Int -> FCode () bumpTickyLitBy lhs n = do dflags <- getDynFlags - -- All the ticky-ticky counters are declared "unsigned long" in C - emit (addToMem (cLong dflags) (CmmLit lhs) n) + emit (addToMem (bWord dflags) (CmmLit lhs) n) bumpTickyLitByE :: CmmLit -> CmmExpr -> FCode () bumpTickyLitByE lhs e = do dflags <- getDynFlags - -- All the ticky-ticky counters are declared "unsigned long" in C - emit (addToMemE (cLong dflags) (CmmLit lhs) e) + emit (addToMemE (bWord dflags) (CmmLit lhs) e) bumpHistogram :: FastString -> Int -> FCode () bumpHistogram _lbl _n -- = bumpHistogramE lbl (CmmLit (CmmInt (fromIntegral n) cLongWidth)) = return () -- TEMP SPJ Apr 07 + -- six years passed - still temp? JS Aug 2013 {- bumpHistogramE :: LitString -> CmmExpr -> FCode () diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs index 3df75ceaa2..45b0f0c785 100644 --- a/compiler/codeGen/StgCmmUtils.hs +++ b/compiler/codeGen/StgCmmUtils.hs @@ -173,22 +173,21 @@ tagToClosure dflags tycon tag ------------------------------------------------------------------------- emitRtsCall :: PackageId -> FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode () -emitRtsCall pkg fun args safe = emitRtsCallGen [] pkg fun args safe +emitRtsCall pkg fun args safe = emitRtsCallGen [] (mkCmmCodeLabel pkg fun) args safe emitRtsCallWithResult :: LocalReg -> ForeignHint -> PackageId -> FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode () emitRtsCallWithResult res hint pkg fun args safe - = emitRtsCallGen [(res,hint)] pkg fun args safe + = emitRtsCallGen [(res,hint)] (mkCmmCodeLabel pkg fun) args safe -- Make a call to an RTS C procedure emitRtsCallGen :: [(LocalReg,ForeignHint)] - -> PackageId - -> FastString + -> CLabel -> [(CmmExpr,ForeignHint)] -> Bool -- True <=> CmmSafe call -> FCode () -emitRtsCallGen res pkg fun args safe +emitRtsCallGen res lbl args safe = do { dflags <- getDynFlags ; updfr_off <- getUpdFrameOff ; let (caller_save, caller_load) = callerSaveVolatileRegs dflags @@ -204,7 +203,7 @@ emitRtsCallGen res pkg fun args safe emit $ mkUnsafeCall (ForeignTarget fun_expr conv) res' args' (args', arg_hints) = unzip args (res', res_hints) = unzip res - fun_expr = mkLblExpr (mkCmmCodeLabel pkg fun) + fun_expr = mkLblExpr lbl ----------------------------------------------------------------------------- |