From bad5783f58b56b328a23dac6567b5d5417392358 Mon Sep 17 00:00:00 2001 From: Nicolas Frisby Date: Fri, 12 Apr 2013 15:32:54 +0100 Subject: [PATCH 1/3] Revert "extended ticky to also track "let"s that are not closures" This reverts commit 024df664b600a622cb8189ccf31789688505fc1c. Of course I gaff on my last day... --- compiler/codeGen/StgCmmBind.hs | 23 ++++++---------- compiler/codeGen/StgCmmCon.hs | 21 ++++++-------- compiler/codeGen/StgCmmExpr.hs | 7 ++--- compiler/codeGen/StgCmmHeap.hs | 14 ++++------ compiler/codeGen/StgCmmMonad.hs | 2 +- compiler/codeGen/StgCmmTicky.hs | 49 ++++++++++++++------------------- 6 files changed, 47 insertions(+), 69 deletions(-) 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 >> From 52efb2c8aefbd448e765e62a34c3e53ab7202a11 Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Fri, 12 Apr 2013 00:20:55 +0200 Subject: [PATCH 2/3] No need to map over all blocks, setting up PIC. Darwin x86 has inconsistent PIC base register, so splitting (which happened before) ensures that each cmm procedure only has one entry point (namely the first block). --- compiler/nativeGen/PIC.hs | 16 ++++------------ 1 file changed, 4 insertions(+), 12 deletions(-) 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" From 47556a8ec9c34829795be646005265a1a7529739 Mon Sep 17 00:00:00 2001 From: Ian Lynagh Date: Sat, 13 Apr 2013 19:56:01 +0100 Subject: [PATCH 3/3] Whitespace only in CmmNode --- compiler/cmm/CmmNode.hs | 35 ++++++++++++++--------------------- 1 file changed, 14 insertions(+), 21 deletions(-) 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