Fix cloning bugs in SpecConstr
[ghc-hetmet.git] / compiler / codeGen / CgTicky.hs
1 -----------------------------------------------------------------------------
2 --
3 -- Code generation for ticky-ticky profiling
4 --
5 -- (c) The University of Glasgow 2004-2006
6 --
7 -----------------------------------------------------------------------------
8
9 module CgTicky (
10         emitTickyCounter,
11
12         tickyDynAlloc,
13         tickyAllocHeap,
14         tickyAllocPrim,
15         tickyAllocThunk,
16         tickyAllocPAP,
17
18         tickyPushUpdateFrame,
19         tickyUpdateFrameOmitted,
20
21         tickyEnterDynCon,
22         tickyEnterStaticCon,
23         tickyEnterViaNode,
24
25         tickyEnterFun, 
26         tickyEnterThunk,
27
28         tickyUpdateBhCaf,
29         tickyBlackHole,
30         tickyUnboxedTupleReturn, tickyVectoredReturn,
31         tickyReturnOldCon, tickyReturnNewCon,
32
33         tickyKnownCallTooFewArgs, tickyKnownCallExact, tickyKnownCallExtraArgs,
34         tickyUnknownCall, tickySlowCallPat,
35
36        staticTickyHdr,
37   ) where
38
39 #include "HsVersions.h"
40 #include "../includes/DerivedConstants.h"
41         -- For REP_xxx constants, which are MachReps
42
43 import ClosureInfo
44 import CgUtils
45 import CgMonad
46 import SMRep
47
48 import Cmm
49 import MachOp
50 import CmmUtils
51 import CLabel
52
53 import Name
54 import Id
55 import StaticFlags
56 import BasicTypes
57 import FastString
58 import Constants
59 import Outputable
60
61 -- Turgid imports for showTypeCategory
62 import PrelNames
63 import TcType
64 import TyCon
65
66 import Data.Maybe
67
68 -----------------------------------------------------------------------------
69 --
70 --              Ticky-ticky profiling
71 --
72 -----------------------------------------------------------------------------
73
74 staticTickyHdr :: [CmmLit]
75 -- krc: not using this right now --
76 -- in the new version of ticky-ticky, we
77 -- don't change the closure layout.
78 -- leave it defined, though, to avoid breaking
79 -- other things.
80 staticTickyHdr = []
81
82 emitTickyCounter :: ClosureInfo -> [Id] -> Int -> Code
83 emitTickyCounter cl_info args on_stk
84   = ifTicky $
85     do  { mod_name <- getModuleName
86         ; fun_descr_lit <- mkStringCLit (fun_descr mod_name)
87         ; arg_descr_lit <- mkStringCLit arg_descr
88         ; emitDataLits ticky_ctr_label  -- Must match layout of StgEntCounter
89 -- krc: note that all the fields are I32 now; some were I16 before, 
90 -- but the code generator wasn't handling that properly and it led to chaos, 
91 -- panic and disorder.
92             [ mkIntCLit 0,
93               mkIntCLit (length args),-- Arity
94               mkIntCLit on_stk, -- Words passed on stack
95               fun_descr_lit,
96               arg_descr_lit,
97               zeroCLit,                 -- Entry count
98               zeroCLit,                 -- Allocs
99               zeroCLit                  -- Link
100             ] }
101   where
102     name = closureName cl_info
103     ticky_ctr_label = mkRednCountsLabel name
104     arg_descr = map (showTypeCategory . idType) args
105     fun_descr mod_name = ppr_for_ticky_name mod_name name
106
107 -- When printing the name of a thing in a ticky file, we want to
108 -- give the module name even for *local* things.   We print
109 -- just "x (M)" rather that "M.x" to distinguish them from the global kind.
110 ppr_for_ticky_name mod_name name
111   | isInternalName name = showSDocDebug (ppr name <+> (parens (ppr mod_name)))
112   | otherwise           = showSDocDebug (ppr name)
113
114 -- -----------------------------------------------------------------------------
115 -- Ticky stack frames
116
117 tickyPushUpdateFrame    = ifTicky $ bumpTickyCounter SLIT("UPDF_PUSHED_ctr")
118 tickyUpdateFrameOmitted = ifTicky $ bumpTickyCounter SLIT("UPDF_OMITTED_ctr")
119
120 -- -----------------------------------------------------------------------------
121 -- Ticky entries
122
123 tickyEnterDynCon      = ifTicky $ bumpTickyCounter SLIT("ENT_DYN_CON_ctr")
124 tickyEnterDynThunk    = ifTicky $ bumpTickyCounter SLIT("ENT_DYN_THK_ctr")
125 tickyEnterStaticCon   = ifTicky $ bumpTickyCounter SLIT("ENT_STATIC_CON_ctr")
126 tickyEnterStaticThunk = ifTicky $ bumpTickyCounter SLIT("ENT_STATIC_THK_ctr")
127 tickyEnterViaNode     = ifTicky $ bumpTickyCounter SLIT("ENT_VIA_NODE_ctr")
128
129 tickyEnterThunk :: ClosureInfo -> Code
130 tickyEnterThunk cl_info
131   | isStaticClosure cl_info = tickyEnterStaticThunk
132   | otherwise               = tickyEnterDynThunk
133
134 tickyBlackHole :: Bool{-updatable-} -> Code
135 tickyBlackHole updatable
136   = ifTicky (bumpTickyCounter ctr)
137   where
138     ctr | updatable = SLIT("UPD_BH_SINGLE_ENTRY_ctr")
139         | otherwise = SLIT("UPD_BH_UPDATABLE_ctr")
140
141 tickyUpdateBhCaf cl_info
142   = ifTicky (bumpTickyCounter ctr)
143   where
144     ctr | closureUpdReqd cl_info = SLIT("UPD_CAF_BH_SINGLE_ENTRY_ctr")
145         | otherwise              = SLIT("UPD_CAF_BH_UPDATABLE_ctr")
146
147 tickyEnterFun :: ClosureInfo -> Code
148 tickyEnterFun cl_info
149   = ifTicky $ 
150     do  { bumpTickyCounter ctr
151         ; fun_ctr_lbl <- getTickyCtrLabel
152         ; registerTickyCtr fun_ctr_lbl
153         ; bumpTickyCounter' (cmmLabelOffB fun_ctr_lbl oFFSET_StgEntCounter_entry_count)
154         }
155   where
156     ctr | isStaticClosure cl_info = SLIT("ENT_STATIC_FUN_DIRECT_ctr")
157         | otherwise               = SLIT("ENT_DYN_FUN_DIRECT_ctr")
158
159 registerTickyCtr :: CLabel -> Code
160 -- Register a ticky counter
161 --   if ( ! f_ct.registeredp ) {
162 --          f_ct.link = ticky_entry_ctrs;       /* hook this one onto the front of the list */
163 --          ticky_entry_ctrs = & (f_ct);        /* mark it as "registered" */
164 --          f_ct.registeredp = 1 }
165 registerTickyCtr ctr_lbl
166   = emitIf test (stmtsC register_stmts)
167   where
168     -- krc: code generator doesn't handle Not, so we test for Eq 0 instead
169     test = CmmMachOp (MO_Eq wordRep)
170               [CmmLoad (CmmLit (cmmLabelOffB ctr_lbl 
171                                 oFFSET_StgEntCounter_registeredp)) wordRep,
172                CmmLit (mkIntCLit 0)]
173     register_stmts
174       = [ CmmStore (CmmLit (cmmLabelOffB ctr_lbl oFFSET_StgEntCounter_link))
175                    (CmmLoad ticky_entry_ctrs wordRep)
176         , CmmStore ticky_entry_ctrs (mkLblExpr ctr_lbl)
177         , CmmStore (CmmLit (cmmLabelOffB ctr_lbl 
178                                 oFFSET_StgEntCounter_registeredp))
179                    (CmmLit (mkIntCLit 1)) ]
180     ticky_entry_ctrs = mkLblExpr (mkRtsDataLabel SLIT("ticky_entry_ctrs"))
181
182 tickyReturnOldCon, tickyReturnNewCon :: Arity -> Code
183 tickyReturnOldCon arity 
184   = ifTicky $ do { bumpTickyCounter SLIT("RET_OLD_ctr")
185                  ; bumpHistogram SLIT("RET_OLD_hst") arity }
186 tickyReturnNewCon arity 
187   | not opt_DoTickyProfiling = nopC
188   | otherwise
189   = ifTicky $ do { bumpTickyCounter SLIT("RET_NEW_ctr")
190                  ; bumpHistogram SLIT("RET_NEW_hst") arity }
191
192 tickyUnboxedTupleReturn :: Int -> Code
193 tickyUnboxedTupleReturn arity
194   = ifTicky $ do { bumpTickyCounter SLIT("RET_UNBOXED_TUP_ctr")
195                  ; bumpHistogram SLIT("RET_UNBOXED_TUP_hst") arity }
196
197 tickyVectoredReturn :: Int -> Code
198 tickyVectoredReturn family_size 
199   = ifTicky $ do { bumpTickyCounter SLIT("VEC_RETURN_ctr")
200                  ; bumpHistogram SLIT("RET_VEC_RETURN_hst") family_size }
201
202 -- -----------------------------------------------------------------------------
203 -- Ticky calls
204
205 -- Ticks at a *call site*:
206 tickyKnownCallTooFewArgs = ifTicky $ bumpTickyCounter SLIT("KNOWN_CALL_TOO_FEW_ARGS_ctr")
207 tickyKnownCallExact = ifTicky $ bumpTickyCounter SLIT("KNOWN_CALL_ctr")
208 tickyKnownCallExtraArgs = ifTicky $ bumpTickyCounter SLIT("KNOWN_CALL_EXTRA_ARGS_ctr")
209 tickyUnknownCall = ifTicky $ bumpTickyCounter SLIT("UNKNOWN_CALL_ctr")
210
211 -- Tick for the call pattern at slow call site (i.e. in addition to
212 -- tickyUnknownCall, tickyKnownCallExtraArgs, etc.)
213 tickySlowCallPat :: [CgRep] -> Code
214 tickySlowCallPat args = return ()
215 {- LATER: (introduces recursive module dependency now).
216   case callPattern args of
217     (str, True)  -> bumpTickyCounter' (mkRtsSlowTickyCtrLabel pat)
218     (str, False) -> bumpTickyCounter  SLIT("TICK_SLOW_CALL_OTHER")
219
220 callPattern :: [CgRep] -> (String,Bool)
221 callPattern reps 
222   | match == length reps = (chars, True)
223   | otherwise            = (chars, False)
224   where (_,match) = findMatch reps
225         chars     = map argChar reps
226
227 argChar VoidArg   = 'v'
228 argChar PtrArg    = 'p'
229 argChar NonPtrArg = 'n'
230 argChar LongArg   = 'l'
231 argChar FloatArg  = 'f'
232 argChar DoubleArg = 'd'
233 -}
234
235 -- -----------------------------------------------------------------------------
236 -- Ticky allocation
237
238 tickyDynAlloc :: ClosureInfo -> Code
239 -- Called when doing a dynamic heap allocation
240 tickyDynAlloc cl_info
241   = ifTicky $
242     case smRepClosureType (closureSMRep cl_info) of
243         Just Constr           -> tick_alloc_con
244         Just ConstrNoCaf      -> tick_alloc_con
245         Just Fun              -> tick_alloc_fun
246         Just Thunk            -> tick_alloc_thk
247         Just ThunkSelector    -> tick_alloc_thk
248         -- black hole
249         Nothing               -> return ()
250   where
251         -- will be needed when we fill in stubs
252     cl_size   = closureSize cl_info
253     slop_size = slopSize cl_info
254
255     tick_alloc_thk 
256         | closureUpdReqd cl_info = tick_alloc_up_thk
257         | otherwise              = tick_alloc_se_thk
258
259     -- krc: changed from panic to return () 
260     -- just to get something working
261     tick_alloc_con = return ()
262     tick_alloc_fun = return ()
263     tick_alloc_up_thk = return ()
264     tick_alloc_se_thk = return ()
265
266
267 tickyAllocPrim :: CmmExpr -> CmmExpr -> CmmExpr -> Code
268 tickyAllocPrim hdr goods slop = ifTicky $ pprTrace "ToDo: tickyAllocPrim" empty (return ())
269
270 tickyAllocThunk :: CmmExpr -> CmmExpr -> Code
271 tickyAllocThunk goods slop = ifTicky $ pprTrace "ToDo: tickyAllocThunk" empty (return ())
272
273 tickyAllocPAP :: CmmExpr -> CmmExpr -> Code
274 tickyAllocPAP goods slop = ifTicky $ pprTrace "ToDo: tickyAllocPAP" empty (return ())
275
276 tickyAllocHeap :: VirtualHpOffset -> Code
277 -- Called when doing a heap check [TICK_ALLOC_HEAP]
278 tickyAllocHeap hp
279   = ifTicky $
280     do  { ticky_ctr <- getTickyCtrLabel
281         ; stmtsC $
282           if hp == 0 then []    -- Inside the stmtC to avoid control
283           else [                -- dependency on the argument
284                 -- Bump the allcoation count in the StgEntCounter
285             addToMem REP_StgEntCounter_allocs 
286                         (CmmLit (cmmLabelOffB ticky_ctr 
287                                 oFFSET_StgEntCounter_allocs)) hp,
288                 -- Bump ALLOC_HEAP_ctr
289             addToMemLbl cLongRep (mkRtsDataLabel SLIT("ALLOC_HEAP_ctr")) 1,
290                 -- Bump ALLOC_HEAP_tot
291             addToMemLbl cLongRep (mkRtsDataLabel SLIT("ALLOC_HEAP_tot")) hp] }
292
293 -- -----------------------------------------------------------------------------
294 -- Ticky utils
295
296 ifTicky :: Code -> Code
297 ifTicky code
298   | opt_DoTickyProfiling = code
299   | otherwise            = nopC
300
301 addToMemLbl :: MachRep -> CLabel -> Int -> CmmStmt
302 addToMemLbl rep lbl n = addToMem rep (CmmLit (CmmLabel lbl)) n
303
304 -- All the ticky-ticky counters are declared "unsigned long" in C
305 bumpTickyCounter :: LitString -> Code
306 bumpTickyCounter lbl = bumpTickyCounter' (cmmLabelOffB (mkRtsDataLabel lbl) 0)
307
308 bumpTickyCounter' :: CmmLit -> Code
309 -- krc: note that we're incrementing the _entry_count_ field of the ticky counter
310 bumpTickyCounter' lhs = stmtC (addToMem cLongRep (CmmLit lhs) 1)
311
312 addToMemLong = addToMem cLongRep
313
314 bumpHistogram :: LitString -> Int -> Code
315 bumpHistogram lbl n 
316 --  = bumpHistogramE lbl (CmmLit (CmmInt (fromIntegral n) cLongRep))
317     = return ()    -- TEMP SPJ Apr 07
318
319 bumpHistogramE :: LitString -> CmmExpr -> Code
320 bumpHistogramE lbl n 
321   = do  t <- newTemp cLongRep
322         stmtC (CmmAssign t n)
323         emitIf (CmmMachOp (MO_U_Le cLongRep) [CmmReg t, eight]) $
324                 stmtC (CmmAssign t eight)
325         stmtC (addToMemLong (cmmIndexExpr cLongRep 
326                                 (CmmLit (CmmLabel (mkRtsDataLabel lbl)))
327                                 (CmmReg t))
328                             1)
329   where 
330    eight = CmmLit (CmmInt 8 cLongRep)
331
332 ------------------------------------------------------------------
333 -- Showing the "type category" for ticky-ticky profiling
334
335 showTypeCategory :: Type -> Char
336   {-    {C,I,F,D}   char, int, float, double
337         T           tuple
338         S           other single-constructor type
339         {c,i,f,d}   unboxed ditto
340         t           *unpacked* tuple
341         s           *unpacked" single-cons...
342
343         v           void#
344         a           primitive array
345
346         E           enumeration type
347         +           dictionary, unless it's a ...
348         L           List
349         >           function
350         M           other (multi-constructor) data-con type
351         .           other type
352         -           reserved for others to mark as "uninteresting"
353     -}
354 showTypeCategory ty
355   = if isDictTy ty
356     then '+'
357     else
358       case tcSplitTyConApp_maybe ty of
359         Nothing -> if isJust (tcSplitFunTy_maybe ty)
360                    then '>'
361                    else '.'
362
363         Just (tycon, _) ->
364           let utc = getUnique tycon in
365           if      utc == charDataConKey    then 'C'
366           else if utc == intDataConKey     then 'I'
367           else if utc == floatDataConKey   then 'F'
368           else if utc == doubleDataConKey  then 'D'
369           else if utc == smallIntegerDataConKey ||
370                   utc == largeIntegerDataConKey   then 'J'
371           else if utc == charPrimTyConKey  then 'c'
372           else if (utc == intPrimTyConKey || utc == wordPrimTyConKey
373                 || utc == addrPrimTyConKey)                then 'i'
374           else if utc  == floatPrimTyConKey                then 'f'
375           else if utc  == doublePrimTyConKey               then 'd'
376           else if isPrimTyCon tycon {- array, we hope -}   then 'A'     -- Bogus
377           else if isEnumerationTyCon tycon                 then 'E'
378           else if isTupleTyCon tycon                       then 'T'
379           else if isJust (maybeTyConSingleCon tycon)       then 'S'
380           else if utc == listTyConKey                      then 'L'
381           else 'M' -- oh, well...