X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcodeGen%2FCgTicky.hs;h=45cede5ca9791cf9d5831a7e7f4c4543adb3e4fd;hp=985ebb8626c6a40c3df3fd1a9d1589f3fc4aa710;hb=cbd7463c986d54422de15cb3b56184de116ef7ba;hpb=49c98d143c382a1341e1046f5ca00819a25691ba diff --git a/compiler/codeGen/CgTicky.hs b/compiler/codeGen/CgTicky.hs index 985ebb8..45cede5 100644 --- a/compiler/codeGen/CgTicky.hs +++ b/compiler/codeGen/CgTicky.hs @@ -33,10 +33,9 @@ module CgTicky ( tickyKnownCallTooFewArgs, tickyKnownCallExact, tickyKnownCallExtraArgs, tickyUnknownCall, tickySlowCallPat, - staticTickyHdr, + staticTickyHdr, ) where -#include "HsVersions.h" #include "../includes/DerivedConstants.h" -- For REP_xxx constants, which are MachReps @@ -45,24 +44,26 @@ import CgUtils import CgMonad import SMRep -import Cmm -import MachOp -import CmmUtils +import OldCmm +import OldCmmUtils import CLabel import Name import Id -import StaticFlags +import IdInfo import BasicTypes import FastString import Constants import Outputable +import Module -- Turgid imports for showTypeCategory import PrelNames import TcType import TyCon +import DynFlags + import Data.Maybe ----------------------------------------------------------------------------- @@ -72,11 +73,12 @@ import Data.Maybe ----------------------------------------------------------------------------- staticTickyHdr :: [CmmLit] --- The ticky header words in a static closure --- Was SET_STATIC_TICKY_HDR -staticTickyHdr - | not opt_DoTickyProfiling = [] - | otherwise = [zeroCLit] +-- krc: not using this right now -- +-- in the new version of ticky-ticky, we +-- don't change the closure layout. +-- leave it defined, though, to avoid breaking +-- other things. +staticTickyHdr = [] emitTickyCounter :: ClosureInfo -> [Id] -> Int -> Code emitTickyCounter cl_info args on_stk @@ -85,10 +87,12 @@ emitTickyCounter cl_info args on_stk ; fun_descr_lit <- mkStringCLit (fun_descr mod_name) ; arg_descr_lit <- mkStringCLit arg_descr ; emitDataLits ticky_ctr_label -- Must match layout of StgEntCounter - [ CmmInt 0 I16, - CmmInt (fromIntegral (length args)) I16, -- Arity - CmmInt (fromIntegral on_stk) I16, -- Words passed on stack - CmmInt 0 I16, -- 2-byte gap +-- krc: note that all the fields are I32 now; some were I16 before, +-- but the code generator wasn't handling that properly and it led to chaos, +-- panic and disorder. + [ mkIntCLit 0, + mkIntCLit (length args),-- Arity + mkIntCLit on_stk, -- Words passed on stack fun_descr_lit, arg_descr_lit, zeroCLit, -- Entry count @@ -97,13 +101,14 @@ emitTickyCounter cl_info args on_stk ] } where name = closureName cl_info - ticky_ctr_label = mkRednCountsLabel name + ticky_ctr_label = mkRednCountsLabel name NoCafRefs arg_descr = map (showTypeCategory . idType) args fun_descr mod_name = ppr_for_ticky_name mod_name name -- When printing the name of a thing in a ticky file, we want to -- give the module name even for *local* things. We print -- just "x (M)" rather that "M.x" to distinguish them from the global kind. +ppr_for_ticky_name :: Module -> Name -> String ppr_for_ticky_name mod_name name | isInternalName name = showSDocDebug (ppr name <+> (parens (ppr mod_name))) | otherwise = showSDocDebug (ppr name) @@ -111,17 +116,20 @@ ppr_for_ticky_name mod_name name -- ----------------------------------------------------------------------------- -- Ticky stack frames -tickyPushUpdateFrame = ifTicky $ bumpTickyCounter SLIT("UPDF_PUSHED_ctr") -tickyUpdateFrameOmitted = ifTicky $ bumpTickyCounter SLIT("UPDF_OMITTED_ctr") +tickyPushUpdateFrame, tickyUpdateFrameOmitted :: Code +tickyPushUpdateFrame = ifTicky $ bumpTickyCounter (fsLit "UPDF_PUSHED_ctr") +tickyUpdateFrameOmitted = ifTicky $ bumpTickyCounter (fsLit "UPDF_OMITTED_ctr") -- ----------------------------------------------------------------------------- -- Ticky entries -tickyEnterDynCon = ifTicky $ bumpTickyCounter SLIT("ENT_DYN_CON_ctr") -tickyEnterDynThunk = ifTicky $ bumpTickyCounter SLIT("ENT_DYN_THK_ctr") -tickyEnterStaticCon = ifTicky $ bumpTickyCounter SLIT("ENT_STATIC_CON_ctr") -tickyEnterStaticThunk = ifTicky $ bumpTickyCounter SLIT("ENT_STATIC_THK_ctr") -tickyEnterViaNode = ifTicky $ bumpTickyCounter SLIT("ENT_VIA_NODE_ctr") +tickyEnterDynCon, tickyEnterDynThunk, tickyEnterStaticCon, + tickyEnterStaticThunk, tickyEnterViaNode :: Code +tickyEnterDynCon = ifTicky $ bumpTickyCounter (fsLit "ENT_DYN_CON_ctr") +tickyEnterDynThunk = ifTicky $ bumpTickyCounter (fsLit "ENT_DYN_THK_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 :: ClosureInfo -> Code tickyEnterThunk cl_info @@ -132,14 +140,15 @@ tickyBlackHole :: Bool{-updatable-} -> Code tickyBlackHole updatable = ifTicky (bumpTickyCounter ctr) where - ctr | updatable = SLIT("UPD_BH_SINGLE_ENTRY_ctr") - | otherwise = SLIT("UPD_BH_UPDATABLE_ctr") + ctr | updatable = fsLit "UPD_BH_SINGLE_ENTRY_ctr" + | otherwise = fsLit "UPD_BH_UPDATABLE_ctr" +tickyUpdateBhCaf :: ClosureInfo -> Code tickyUpdateBhCaf cl_info = ifTicky (bumpTickyCounter ctr) where - ctr | closureUpdReqd cl_info = SLIT("UPD_CAF_BH_SINGLE_ENTRY_ctr") - | otherwise = SLIT("UPD_CAF_BH_UPDATABLE_ctr") + ctr | closureUpdReqd cl_info = fsLit "UPD_CAF_BH_SINGLE_ENTRY_ctr" + | otherwise = fsLit "UPD_CAF_BH_UPDATABLE_ctr" tickyEnterFun :: ClosureInfo -> Code tickyEnterFun cl_info @@ -147,10 +156,11 @@ tickyEnterFun cl_info do { bumpTickyCounter ctr ; fun_ctr_lbl <- getTickyCtrLabel ; registerTickyCtr fun_ctr_lbl - ; bumpTickyCounter' fun_ctr_lbl } + ; bumpTickyCounter' (cmmLabelOffB fun_ctr_lbl oFFSET_StgEntCounter_entry_count) + } where - ctr | isStaticClosure cl_info = SLIT("TICK_ENT_STATIC_FUN_DIRECT") - | otherwise = SLIT("TICK_ENT_DYN_FUN_DIRECT") + ctr | isStaticClosure cl_info = fsLit "ENT_STATIC_FUN_DIRECT_ctr" + | otherwise = fsLit "ENT_DYN_FUN_DIRECT_ctr" registerTickyCtr :: CLabel -> Code -- Register a ticky counter @@ -161,55 +171,57 @@ registerTickyCtr :: CLabel -> Code registerTickyCtr ctr_lbl = emitIf test (stmtsC register_stmts) where - test = CmmMachOp (MO_Not I16) - [CmmLoad (CmmLit (cmmLabelOffB ctr_lbl - oFFSET_StgEntCounter_registeredp)) I16] + -- krc: code generator doesn't handle Not, so we test for Eq 0 instead + test = CmmMachOp (MO_Eq wordWidth) + [CmmLoad (CmmLit (cmmLabelOffB ctr_lbl + oFFSET_StgEntCounter_registeredp)) bWord, + CmmLit (mkIntCLit 0)] register_stmts = [ CmmStore (CmmLit (cmmLabelOffB ctr_lbl oFFSET_StgEntCounter_link)) - (CmmLoad ticky_entry_ctrs wordRep) + (CmmLoad ticky_entry_ctrs bWord) , CmmStore ticky_entry_ctrs (mkLblExpr ctr_lbl) , CmmStore (CmmLit (cmmLabelOffB ctr_lbl oFFSET_StgEntCounter_registeredp)) (CmmLit (mkIntCLit 1)) ] - ticky_entry_ctrs = mkLblExpr (mkRtsDataLabel SLIT("ticky_entry_ctrs")) + ticky_entry_ctrs = mkLblExpr (mkCmmDataLabel rtsPackageId (fsLit "ticky_entry_ctrs")) tickyReturnOldCon, tickyReturnNewCon :: Arity -> Code tickyReturnOldCon arity - = ifTicky $ do { bumpTickyCounter SLIT("RET_OLD_ctr") - ; bumpHistogram SLIT("RET_OLD_hst") arity } + = ifTicky $ do { bumpTickyCounter (fsLit "RET_OLD_ctr") + ; bumpHistogram (fsLit "RET_OLD_hst") arity } tickyReturnNewCon arity - | not opt_DoTickyProfiling = nopC - | otherwise - = ifTicky $ do { bumpTickyCounter SLIT("RET_NEW_ctr") - ; bumpHistogram SLIT("RET_NEW_hst") arity } + = ifTicky $ do { bumpTickyCounter (fsLit "RET_NEW_ctr") + ; bumpHistogram (fsLit "RET_NEW_hst") arity } tickyUnboxedTupleReturn :: Int -> Code tickyUnboxedTupleReturn arity - = ifTicky $ do { bumpTickyCounter SLIT("RET_UNBOXED_TUP_ctr") - ; bumpHistogram SLIT("RET_UNBOXED_TUP_hst") arity } + = ifTicky $ do { bumpTickyCounter (fsLit "RET_UNBOXED_TUP_ctr") + ; bumpHistogram (fsLit "RET_UNBOXED_TUP_hst") arity } tickyVectoredReturn :: Int -> Code tickyVectoredReturn family_size - = ifTicky $ do { bumpTickyCounter SLIT("VEC_RETURN_ctr") - ; bumpHistogram SLIT("RET_VEC_RETURN_hst") family_size } + = ifTicky $ do { bumpTickyCounter (fsLit "VEC_RETURN_ctr") + ; bumpHistogram (fsLit "RET_VEC_RETURN_hst") family_size } -- ----------------------------------------------------------------------------- -- Ticky calls -- Ticks at a *call site*: -tickyKnownCallTooFewArgs = ifTicky $ bumpTickyCounter SLIT("KNOWN_CALL_TOO_FEW_ARGS_ctr") -tickyKnownCallExact = ifTicky $ bumpTickyCounter SLIT("KNOWN_CALL_ctr") -tickyKnownCallExtraArgs = ifTicky $ bumpTickyCounter SLIT("KNOWN_CALL_EXTRA_ctr") -tickyUnknownCall = ifTicky $ bumpTickyCounter SLIT("UNKNOWN_CALL_ctr") +tickyKnownCallTooFewArgs, tickyKnownCallExact, + tickyKnownCallExtraArgs, tickyUnknownCall :: Code +tickyKnownCallTooFewArgs = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_TOO_FEW_ARGS_ctr") +tickyKnownCallExact = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_ctr") +tickyKnownCallExtraArgs = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_EXTRA_ARGS_ctr") +tickyUnknownCall = ifTicky $ bumpTickyCounter (fsLit "UNKNOWN_CALL_ctr") -- Tick for the call pattern at slow call site (i.e. in addition to -- tickyUnknownCall, tickyKnownCallExtraArgs, etc.) tickySlowCallPat :: [CgRep] -> Code -tickySlowCallPat args = return () +tickySlowCallPat _args = return () {- LATER: (introduces recursive module dependency now). case callPattern args of (str, True) -> bumpTickyCounter' (mkRtsSlowTickyCtrLabel pat) - (str, False) -> bumpTickyCounter SLIT("TICK_SLOW_CALL_OTHER") + (str, False) -> bumpTickyCounter (sLit "TICK_SLOW_CALL_OTHER") callPattern :: [CgRep] -> (String,Bool) callPattern reps @@ -234,33 +246,38 @@ tickyDynAlloc :: ClosureInfo -> Code tickyDynAlloc cl_info = ifTicky $ case smRepClosureType (closureSMRep cl_info) of - Constr -> tick_alloc_con - ConstrNoCaf -> tick_alloc_con - Fun -> tick_alloc_fun - Thunk -> tick_alloc_thk - ThunkSelector -> tick_alloc_thk + Just Constr -> tick_alloc_con + Just ConstrNoCaf -> tick_alloc_con + Just Fun -> tick_alloc_fun + Just Thunk -> tick_alloc_thk + Just ThunkSelector -> tick_alloc_thk + -- black hole + Nothing -> return () where -- will be needed when we fill in stubs - cl_size = closureSize cl_info - slop_size = slopSize cl_info + _cl_size = closureSize cl_info + _slop_size = slopSize cl_info tick_alloc_thk | closureUpdReqd cl_info = tick_alloc_up_thk | otherwise = tick_alloc_se_thk - tick_alloc_con = panic "ToDo: tick_alloc" - tick_alloc_fun = panic "ToDo: tick_alloc" - tick_alloc_up_thk = panic "ToDo: tick_alloc" - tick_alloc_se_thk = panic "ToDo: tick_alloc" + -- krc: changed from panic to return () + -- just to get something working + tick_alloc_con = return () + tick_alloc_fun = return () + tick_alloc_up_thk = return () + tick_alloc_se_thk = return () + tickyAllocPrim :: CmmExpr -> CmmExpr -> CmmExpr -> Code -tickyAllocPrim hdr goods slop = ifTicky $ panic "ToDo: tickyAllocPrim" +tickyAllocPrim _hdr _goods _slop = ifTicky $ pprTrace "ToDo: tickyAllocPrim" empty (return ()) tickyAllocThunk :: CmmExpr -> CmmExpr -> Code -tickyAllocThunk goods slop = ifTicky $ panic "ToDo: tickyAllocThunk" +tickyAllocThunk _goods _slop = ifTicky $ pprTrace "ToDo: tickyAllocThunk" empty (return ()) tickyAllocPAP :: CmmExpr -> CmmExpr -> Code -tickyAllocPAP goods slop = ifTicky $ panic "ToDo: tickyAllocPAP" +tickyAllocPAP _goods _slop = ifTicky $ pprTrace "ToDo: tickyAllocPAP" empty (return ()) tickyAllocHeap :: VirtualHpOffset -> Code -- Called when doing a heap check [TICK_ALLOC_HEAP] @@ -271,50 +288,56 @@ tickyAllocHeap hp if hp == 0 then [] -- Inside the stmtC to avoid control else [ -- dependency on the argument -- Bump the allcoation count in the StgEntCounter - addToMem REP_StgEntCounter_allocs + addToMem (typeWidth REP_StgEntCounter_allocs) (CmmLit (cmmLabelOffB ticky_ctr oFFSET_StgEntCounter_allocs)) hp, -- Bump ALLOC_HEAP_ctr - addToMemLbl cLongRep (mkRtsDataLabel SLIT("ALLOC_HEAP_ctr")) 1, - -- Bump ALLOC_HEAP_tot - addToMemLbl cLongRep (mkRtsDataLabel SLIT("ALLOC_HEAP_tot")) hp] } + addToMemLbl cLongWidth (mkCmmDataLabel rtsPackageId $ fsLit "ALLOC_HEAP_ctr") 1, + -- Bump ALLOC_HEAP_tot + addToMemLbl cLongWidth (mkCmmDataLabel rtsPackageId $ fsLit "ALLOC_HEAP_tot") hp] } -- ----------------------------------------------------------------------------- -- Ticky utils ifTicky :: Code -> Code -ifTicky code - | opt_DoTickyProfiling = code - | otherwise = nopC +ifTicky code = do dflags <- getDynFlags + if doingTickyProfiling dflags then code + else nopC -addToMemLbl :: MachRep -> CLabel -> Int -> CmmStmt +addToMemLbl :: Width -> CLabel -> Int -> CmmStmt addToMemLbl rep lbl n = addToMem rep (CmmLit (CmmLabel lbl)) n -- All the ticky-ticky counters are declared "unsigned long" in C -bumpTickyCounter :: LitString -> Code -bumpTickyCounter lbl = bumpTickyCounter' (mkRtsDataLabel lbl) - -bumpTickyCounter' :: CLabel -> Code -bumpTickyCounter' lbl = stmtC (addToMemLbl cLongRep lbl 1) +bumpTickyCounter :: FastString -> Code +bumpTickyCounter lbl = bumpTickyCounter' (cmmLabelOffB (mkCmmDataLabel rtsPackageId lbl) 0) -addToMemLong = addToMem cLongRep +bumpTickyCounter' :: CmmLit -> Code +-- krc: note that we're incrementing the _entry_count_ field of the ticky counter +bumpTickyCounter' lhs = stmtC (addToMemLong (CmmLit lhs) 1) -bumpHistogram :: LitString -> Int -> Code -bumpHistogram lbl n - = bumpHistogramE lbl (CmmLit (CmmInt (fromIntegral n) cLongRep)) +bumpHistogram :: FastString -> Int -> Code +bumpHistogram _lbl _n +-- = bumpHistogramE lbl (CmmLit (CmmInt (fromIntegral n) cLong)) + = return () -- TEMP SPJ Apr 07 +{- bumpHistogramE :: LitString -> CmmExpr -> Code bumpHistogramE lbl n - = do t <- newTemp cLongRep - stmtC (CmmAssign t n) - emitIf (CmmMachOp (MO_U_Le cLongRep) [CmmReg t, eight]) $ - stmtC (CmmAssign t eight) - stmtC (addToMemLong (cmmIndexExpr cLongRep + = do t <- newTemp cLong + stmtC (CmmAssign (CmmLocal t) n) + emitIf (CmmMachOp (MO_U_Le cLongWidth) [CmmReg (CmmLocal t), eight]) $ + stmtC (CmmAssign (CmmLocal t) eight) + stmtC (addToMemLong (cmmIndexExpr cLongWidth (CmmLit (CmmLabel (mkRtsDataLabel lbl))) - (CmmReg t)) + (CmmReg (CmmLocal t))) 1) where - eight = CmmLit (CmmInt 8 cLongRep) + eight = CmmLit (CmmInt 8 cLongWidth) +-} + +------------------------------------------------------------------ +addToMemLong :: CmmExpr -> Int -> CmmStmt +addToMemLong = addToMem cLongWidth ------------------------------------------------------------------ -- Showing the "type category" for ticky-ticky profiling @@ -353,8 +376,6 @@ showTypeCategory ty else if utc == intDataConKey then 'I' else if utc == floatDataConKey then 'F' else if utc == doubleDataConKey then 'D' - else if utc == smallIntegerDataConKey || - utc == largeIntegerDataConKey then 'J' else if utc == charPrimTyConKey then 'c' else if (utc == intPrimTyConKey || utc == wordPrimTyConKey || utc == addrPrimTyConKey) then 'i' @@ -363,6 +384,6 @@ showTypeCategory ty else if isPrimTyCon tycon {- array, we hope -} then 'A' -- Bogus else if isEnumerationTyCon tycon then 'E' else if isTupleTyCon tycon then 'T' - else if isJust (maybeTyConSingleCon tycon) then 'S' + else if isJust (tyConSingleDataCon_maybe tycon) then 'S' else if utc == listTyConKey then 'L' else 'M' -- oh, well...