diff --git a/compiler/cmm/CmmNode.hs b/compiler/cmm/CmmNode.hs index 61c0b801790d..afd6301e979d 100644 --- a/compiler/cmm/CmmNode.hs +++ b/compiler/cmm/CmmNode.hs @@ -4,13 +4,6 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} -{-# 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 CmmNode ( CmmNode(..), CmmFormal, CmmActual, UpdFrameOffset, Convention(..), @@ -50,13 +43,13 @@ data CmmNode e x where -- Assign to memory location. Size is -- given by cmmExprType of the rhs. - CmmUnsafeForeignCall :: -- An unsafe foreign call; - -- see Note [Foreign calls] - -- Like a "fat machine instruction"; can occur - -- in the middle of a block - ForeignTarget -> -- call target - [CmmFormal] -> -- zero or more results - [CmmActual] -> -- zero or more arguments + CmmUnsafeForeignCall :: -- An unsafe foreign call; + -- see Note [Foreign calls] + -- Like a "fat machine instruction"; can occur + -- in the middle of a block + ForeignTarget -> -- call target + [CmmFormal] -> -- zero or more results + [CmmActual] -> -- zero or more arguments CmmNode O O -- Semantics: clobbers any GlobalRegs for which callerSaves r == True -- See Note [foreign calls clobber GlobalRegs] @@ -124,7 +117,7 @@ data CmmNode e x where } -> CmmNode O C CmmForeignCall :: { -- A safe foreign call; see Note [Foreign calls] - -- Always the last node of a block + -- Always the last node of a block tgt :: ForeignTarget, -- call target and convention res :: [CmmFormal], -- zero or more results args :: [CmmActual], -- zero or more arguments; see Note [Register parameter passing] @@ -143,14 +136,14 @@ instruction". In particular, they do *not* kill all live registers, just the registers they return to (there was a bit of code in GHC that conservatively assumed otherwise.) However, see [Register parameter passing]. -Safe ones are trickier. A safe foreign call +Safe ones are trickier. A safe foreign call r = f(x) ultimately expands to - push "return address" -- Never used to return to; - -- just points an info table + push "return address" -- Never used to return to; + -- just points an info table save registers into TSO call suspendThread - r = f(x) -- Make the call + r = f(x) -- Make the call call resumeThread restore registers pop "return address" @@ -354,7 +347,7 @@ instance DefinerOfRegs GlobalReg (CmmNode e x) where ----------------------------------- -- mapping Expr in CmmNode -mapForeignTarget :: (CmmExpr -> CmmExpr) -> ForeignTarget -> ForeignTarget +mapForeignTarget :: (CmmExpr -> CmmExpr) -> ForeignTarget -> ForeignTarget mapForeignTarget exp (ForeignTarget e c) = ForeignTarget (exp e) c mapForeignTarget _ m@(PrimTarget _) = m @@ -430,7 +423,7 @@ mapExpDeepM f = mapExpM $ wrapRecExpM f ----------------------------------- -- folding Expr in CmmNode -foldExpForeignTarget :: (CmmExpr -> z -> z) -> ForeignTarget -> z -> z +foldExpForeignTarget :: (CmmExpr -> z -> z) -> ForeignTarget -> z -> z foldExpForeignTarget exp (ForeignTarget e _) z = exp e z foldExpForeignTarget _ (PrimTarget _) z = z diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs index 0ba99aed3604..1e5d6b9f4fdc 100644 --- a/compiler/codeGen/StgCmmBind.hs +++ b/compiler/codeGen/StgCmmBind.hs @@ -204,9 +204,8 @@ cgRhs :: Id -- (see above) ) -cgRhs id (StgRhsCon cc con args) - = withNewTickyCounterThunk (idName id) $ - buildDynCon id True cc con args +cgRhs name (StgRhsCon cc con args) + = buildDynCon name cc con args cgRhs name (StgRhsClosure cc bi fvs upd_flag _srt args body) = do dflags <- getDynFlags @@ -364,7 +363,7 @@ mkRhsClosure _ bndr cc _ fvs upd_flag args body ; emit (mkComment $ mkFastString "calling allocDynClosure") ; let toVarArg (NonVoid a, off) = (NonVoid (StgVarArg a), off) ; let info_tbl = mkCmmInfo closure_info - ; hp_plus_n <- allocDynClosure (Just bndr) info_tbl lf_info use_cc blame_cc + ; hp_plus_n <- allocDynClosure info_tbl lf_info use_cc blame_cc (map toVarArg fv_details) -- RETURN @@ -382,9 +381,8 @@ cgRhsStdThunk bndr lf_info payload ; return (id_info, gen_code reg) } where - gen_code reg -- AHA! A STANDARD-FORM THUNK - = withNewTickyCounterStdThunk (idName bndr) $ - do + gen_code reg + = do -- AHA! A STANDARD-FORM THUNK { -- LAY OUT THE OBJECT mod_name <- getModuleName ; dflags <- getDynFlags @@ -399,11 +397,9 @@ cgRhsStdThunk bndr lf_info payload -- ; (use_cc, blame_cc) <- chooseDynCostCentres cc [{- no args-}] body ; let use_cc = curCCS; blame_cc = curCCS - ; tickyEnterStdThunk - -- BUILD THE OBJECT ; let info_tbl = mkCmmInfo closure_info - ; hp_plus_n <- allocDynClosure (Just bndr) info_tbl lf_info + ; hp_plus_n <- allocDynClosure info_tbl lf_info use_cc blame_cc payload_w_offsets -- RETURN @@ -452,8 +448,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 cl_info $ emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl [] $ \(_, node, _) -> thunkCode cl_info fv_details cc node arity body where @@ -557,7 +552,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 @@ -722,7 +717,7 @@ link_caf node _is_upd = do blame_cc = use_cc tso = CmmReg (CmmGlobal CurrentTSO) - ; hp_rel <- allocDynClosureCmm Nothing cafBlackHoleInfoTable mkLFBlackHole + ; hp_rel <- allocDynClosureCmm cafBlackHoleInfoTable mkLFBlackHole use_cc blame_cc [(tso,fixedHdrSize dflags)] -- small optimisation: we duplicate the hp_rel expression in -- both the newCAF call and the value returned below. diff --git a/compiler/codeGen/StgCmmCon.hs b/compiler/codeGen/StgCmmCon.hs index d2a25ebd6c87..3e95c59d120e 100644 --- a/compiler/codeGen/StgCmmCon.hs +++ b/compiler/codeGen/StgCmmCon.hs @@ -109,21 +109,19 @@ cgTopRhsCon id con args buildDynCon :: Id -- Name of the thing to which this constr will -- be bound - -> Bool -- is it genuinely bound to that name, or just for profiling? -> CostCentreStack -- Where to grab cost centre from; -- current CCS if currentOrSubsumedCCS -> DataCon -- The data constructor -> [StgArg] -- Its args -> FCode (CgIdInfo, FCode CmmAGraph) -- Return details about how to find it and initialization code -buildDynCon binder actually_bound cc con args +buildDynCon binder cc con args = do dflags <- getDynFlags - buildDynCon' dflags (targetPlatform dflags) binder actually_bound cc con args - + buildDynCon' dflags (targetPlatform dflags) binder cc con args buildDynCon' :: DynFlags -> Platform - -> Id -> Bool + -> Id -> CostCentreStack -> DataCon -> [StgArg] @@ -150,7 +148,7 @@ premature looking at the args will cause the compiler to black-hole! -- which have exclusively size-zero (VoidRep) args, we generate no code -- at all. -buildDynCon' dflags _ binder _ _cc con [] +buildDynCon' dflags _ binder _cc con [] = return (litIdInfo dflags binder (mkConLFInfo con) (CmmLabel (mkClosureLabel (dataConName con) (idCafInfo binder))), return mkNop) @@ -181,7 +179,7 @@ We don't support this optimisation when compiling into Windows DLLs yet because they don't support cross package data references well. -} -buildDynCon' dflags platform binder _ _cc con [arg] +buildDynCon' dflags platform binder _cc con [arg] | maybeIntLikeCon con , platformOS platform /= OSMinGW32 || not (gopt Opt_PIC dflags) , StgLitArg (MachInt val) <- arg @@ -195,7 +193,7 @@ buildDynCon' dflags platform binder _ _cc con [arg] ; return ( litIdInfo dflags binder (mkConLFInfo con) intlike_amode , return mkNop) } -buildDynCon' dflags platform binder _ _cc con [arg] +buildDynCon' dflags platform binder _cc con [arg] | maybeCharLikeCon con , platformOS platform /= OSMinGW32 || not (gopt Opt_PIC dflags) , StgLitArg (MachChar val) <- arg @@ -210,7 +208,7 @@ buildDynCon' dflags platform binder _ _cc con [arg] , return mkNop) } -------- buildDynCon': the general case ----------- -buildDynCon' dflags _ binder actually_bound ccs con args +buildDynCon' dflags _ binder ccs con args = do { (id_info, reg) <- rhsIdInfo binder lf_info ; return (id_info, gen_code reg) } @@ -224,10 +222,7 @@ buildDynCon' dflags _ binder actually_bound ccs con args nonptr_wds = tot_wds - ptr_wds info_tbl = mkDataConInfoTable dflags con False ptr_wds nonptr_wds - ; let ticky_name | actually_bound = Just binder - | otherwise = Nothing - - ; hp_plus_n <- allocDynClosure ticky_name info_tbl lf_info + ; hp_plus_n <- allocDynClosure info_tbl lf_info use_cc blame_cc args_w_offsets ; return (mkRhsInit dflags reg lf_info hp_plus_n) } where diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs index d7edf8e19395..78080218f83f 100644 --- a/compiler/codeGen/StgCmmExpr.hs +++ b/compiler/codeGen/StgCmmExpr.hs @@ -610,11 +610,10 @@ cgConApp con stg_args | otherwise -- Boxed constructors; allocate and return = ASSERT( stg_args `lengthIs` dataConRepRepArity con ) - do { (idinfo, fcode_init) <- buildDynCon (dataConWorkId con) False + do { (idinfo, fcode_init) <- buildDynCon (dataConWorkId con) currentCCS con stg_args - -- The first "con" says that the name bound to this - -- closure is is "con", which is a bit of a fudge, but - -- it only affects profiling (hence the False) + -- The first "con" says that the name bound to this closure is + -- is "con", which is a bit of a fudge, but it only affects profiling ; emit =<< fcode_init ; emitReturn [idInfoToAmode idinfo] } diff --git a/compiler/codeGen/StgCmmHeap.hs b/compiler/codeGen/StgCmmHeap.hs index b8962cedb42f..0a817030e5ad 100644 --- a/compiler/codeGen/StgCmmHeap.hs +++ b/compiler/codeGen/StgCmmHeap.hs @@ -42,7 +42,6 @@ import Cmm import CmmUtils import CostCentre import IdInfo( CafInfo(..), mayHaveCafRefs ) -import Id ( Id ) import Module import DynFlags import FastString( mkFastString, fsLit ) @@ -55,8 +54,7 @@ import Data.Maybe (isJust) ----------------------------------------------------------- allocDynClosure - :: Maybe Id - -> CmmInfoTable + :: CmmInfoTable -> LambdaFormInfo -> CmmExpr -- Cost Centre to stick in the object -> CmmExpr -- Cost Centre to blame for this alloc @@ -68,7 +66,7 @@ allocDynClosure -> FCode CmmExpr -- returns Hp+n allocDynClosureCmm - :: Maybe Id -> CmmInfoTable -> LambdaFormInfo -> CmmExpr -> CmmExpr + :: CmmInfoTable -> LambdaFormInfo -> CmmExpr -> CmmExpr -> [(CmmExpr, VirtualHpOffset)] -> FCode CmmExpr -- returns Hp+n @@ -90,19 +88,19 @@ allocDynClosureCmm -- significant - see test T4801. -allocDynClosure mb_id info_tbl lf_info use_cc _blame_cc args_w_offsets +allocDynClosure info_tbl lf_info use_cc _blame_cc args_w_offsets = do { let (args, offsets) = unzip args_w_offsets ; cmm_args <- mapM getArgAmode args -- No void args - ; allocDynClosureCmm mb_id info_tbl lf_info + ; allocDynClosureCmm info_tbl lf_info use_cc _blame_cc (zip cmm_args offsets) } -allocDynClosureCmm mb_id info_tbl lf_info use_cc _blame_cc amodes_w_offsets +allocDynClosureCmm info_tbl lf_info use_cc _blame_cc amodes_w_offsets = do { virt_hp <- getVirtHp -- SAY WHAT WE ARE ABOUT TO DO ; let rep = cit_rep info_tbl - ; tickyDynAlloc mb_id rep lf_info + ; tickyDynAlloc (toRednCountsLbl $ cit_lbl info_tbl) rep lf_info ; profDynAlloc rep use_cc -- FIND THE OFFSET OF THE INFO-PTR WORD diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs index 1f3d5c488663..dd7e95078fd3 100644 --- a/compiler/codeGen/StgCmmMonad.hs +++ b/compiler/codeGen/StgCmmMonad.hs @@ -514,7 +514,7 @@ getTickyCtrLabel = do info <- getInfoDown return (cgd_ticky info) -setTickyCtrLabel :: CLabel -> FCode a -> FCode a +setTickyCtrLabel :: CLabel -> FCode () -> FCode () setTickyCtrLabel ticky code = do info <- getInfoDown withInfoDown code (info {cgd_ticky = ticky}) diff --git a/compiler/codeGen/StgCmmTicky.hs b/compiler/codeGen/StgCmmTicky.hs index 79afe0b17e7f..64271386391e 100644 --- a/compiler/codeGen/StgCmmTicky.hs +++ b/compiler/codeGen/StgCmmTicky.hs @@ -65,9 +65,8 @@ the code generator as well as the RTS because: module StgCmmTicky ( withNewTickyCounterFun, - withNewTickyCounterLNE, withNewTickyCounterThunk, - withNewTickyCounterStdThunk, + withNewTickyCounterLNE, tickyDynAlloc, tickyAllocHeap, @@ -88,8 +87,7 @@ module StgCmmTicky ( tickyEnterViaNode, tickyEnterFun, - tickyEnterThunk, tickyEnterStdThunk, -- dynamic non-value - -- thunks only + tickyEnterThunk, tickyEnterLNE, tickyUpdateBhCaf, @@ -143,22 +141,22 @@ import Control.Monad ( when ) data TickyClosureType = TickyFun | TickyThunk | TickyLNE -withNewTickyCounterFun, withNewTickyCounterLNE :: Name -> [NonVoid Id] -> FCode a -> FCode a +withNewTickyCounterFun, withNewTickyCounterLNE :: Name -> [NonVoid Id] -> FCode () -> FCode () withNewTickyCounterFun = withNewTickyCounter TickyFun 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 :: ClosureInfo -> FCode () -> FCode () +withNewTickyCounterThunk cl_info code + | isStaticClosure cl_info = code -- static thunks are uninteresting + | otherwise = do b <- tickyDynThunkIsOn - if not b then code else withNewTickyCounter TickyThunk name [] code - -withNewTickyCounterStdThunk = withNewTickyCounterThunk + if not b then code else withNewTickyCounter TickyThunk (closureName cl_info) [] code -- args does not include the void arguments -withNewTickyCounter :: TickyClosureType -> Name -> [NonVoid Id] -> FCode a -> FCode a +withNewTickyCounter :: TickyClosureType -> Name -> [NonVoid Id] -> FCode () -> FCode () withNewTickyCounter cloType name args m = do lbl <- emitTickyCounter cloType name args setTickyCtrLabel lbl m @@ -224,28 +222,23 @@ tickyUpdateFrameOmitted = ifTicky $ bumpTickyCounter (fsLit "UPDF_OMITTED_ctr") -- ----------------------------------------------------------------------------- -- Ticky entries --- NB the name-specific entries are only available for names that have --- dedicated Cmm code. As far as I know, this just rules out --- constructor thunks. For them, there is no CMM code block to put the --- bump of name-specific ticky counter into. On the other hand, we can --- still track allocation their allocation. - -tickyEnterDynCon, tickyEnterStaticCon, tickyEnterViaNode :: FCode () +tickyEnterDynCon, tickyEnterStaticCon, + tickyEnterStaticThunk, tickyEnterViaNode :: FCode () tickyEnterDynCon = ifTicky $ bumpTickyCounter (fsLit "ENT_DYN_CON_ctr") tickyEnterStaticCon = ifTicky $ bumpTickyCounter (fsLit "ENT_STATIC_CON_ctr") +tickyEnterStaticThunk = ifTicky $ bumpTickyCounter (fsLit "ENT_STATIC_THK_ctr") tickyEnterViaNode = ifTicky $ bumpTickyCounter (fsLit "ENT_VIA_NODE_ctr") -tickyEnterThunk :: FCode () -tickyEnterThunk = ifTicky $ do +tickyEnterThunk :: ClosureInfo -> FCode () +tickyEnterThunk cl_info + | isStaticClosure cl_info = tickyEnterStaticThunk + | otherwise = ifTicky $ do bumpTickyCounter (fsLit "ENT_DYN_THK_ctr") ifTickyDynThunk $ do ticky_ctr_lbl <- getTickyCtrLabel registerTickyCtrAtEntryDyn ticky_ctr_lbl bumpTickyEntryCount ticky_ctr_lbl -tickyEnterStdThunk :: FCode () -tickyEnterStdThunk = tickyEnterThunk - tickyBlackHole :: Bool{-updatable-} -> FCode () tickyBlackHole updatable = ifTicky (bumpTickyCounter ctr) @@ -397,21 +390,20 @@ bad for both space and time). -- ----------------------------------------------------------------------------- -- Ticky allocation -tickyDynAlloc :: Maybe Id -> SMRep -> LambdaFormInfo -> FCode () +tickyDynAlloc :: Maybe CLabel -> SMRep -> LambdaFormInfo -> FCode () -- Called when doing a dynamic heap allocation; the LambdaFormInfo -- used to distinguish between closure types -- -- TODO what else to count while we're here? -tickyDynAlloc mb_id rep lf = ifTicky $ getDynFlags >>= \dflags -> +tickyDynAlloc mb_ctr_lbl rep lf = ifTicky $ getDynFlags >>= \dflags -> let bytes = wORD_SIZE dflags * heapClosureSize dflags rep countGlobal tot ctr = do bumpTickyCounterBy tot bytes bumpTickyCounter ctr - countSpecific = ifTickyAllocd $ case mb_id of + countSpecific = ifTickyAllocd $ case mb_ctr_lbl of Nothing -> return () - Just id -> do - let ctr_lbl = mkRednCountsLabel (idName id) + Just ctr_lbl -> do registerTickyCtr ctr_lbl bumpTickyAllocd ctr_lbl bytes @@ -422,7 +414,6 @@ tickyDynAlloc mb_id rep lf = ifTicky $ getDynFlags >>= \dflags -> in case () of _ | isConRep rep -> - ifTickyDynThunk countSpecific >> countGlobal (fsLit "ALLOC_CON_gds") (fsLit "ALLOC_CON_ctr") | isThunkRep rep -> ifTickyDynThunk countSpecific >> diff --git a/compiler/nativeGen/PIC.hs b/compiler/nativeGen/PIC.hs index 5fff8cbdbb0a..e46a823eaaef 100644 --- a/compiler/nativeGen/PIC.hs +++ b/compiler/nativeGen/PIC.hs @@ -771,19 +771,11 @@ initializePicBase_x86 ArchX86 os picReg BasicBlock bID (X86.FETCHGOT picReg : insns) initializePicBase_x86 ArchX86 OSDarwin picReg - (CmmProc info lab live (ListGraph blocks) : statics) - = return (CmmProc info lab live (ListGraph blocks') : statics) - - where blocks' = case blocks of - [] -> [] - (b:bs) -> fetchPC b : map maybeFetchPC bs - - maybeFetchPC b@(BasicBlock bID _) - | bID `mapMember` info = fetchPC b - | otherwise = b + (CmmProc info lab live (ListGraph (entry:blocks)) : statics) + = return (CmmProc info lab live (ListGraph (block':blocks)) : statics) - fetchPC (BasicBlock bID insns) = - BasicBlock bID (X86.FETCHPC picReg : insns) + where BasicBlock bID insns = entry + block' = BasicBlock bID (X86.FETCHPC picReg : insns) initializePicBase_x86 _ _ _ _ = panic "initializePicBase_x86: not needed"