2c72860a2992758edb02fa628794513833946b8d
[ghc.git] / compiler / codeGen / CgClosure.lhs
1 %
2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 %
5 \section[CgClosure]{Code generation for closures}
6
7 This module provides the support code for @StgToAbstractC@ to deal
8 with {\em closures} on the RHSs of let(rec)s.  See also
9 @CgCon@, which deals with constructors.
10
11 \begin{code}
12 module CgClosure ( cgTopRhsClosure, 
13                    cgStdRhsClosure, 
14                    cgRhsClosure,
15                    emitBlackHoleCode,
16                    ) where
17
18 #include "HsVersions.h"
19
20 import {-# SOURCE #-} CgExpr ( cgExpr )
21
22 import CgMonad
23 import CgBindery
24 import CgHeapery
25 import CgStackery
26 import CgProf
27 import CgTicky
28 import CgParallel
29 import CgInfoTbls
30 import CgCallConv
31 import CgUtils
32 import ClosureInfo
33 import SMRep
34 import MachOp
35 import Cmm
36 import CmmUtils
37 import CLabel
38 import StgSyn
39 import CostCentre       
40 import Id
41 import Name
42 import Module
43 import ListSetOps
44 import Util
45 import BasicTypes
46 import Constants
47 import Outputable
48 import FastString
49 \end{code}
50
51 %********************************************************
52 %*                                                      *
53 \subsection[closures-no-free-vars]{Top-level closures}
54 %*                                                      *
55 %********************************************************
56
57 For closures bound at top level, allocate in static space.
58 They should have no free variables.
59
60 \begin{code}
61 cgTopRhsClosure :: Id
62                 -> CostCentreStack      -- Optional cost centre annotation
63                 -> StgBinderInfo
64                 -> UpdateFlag
65                 -> [Id]         -- Args
66                 -> StgExpr
67                 -> FCode (Id, CgIdInfo)
68
69 cgTopRhsClosure id ccs binder_info upd_flag args body = do
70   {     -- LAY OUT THE OBJECT
71     let name = idName id
72   ; lf_info  <- mkClosureLFInfo id TopLevel [] upd_flag args
73   ; srt_info <- getSRTInfo
74   ; mod_name <- getModuleName
75   ; let descr         = closureDescription mod_name name
76         closure_info  = mkClosureInfo True id lf_info 0 0 srt_info descr
77         closure_label = mkLocalClosureLabel name
78         cg_id_info    = stableIdInfo id (mkLblExpr closure_label) lf_info
79         closure_rep   = mkStaticClosureFields closure_info ccs True []
80
81          -- BUILD THE OBJECT, AND GENERATE INFO TABLE (IF NECESSARY)
82   ; emitDataLits closure_label closure_rep
83   ; forkClosureBody (closureCodeBody binder_info closure_info
84                                      ccs args body)
85
86   ; returnFC (id, cg_id_info) }
87 \end{code}
88
89 %********************************************************
90 %*                                                      *
91 \subsection[non-top-level-closures]{Non top-level closures}
92 %*                                                      *
93 %********************************************************
94
95 For closures with free vars, allocate in heap.
96
97 \begin{code}
98 cgStdRhsClosure
99         :: Id
100         -> CostCentreStack      -- Optional cost centre annotation
101         -> StgBinderInfo
102         -> [Id]                 -- Free vars
103         -> [Id]                 -- Args
104         -> StgExpr
105         -> LambdaFormInfo
106         -> [StgArg]             -- payload
107         -> FCode (Id, CgIdInfo)
108
109 cgStdRhsClosure bndr cc bndr_info fvs args body lf_info payload 
110   = do  -- AHA!  A STANDARD-FORM THUNK
111   {     -- LAY OUT THE OBJECT
112     amodes <- getArgAmodes payload
113   ; mod_name <- getModuleName
114   ; let (tot_wds, ptr_wds, amodes_w_offsets) 
115             = mkVirtHeapOffsets (isLFThunk lf_info) amodes
116
117         descr        = closureDescription mod_name (idName bndr)
118         closure_info = mkClosureInfo False      -- Not static
119                                      bndr lf_info tot_wds ptr_wds 
120                                      NoC_SRT    -- No SRT for a std-form closure
121                                      descr
122                 
123   ; (use_cc, blame_cc) <- chooseDynCostCentres cc args body
124
125         -- BUILD THE OBJECT
126   ; heap_offset <- allocDynClosure closure_info use_cc blame_cc amodes_w_offsets
127
128         -- RETURN
129   ; returnFC (bndr, heapIdInfo bndr heap_offset lf_info) }
130 \end{code}
131
132 Here's the general case.
133
134 \begin{code}
135 cgRhsClosure    :: Id
136                 -> CostCentreStack      -- Optional cost centre annotation
137                 -> StgBinderInfo
138                 -> [Id]                 -- Free vars
139                 -> UpdateFlag
140                 -> [Id]                 -- Args
141                 -> StgExpr
142                 -> FCode (Id, CgIdInfo)
143
144 cgRhsClosure bndr cc bndr_info fvs upd_flag args body = do
145   {     -- LAY OUT THE OBJECT
146         -- If the binder is itself a free variable, then don't store
147         -- it in the closure.  Instead, just bind it to Node on entry.
148         -- NB we can be sure that Node will point to it, because we
149         -- havn't told mkClosureLFInfo about this; so if the binder
150         -- _was_ a free var of its RHS, mkClosureLFInfo thinks it *is*
151         -- stored in the closure itself, so it will make sure that
152         -- Node points to it...
153     let
154         name         = idName bndr
155         is_elem      = isIn "cgRhsClosure"
156         bndr_is_a_fv = bndr `is_elem` fvs
157         reduced_fvs | bndr_is_a_fv = fvs `minusList` [bndr]
158                     | otherwise    = fvs
159
160   ; lf_info <- mkClosureLFInfo bndr NotTopLevel fvs upd_flag args
161   ; fv_infos <- mapFCs getCgIdInfo reduced_fvs
162   ; srt_info <- getSRTInfo
163   ; mod_name <- getModuleName
164   ; let bind_details :: [(CgIdInfo, VirtualHpOffset)]
165         (tot_wds, ptr_wds, bind_details) 
166            = mkVirtHeapOffsets (isLFThunk lf_info) (map add_rep fv_infos)
167
168         add_rep info = (cgIdInfoArgRep info, info)
169
170         descr        = closureDescription mod_name name
171         closure_info = mkClosureInfo False      -- Not static
172                                      bndr lf_info tot_wds ptr_wds
173                                      srt_info descr
174
175         -- BUILD ITS INFO TABLE AND CODE
176   ; forkClosureBody (do
177         {       -- Bind the fvs
178           let bind_fv (info, offset) 
179                 = bindNewToNode (cgIdInfoId info) offset (cgIdInfoLF info)
180         ; mapCs bind_fv bind_details
181
182                 -- Bind the binder itself, if it is a free var
183         ; whenC bndr_is_a_fv (bindNewToReg bndr nodeReg lf_info)
184         
185                 -- Compile the body
186         ; closureCodeBody bndr_info closure_info cc args body })
187
188         -- BUILD THE OBJECT
189   ; let
190         to_amode (info, offset) = do { amode <- idInfoToAmode info
191                                      ; return (amode, offset) }
192   ; (use_cc, blame_cc) <- chooseDynCostCentres cc args body
193   ; amodes_w_offsets <- mapFCs to_amode bind_details
194   ; heap_offset <- allocDynClosure closure_info use_cc blame_cc amodes_w_offsets
195
196         -- RETURN
197   ; returnFC (bndr, heapIdInfo bndr heap_offset lf_info) }
198
199
200 mkClosureLFInfo :: Id           -- The binder
201                 -> TopLevelFlag -- True of top level
202                 -> [Id]         -- Free vars
203                 -> UpdateFlag   -- Update flag
204                 -> [Id]         -- Args
205                 -> FCode LambdaFormInfo
206 mkClosureLFInfo bndr top fvs upd_flag args
207   | null args = return (mkLFThunk (idType bndr) top fvs upd_flag)
208   | otherwise = do { arg_descr <- mkArgDescr (idName bndr) args
209                    ; return (mkLFReEntrant top fvs args arg_descr) }
210 \end{code}
211
212
213 %************************************************************************
214 %*                                                                      *
215 \subsection[code-for-closures]{The code for closures}
216 %*                                                                      *
217 %************************************************************************
218
219 \begin{code}
220 closureCodeBody :: StgBinderInfo
221                 -> ClosureInfo     -- Lots of information about this closure
222                 -> CostCentreStack -- Optional cost centre attached to closure
223                 -> [Id]
224                 -> StgExpr
225                 -> Code
226 \end{code}
227
228 There are two main cases for the code for closures.  If there are {\em
229 no arguments}, then the closure is a thunk, and not in normal form.
230 So it should set up an update frame (if it is shared).
231 NB: Thunks cannot have a primitive type!
232
233 \begin{code}
234 closureCodeBody binder_info cl_info cc [{- No args i.e. thunk -}] body = do
235   { body_absC <- getCgStmts $ do
236         { tickyEnterThunk cl_info
237         ; ldvEnter (CmmReg nodeReg)  -- NB: Node always points when profiling
238         ; thunkWrapper cl_info $ do
239                 -- We only enter cc after setting up update so
240                 -- that cc of enclosing scope will be recorded
241                 -- in update frame CAF/DICT functions will be
242                 -- subsumed by this enclosing cc
243             { enterCostCentre cl_info cc body
244             ; cgExpr body }
245         }
246     
247   ; emitClosureCodeAndInfoTable cl_info [] body_absC }
248 \end{code}
249
250 If there is /at least one argument/, then this closure is in
251 normal form, so there is no need to set up an update frame.
252
253 The Macros for GrAnSim are produced at the beginning of the
254 argSatisfactionCheck (by calling fetchAndReschedule).  There info if
255 Node points to closure is available. -- HWL
256
257 \begin{code}
258 closureCodeBody binder_info cl_info cc args body 
259   = ASSERT( length args > 0 )
260   do {  -- Get the current virtual Sp (it might not be zero, 
261         -- eg. if we're compiling a let-no-escape).
262     vSp <- getVirtSp
263   ; let (reg_args, other_args) = assignCallRegs (addIdReps args)
264         (sp_top, stk_args)     = mkVirtStkOffsets vSp other_args
265
266         -- Allocate the global ticky counter
267   ; let ticky_ctr_lbl = mkRednCountsLabel (closureName cl_info)
268   ; emitTickyCounter cl_info args sp_top
269
270         -- ...and establish the ticky-counter 
271         -- label for this block
272   ; setTickyCtrLabel ticky_ctr_lbl $ do
273
274         -- Emit the slow-entry code
275   { reg_save_code <- mkSlowEntryCode cl_info reg_args
276
277         -- Emit the main entry code
278   ; blks <- forkProc $
279             mkFunEntryCode cl_info cc reg_args stk_args
280                            sp_top reg_save_code body
281   ; emitClosureCodeAndInfoTable cl_info [] blks
282   }}
283
284
285
286 mkFunEntryCode :: ClosureInfo
287                -> CostCentreStack
288                -> [(Id,GlobalReg)]        -- Args in regs
289                -> [(Id,VirtualSpOffset)]  -- Args on stack
290                -> VirtualSpOffset         -- Last allocated word on stack
291                -> CmmStmts                -- Register-save code in case of GC
292                -> StgExpr
293                -> Code
294 -- The main entry code for the closure
295 mkFunEntryCode cl_info cc reg_args stk_args sp_top reg_save_code body = do
296   {     -- Bind args to regs/stack as appropriate,
297         -- and record expected position of sps
298   ; bindArgsToRegs  reg_args
299   ; bindArgsToStack stk_args
300   ; setRealAndVirtualSp sp_top
301
302         -- Enter the cost-centre, if required
303         -- ToDo: It's not clear why this is outside the funWrapper,
304         --       but the tickyEnterFun is inside. Perhaps we can put
305         --       them together?
306   ; enterCostCentre cl_info cc body
307
308         -- Do the business
309   ; funWrapper cl_info reg_args reg_save_code $ do
310         { tickyEnterFun cl_info
311         ; cgExpr body }
312   }
313 \end{code}
314
315 The "slow entry" code for a function.  This entry point takes its
316 arguments on the stack.  It loads the arguments into registers
317 according to the calling convention, and jumps to the function's
318 normal entry point.  The function's closure is assumed to be in
319 R1/node.
320
321 The slow entry point is used in two places:
322
323  (a) unknown calls: eg. stg_PAP_entry 
324  (b) returning from a heap-check failure
325
326 \begin{code}
327 mkSlowEntryCode :: ClosureInfo -> [(Id,GlobalReg)] -> FCode CmmStmts
328 -- If this function doesn't have a specialised ArgDescr, we need
329 -- to generate the function's arg bitmap, slow-entry code, and
330 -- register-save code for the heap-check failure
331 -- Here, we emit the slow-entry code, and 
332 -- return the register-save assignments
333 mkSlowEntryCode cl_info reg_args
334   | Just (_, ArgGen _) <- closureFunInfo cl_info
335   = do  { emitSimpleProc slow_lbl (emitStmts load_stmts)
336         ; return save_stmts }
337   | otherwise = return noStmts
338   where
339      name = closureName cl_info
340      slow_lbl = mkSlowEntryLabel name
341
342      load_stmts = mkStmts load_assts `plusStmts` mkStmts [stk_adj_pop, jump_to_entry]
343      save_stmts = oneStmt stk_adj_push `plusStmts`  mkStmts save_assts
344
345      reps_w_regs :: [(CgRep,GlobalReg)]
346      reps_w_regs = [(idCgRep id, reg) | (id,reg) <- reverse reg_args]
347      (final_stk_offset, stk_offsets)
348         = mapAccumL (\off (rep,_) -> (off + cgRepSizeW rep, off))
349                     0 reps_w_regs
350
351      load_assts = zipWithEqual "mk_load" mk_load reps_w_regs stk_offsets
352      mk_load (rep,reg) offset = CmmAssign (CmmGlobal reg) 
353                                           (CmmLoad (cmmRegOffW spReg offset)
354                                                    (argMachRep rep))
355
356      save_assts = zipWithEqual "mk_save" mk_save reps_w_regs stk_offsets
357      mk_save (rep,reg) offset = ASSERT( argMachRep rep == globalRegRep reg )
358                                 CmmStore (cmmRegOffW spReg offset) 
359                                          (CmmReg (CmmGlobal reg))
360
361      stk_adj_pop   = CmmAssign spReg (cmmRegOffW spReg final_stk_offset)
362      stk_adj_push  = CmmAssign spReg (cmmRegOffW spReg (- final_stk_offset))
363      jump_to_entry = CmmJump (mkLblExpr (enterLocalIdLabel name)) []
364 \end{code}
365
366
367 %************************************************************************
368 %*                                                                      *
369 \subsubsection[closure-code-wrappers]{Wrappers around closure code}
370 %*                                                                      *
371 %************************************************************************
372
373 \begin{code}
374 thunkWrapper:: ClosureInfo -> Code -> Code
375 thunkWrapper closure_info thunk_code = do
376   { let node_points = nodeMustPointToIt (closureLFInfo closure_info)
377
378     -- HWL: insert macros for GrAnSim; 2 versions depending on liveness of node
379     -- (we prefer fetchAndReschedule-style context switches to yield ones)
380   ; if node_points 
381     then granFetchAndReschedule [] node_points 
382     else granYield              [] node_points
383
384         -- Stack and/or heap checks
385   ; thunkEntryChecks closure_info $ do
386         {       -- Overwrite with black hole if necessary
387           whenC (blackHoleOnEntry closure_info && node_points)
388                 (blackHoleIt closure_info)
389         ; setupUpdate closure_info thunk_code }
390                 -- setupUpdate *encloses* the thunk_code
391   }
392
393 funWrapper :: ClosureInfo       -- Closure whose code body this is
394            -> [(Id,GlobalReg)]  -- List of argument registers (if any)
395            -> CmmStmts          -- reg saves for the heap check failure
396            -> Code              -- Body of function being compiled
397            -> Code
398 funWrapper closure_info arg_regs reg_save_code fun_body = do
399   { let node_points = nodeMustPointToIt (closureLFInfo closure_info)
400
401         -- Enter for Ldv profiling
402   ; whenC node_points (ldvEnter (CmmReg nodeReg))
403
404         -- GranSim yeild poin
405   ; granYield arg_regs node_points
406
407         -- Heap and/or stack checks wrap the function body
408   ; funEntryChecks closure_info reg_save_code 
409                    fun_body
410   }
411 \end{code}
412
413
414 %************************************************************************
415 %*                                                                      *
416 \subsubsubsection[update-and-BHs]{Update and black-hole wrappers}
417 %*                                                                      *
418 %************************************************************************
419
420
421 \begin{code}
422 blackHoleIt :: ClosureInfo -> Code
423 -- Only called for closures with no args
424 -- Node points to the closure
425 blackHoleIt closure_info = emitBlackHoleCode (closureSingleEntry closure_info)
426
427 emitBlackHoleCode :: Bool -> Code
428 emitBlackHoleCode is_single_entry 
429   | eager_blackholing = do 
430         tickyBlackHole (not is_single_entry)
431         stmtC (CmmStore (CmmReg nodeReg) (CmmLit (CmmLabel bh_lbl)))
432   | otherwise = 
433         nopC
434   where
435     bh_lbl | is_single_entry = mkRtsDataLabel SLIT("stg_SE_BLACKHOLE_info")
436            | otherwise       = mkRtsDataLabel SLIT("stg_BLACKHOLE_info")
437
438         -- If we wanted to do eager blackholing with slop filling,
439         -- we'd need to do it at the *end* of a basic block, otherwise
440         -- we overwrite the free variables in the thunk that we still
441         -- need.  We have a patch for this from Andy Cheadle, but not
442         -- incorporated yet. --SDM [6/2004]
443         --
444         -- Profiling needs slop filling (to support LDV profiling), so
445         -- currently eager blackholing doesn't work with profiling.
446         --
447         -- Previously, eager blackholing was enabled when ticky-ticky
448         -- was on. But it didn't work, and it wasn't strictly necessary 
449         -- to bring back minimal ticky-ticky, so now EAGER_BLACKHOLING 
450         -- is unconditionally disabled. -- krc 1/2007
451
452     eager_blackholing = False 
453 \end{code}
454
455 \begin{code}
456 setupUpdate :: ClosureInfo -> Code -> Code      -- Only called for closures with no args
457         -- Nota Bene: this function does not change Node (even if it's a CAF),
458         -- so that the cost centre in the original closure can still be
459         -- extracted by a subsequent enterCostCentre
460 setupUpdate closure_info code
461   | closureReEntrant closure_info
462   = code
463
464   | not (isStaticClosure closure_info)
465   = if closureUpdReqd closure_info
466     then do { tickyPushUpdateFrame;  pushUpdateFrame (CmmReg nodeReg) code }
467     else do { tickyUpdateFrameOmitted; code }
468  
469   | otherwise   -- A static closure
470   = do  { tickyUpdateBhCaf closure_info
471
472         ; if closureUpdReqd closure_info
473           then do       -- Blackhole the (updatable) CAF:
474                 { upd_closure <- link_caf closure_info True
475                 ; pushUpdateFrame upd_closure code }
476           else do
477                 { -- krc: removed some ticky-related code here.
478                 ; tickyUpdateFrameOmitted
479                 ; code }
480     }
481
482
483 -----------------------------------------------------------------------------
484 -- Entering a CAF
485 --
486 -- When a CAF is first entered, it creates a black hole in the heap,
487 -- and updates itself with an indirection to this new black hole.
488 --
489 -- We update the CAF with an indirection to a newly-allocated black
490 -- hole in the heap.  We also set the blocking queue on the newly
491 -- allocated black hole to be empty.
492 --
493 -- Why do we make a black hole in the heap when we enter a CAF?
494 --    
495 --     - for a  generational garbage collector, which needs a fast
496 --       test for whether an updatee is in an old generation or not
497 --
498 --     - for the parallel system, which can implement updates more
499 --       easily if the updatee is always in the heap. (allegedly).
500 --
501 -- When debugging, we maintain a separate CAF list so we can tell when
502 -- a CAF has been garbage collected.
503
504 -- newCAF must be called before the itbl ptr is overwritten, since
505 -- newCAF records the old itbl ptr in order to do CAF reverting
506 -- (which Hugs needs to do in order that combined mode works right.)
507 --
508
509 -- ToDo [Feb 04]  This entire link_caf nonsense could all be moved
510 -- into the "newCAF" RTS procedure, which we call anyway, including
511 -- the allocation of the black-hole indirection closure.
512 -- That way, code size would fall, the CAF-handling code would 
513 -- be closer together, and the compiler wouldn't need to know
514 -- about off_indirectee etc.
515
516 link_caf :: ClosureInfo
517          -> Bool                -- True <=> updatable, False <=> single-entry
518          -> FCode CmmExpr       -- Returns amode for closure to be updated
519 -- To update a CAF we must allocate a black hole, link the CAF onto the
520 -- CAF list, then update the CAF to point to the fresh black hole.
521 -- This function returns the address of the black hole, so it can be
522 -- updated with the new value when available.  The reason for all of this
523 -- is that we only want to update dynamic heap objects, not static ones,
524 -- so that generational GC is easier.
525 link_caf cl_info is_upd = do
526   {     -- Alloc black hole specifying CC_HDR(Node) as the cost centre
527   ; let use_cc   = costCentreFrom (CmmReg nodeReg)
528         blame_cc = use_cc
529   ; hp_offset <- allocDynClosure bh_cl_info use_cc blame_cc []
530   ; hp_rel    <- getHpRelOffset hp_offset
531
532         -- Call the RTS function newCAF to add the CAF to the CafList
533         -- so that the garbage collector can find them
534         -- This must be done *before* the info table pointer is overwritten, 
535         -- because the old info table ptr is needed for reversion
536   ; emitRtsCallWithVols SLIT("newCAF") [(CmmReg nodeReg,PtrHint)] [node]
537         -- node is live, so save it.
538
539         -- Overwrite the closure with a (static) indirection 
540         -- to the newly-allocated black hole
541   ; stmtsC [ CmmStore (cmmRegOffW nodeReg off_indirectee) hp_rel
542            , CmmStore (CmmReg nodeReg) ind_static_info ]
543
544   ; returnFC hp_rel }
545   where
546     bh_cl_info :: ClosureInfo
547     bh_cl_info | is_upd    = cafBlackHoleClosureInfo   cl_info
548                | otherwise = seCafBlackHoleClosureInfo cl_info
549
550     ind_static_info :: CmmExpr
551     ind_static_info = mkLblExpr mkIndStaticInfoLabel
552
553     off_indirectee :: WordOff
554     off_indirectee = fixedHdrSize + oFFSET_StgInd_indirectee*wORD_SIZE
555 \end{code}
556
557
558 %************************************************************************
559 %*                                                                      *
560 \subsection[CgClosure-Description]{Profiling Closure Description.}
561 %*                                                                      *
562 %************************************************************************
563
564 For "global" data constructors the description is simply occurrence
565 name of the data constructor itself.  Otherwise it is determined by
566 @closureDescription@ from the let binding information.
567
568 \begin{code}
569 closureDescription :: Module            -- Module
570                    -> Name              -- Id of closure binding
571                    -> String
572         -- Not called for StgRhsCon which have global info tables built in
573         -- CgConTbls.lhs with a description generated from the data constructor
574 closureDescription mod_name name
575   = showSDocDump (char '<' <>
576                     (if isExternalName name
577                       then ppr name -- ppr will include the module name prefix
578                       else pprModule mod_name <> char '.' <> ppr name) <>
579                     char '>')
580    -- showSDocDump, because we want to see the unique on the Name.
581 \end{code}
582