Fix warnings in CgCallConv
[ghc-hetmet.git] / compiler / codeGen / StgCmmClosure.hs
1 -----------------------------------------------------------------------------
2 --
3 -- Stg to C-- code generation:
4 -- 
5 -- The types   LambdaFormInfo
6 --             ClosureInfo
7 --
8 -- Nothing monadic in here!
9 --
10 -- (c) The University of Glasgow 2004-2006
11 --
12 -----------------------------------------------------------------------------
13
14
15 module StgCmmClosure (
16         SMRep, 
17         DynTag,  tagForCon, isSmallFamily,
18         ConTagZ, dataConTagZ,
19
20         ArgDescr(..), Liveness(..), 
21         C_SRT(..), needsSRT,
22
23         isVoidRep, isGcPtrRep, addIdReps, addArgReps,
24         argPrimRep, 
25
26         LambdaFormInfo,         -- Abstract
27         StandardFormInfo,       -- ...ditto...
28         mkLFThunk, mkLFReEntrant, mkConLFInfo, mkSelectorLFInfo,
29         mkApLFInfo, mkLFImported, mkLFArgument, mkLFLetNoEscape,
30         lfDynTag,
31
32         ClosureInfo,
33         mkClosureInfo, mkConInfo, maybeIsLFCon,
34
35         closureSize, closureNonHdrSize,
36         closureGoodStuffSize, closurePtrsSize,
37         slopSize, 
38
39         closureName, infoTableLabelFromCI,
40         closureLabelFromCI,
41         closureTypeInfo,
42         closureLFInfo, isLFThunk,closureSMRep, closureUpdReqd, 
43         closureNeedsUpdSpace, closureIsThunk,
44         closureSingleEntry, closureReEntrant, isConstrClosure_maybe,
45         closureFunInfo, isStandardFormThunk, isKnownFun,
46         funTag, tagForArity, 
47
48         enterIdLabel, enterLocalIdLabel, 
49
50         nodeMustPointToIt, 
51         CallMethod(..), getCallMethod,
52
53         blackHoleOnEntry,
54
55         getClosureType,
56
57         isToplevClosure,
58         closureValDescr, closureTypeDescr,      -- profiling
59
60         isStaticClosure,
61         cafBlackHoleClosureInfo, 
62
63         staticClosureNeedsLink, clHasCafRefs 
64     ) where
65
66 #include "../includes/MachDeps.h"
67
68 #define FAST_STRING_NOT_NEEDED
69 #include "HsVersions.h"
70
71 import ClosureInfo (ArgDescr(..), C_SRT(..), Liveness(..))
72         -- XXX temporary becuase FunInfo needs this one
73
74 import StgSyn
75 import SMRep
76 import Cmm      ( ClosureTypeInfo(..), ConstrDescription )
77 import CmmExpr
78
79 import CLabel
80 import StaticFlags
81 import Id
82 import IdInfo
83 import DataCon
84 import Name
85 import OccName
86 import Type
87 import TypeRep
88 import TcType
89 import TyCon
90 import BasicTypes
91 import Outputable
92 import Constants
93 import DynFlags
94
95 -----------------------------------------------------------------------------
96 --              Representations
97 -----------------------------------------------------------------------------
98
99 addIdReps :: [Id] -> [(PrimRep, Id)]
100 addIdReps ids = [(idPrimRep id, id) | id <- ids]
101
102 addArgReps :: [StgArg] -> [(PrimRep, StgArg)]
103 addArgReps args = [(argPrimRep arg, arg) | arg <- args]
104
105 argPrimRep :: StgArg -> PrimRep
106 argPrimRep arg = typePrimRep (stgArgType arg)
107
108 isVoidRep :: PrimRep -> Bool
109 isVoidRep VoidRep = True
110 isVoidRep _other  = False
111
112 isGcPtrRep :: PrimRep -> Bool
113 isGcPtrRep PtrRep = True
114 isGcPtrRep _      = False
115
116
117 -----------------------------------------------------------------------------
118 --              LambdaFormInfo
119 -----------------------------------------------------------------------------
120
121 -- Information about an identifier, from the code generator's point of
122 -- view.  Every identifier is bound to a LambdaFormInfo in the
123 -- environment, which gives the code generator enough info to be able to
124 -- tail call or return that identifier.
125
126 data LambdaFormInfo
127   = LFReEntrant         -- Reentrant closure (a function)
128         TopLevelFlag    -- True if top level
129         !Int            -- Arity. Invariant: always > 0
130         !Bool           -- True <=> no fvs
131         ArgDescr        -- Argument descriptor (should really be in ClosureInfo)
132
133   | LFThunk             -- Thunk (zero arity)
134         TopLevelFlag
135         !Bool           -- True <=> no free vars
136         !Bool           -- True <=> updatable (i.e., *not* single-entry)
137         StandardFormInfo
138         !Bool           -- True <=> *might* be a function type
139
140   | LFCon               -- A saturated constructor application
141         DataCon         -- The constructor
142
143   | LFUnknown           -- Used for function arguments and imported things.
144                         -- We know nothing about this closure.  
145                         -- Treat like updatable "LFThunk"...
146                         -- Imported things which we *do* know something about use
147                         -- one of the other LF constructors (eg LFReEntrant for
148                         -- known functions)
149         !Bool           -- True <=> *might* be a function type
150                         --      The False case is good when we want to enter it,
151                         --      because then we know the entry code will do
152                         --      For a function, the entry code is the fast entry point
153
154   | LFUnLifted          -- A value of unboxed type; 
155                         -- always a value, neeeds evaluation
156
157   | LFLetNoEscape       -- See LetNoEscape module for precise description 
158
159   | LFBlackHole         -- Used for the closures allocated to hold the result
160                         -- of a CAF.  We want the target of the update frame to
161                         -- be in the heap, so we make a black hole to hold it.
162         CLabel          -- Flavour (info label, eg CAF_BLACKHOLE_info).
163
164
165 -------------------------
166 -- An ArgDsecr describes the argument pattern of a function
167
168 {-      XXX  -- imported from old ClosureInfo for now
169 data ArgDescr
170   = ArgSpec             -- Fits one of the standard patterns
171         !StgHalfWord    -- RTS type identifier ARG_P, ARG_N, ...
172
173   | ArgGen              -- General case
174         Liveness        -- Details about the arguments
175 -}
176
177 {-      XXX  -- imported from old ClosureInfo for now
178 -------------------------
179 -- We represent liveness bitmaps as a Bitmap (whose internal
180 -- representation really is a bitmap).  These are pinned onto case return
181 -- vectors to indicate the state of the stack for the garbage collector.
182 -- 
183 -- In the compiled program, liveness bitmaps that fit inside a single
184 -- word (StgWord) are stored as a single word, while larger bitmaps are
185 -- stored as a pointer to an array of words. 
186
187 data Liveness
188   = SmallLiveness       -- Liveness info that fits in one word
189         StgWord         -- Here's the bitmap
190
191   | BigLiveness         -- Liveness info witha a multi-word bitmap
192         CLabel          -- Label for the bitmap
193 -}
194
195 -------------------------
196 -- StandardFormInfo tells whether this thunk has one of 
197 -- a small number of standard forms
198
199 data StandardFormInfo
200   = NonStandardThunk
201         -- Not of of the standard forms
202
203   | SelectorThunk
204         -- A SelectorThunk is of form
205         --      case x of
206         --             con a1,..,an -> ak
207         -- and the constructor is from a single-constr type.
208        WordOff          -- 0-origin offset of ak within the "goods" of 
209                         -- constructor (Recall that the a1,...,an may be laid
210                         -- out in the heap in a non-obvious order.)
211
212   | ApThunk 
213         -- An ApThunk is of form
214         --      x1 ... xn
215         -- The code for the thunk just pushes x2..xn on the stack and enters x1.
216         -- There are a few of these (for 1 <= n <= MAX_SPEC_AP_SIZE) pre-compiled
217         -- in the RTS to save space.
218         Int             -- Arity, n
219
220
221 ------------------------------------------------------
222 --              Building LambdaFormInfo
223 ------------------------------------------------------
224
225 mkLFArgument :: Id -> LambdaFormInfo
226 mkLFArgument id 
227   | isUnLiftedType ty      = LFUnLifted
228   | might_be_a_function ty = LFUnknown True
229   | otherwise              = LFUnknown False
230   where
231     ty = idType id
232
233 -------------
234 mkLFLetNoEscape :: LambdaFormInfo
235 mkLFLetNoEscape = LFLetNoEscape
236
237 -------------
238 mkLFReEntrant :: TopLevelFlag   -- True of top level
239               -> [Id]           -- Free vars
240               -> [Id]           -- Args
241               -> ArgDescr       -- Argument descriptor
242               -> LambdaFormInfo
243
244 mkLFReEntrant top fvs args arg_descr 
245   = LFReEntrant top (length args) (null fvs) arg_descr
246
247 -------------
248 mkLFThunk :: Type -> TopLevelFlag -> [Id] -> UpdateFlag -> LambdaFormInfo
249 mkLFThunk thunk_ty top fvs upd_flag
250   = ASSERT( not (isUpdatable upd_flag) || not (isUnLiftedType thunk_ty) )
251     LFThunk top (null fvs) 
252             (isUpdatable upd_flag)
253             NonStandardThunk 
254             (might_be_a_function thunk_ty)
255
256 --------------
257 might_be_a_function :: Type -> Bool
258 -- Return False only if we are *sure* it's a data type
259 -- Look through newtypes etc as much as poss
260 might_be_a_function ty
261   = case splitTyConApp_maybe (repType ty) of
262         Just (tc, _) -> not (isDataTyCon tc)
263         Nothing      -> True
264
265 -------------
266 mkConLFInfo :: DataCon -> LambdaFormInfo
267 mkConLFInfo con = LFCon con
268
269 -------------
270 mkSelectorLFInfo :: Id -> Int -> Bool -> LambdaFormInfo
271 mkSelectorLFInfo id offset updatable
272   = LFThunk NotTopLevel False updatable (SelectorThunk offset) 
273         (might_be_a_function (idType id))
274
275 -------------
276 mkApLFInfo :: Id -> UpdateFlag -> Arity -> LambdaFormInfo
277 mkApLFInfo id upd_flag arity
278   = LFThunk NotTopLevel (arity == 0) (isUpdatable upd_flag) (ApThunk arity)
279         (might_be_a_function (idType id))
280
281 -------------
282 mkLFImported :: Id -> LambdaFormInfo
283 mkLFImported id
284   | Just con <- isDataConWorkId_maybe id
285   , isNullaryRepDataCon con
286   = LFCon con   -- An imported nullary constructor
287                 -- We assume that the constructor is evaluated so that
288                 -- the id really does point directly to the constructor
289
290   | arity > 0
291   = LFReEntrant TopLevel arity True (panic "arg_descr")
292
293   | otherwise
294   = mkLFArgument id -- Not sure of exact arity
295   where
296     arity = idArity id
297
298 -----------------------------------------------------
299 --              Dynamic pointer tagging
300 -----------------------------------------------------
301
302 type ConTagZ = Int      -- A *zero-indexed* contructor tag
303
304 type DynTag = Int       -- The tag on a *pointer*
305                         -- (from the dynamic-tagging paper)
306
307 {-      Note [Data constructor dynamic tags]
308         ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
309 The family size of a data type (the number of constructors)
310 can be either:
311     * small, if the family size < 2**tag_bits
312     * big, otherwise.
313
314 Small families can have the constructor tag in the tag bits.
315 Big families only use the tag value 1 to represent evaluatedness. -}
316
317 isSmallFamily :: Int -> Bool
318 isSmallFamily fam_size = fam_size <= mAX_PTR_TAG
319
320 -- We keep the *zero-indexed* tag in the srt_len field of the info
321 -- table of a data constructor.
322 dataConTagZ :: DataCon -> ConTagZ
323 dataConTagZ con = dataConTag con - fIRST_TAG
324
325 tagForCon :: DataCon -> DynTag
326 tagForCon con 
327   | isSmallFamily fam_size = con_tag + 1
328   | otherwise              = 1
329   where
330     con_tag  = dataConTagZ con
331     fam_size = tyConFamilySize (dataConTyCon con)
332
333 tagForArity :: Int -> DynTag
334 tagForArity arity | isSmallFamily arity = arity
335                   | otherwise           = 0
336
337 lfDynTag :: LambdaFormInfo -> DynTag
338 -- Return the tag in the low order bits of a variable bound
339 -- to this LambdaForm
340 lfDynTag (LFCon con)               = tagForCon con
341 lfDynTag (LFReEntrant _ arity _ _) = tagForArity arity
342 lfDynTag _other                    = 0
343
344
345 -----------------------------------------------------------------------------
346 --              Observing LambdaFormInfo
347 -----------------------------------------------------------------------------
348
349 -------------
350 maybeIsLFCon :: LambdaFormInfo -> Maybe DataCon
351 maybeIsLFCon (LFCon con) = Just con
352 maybeIsLFCon _ = Nothing
353
354 ------------
355 isLFThunk :: LambdaFormInfo -> Bool
356 isLFThunk (LFThunk _ _ _ _ _)  = True
357 isLFThunk (LFBlackHole _)      = True
358         -- return True for a blackhole: this function is used to determine
359         -- whether to use the thunk header in SMP mode, and a blackhole
360         -- must have one.
361 isLFThunk _ = False
362
363
364 -----------------------------------------------------------------------------
365 --              Choosing SM reps
366 -----------------------------------------------------------------------------
367
368 chooseSMRep
369         :: Bool                 -- True <=> static closure
370         -> LambdaFormInfo
371         -> WordOff -> WordOff   -- Tot wds, ptr wds
372         -> SMRep
373
374 chooseSMRep is_static lf_info tot_wds ptr_wds
375   = let
376          nonptr_wds   = tot_wds - ptr_wds
377          closure_type = getClosureType is_static ptr_wds lf_info
378     in
379     GenericRep is_static ptr_wds nonptr_wds closure_type        
380
381 -- We *do* get non-updatable top-level thunks sometimes.  eg. f = g
382 -- gets compiled to a jump to g (if g has non-zero arity), instead of
383 -- messing around with update frames and PAPs.  We set the closure type
384 -- to FUN_STATIC in this case.
385
386 getClosureType :: Bool -> WordOff -> LambdaFormInfo -> ClosureType
387 getClosureType is_static ptr_wds lf_info
388   = case lf_info of
389         LFCon {} | is_static && ptr_wds == 0 -> ConstrNoCaf
390                  | otherwise                 -> Constr
391         LFReEntrant {}                       -> Fun
392         LFThunk _ _ _ (SelectorThunk {}) _   -> ThunkSelector
393         LFThunk {}                           -> Thunk
394         _ -> panic "getClosureType"
395
396
397 -----------------------------------------------------------------------------
398 --              nodeMustPointToIt
399 -----------------------------------------------------------------------------
400
401 -- Be sure to see the stg-details notes about these...
402
403 nodeMustPointToIt :: LambdaFormInfo -> Bool
404 nodeMustPointToIt (LFReEntrant top _ no_fvs _)
405   = not no_fvs ||   -- Certainly if it has fvs we need to point to it
406     isNotTopLevel top
407                     -- If it is not top level we will point to it
408                     --   We can have a \r closure with no_fvs which
409                     --   is not top level as special case cgRhsClosure
410                     --   has been dissabled in favour of let floating
411
412                 -- For lex_profiling we also access the cost centre for a
413                 -- non-inherited function i.e. not top level
414                 -- the  not top  case above ensures this is ok.
415
416 nodeMustPointToIt (LFCon _) = True
417
418         -- Strictly speaking, the above two don't need Node to point
419         -- to it if the arity = 0.  But this is a *really* unlikely
420         -- situation.  If we know it's nil (say) and we are entering
421         -- it. Eg: let x = [] in x then we will certainly have inlined
422         -- x, since nil is a simple atom.  So we gain little by not
423         -- having Node point to known zero-arity things.  On the other
424         -- hand, we do lose something; Patrick's code for figuring out
425         -- when something has been updated but not entered relies on
426         -- having Node point to the result of an update.  SLPJ
427         -- 27/11/92.
428
429 nodeMustPointToIt (LFThunk _ no_fvs updatable NonStandardThunk _)
430   = updatable || not no_fvs || opt_SccProfilingOn
431           -- For the non-updatable (single-entry case):
432           --
433           -- True if has fvs (in which case we need access to them, and we
434           --                should black-hole it)
435           -- or profiling (in which case we need to recover the cost centre
436           --             from inside it)
437
438 nodeMustPointToIt (LFThunk {})  -- Node must point to a standard-form thunk
439   = True 
440
441 nodeMustPointToIt (LFUnknown _)   = True
442 nodeMustPointToIt LFUnLifted      = False
443 nodeMustPointToIt (LFBlackHole _) = True    -- BH entry may require Node to point
444 nodeMustPointToIt LFLetNoEscape   = False 
445
446 -----------------------------------------------------------------------------
447 --              getCallMethod
448 -----------------------------------------------------------------------------
449
450 {- The entry conventions depend on the type of closure being entered,
451 whether or not it has free variables, and whether we're running
452 sequentially or in parallel.
453
454 Closure                               Node   Argument   Enter
455 Characteristics                 Par   Req'd  Passing    Via
456 -------------------------------------------------------------------------------
457 Unknown                         & no & yes & stack      & node
458 Known fun (>1 arg), no fvs      & no & no  & registers  & fast entry (enough args)
459                                                         & slow entry (otherwise)
460 Known fun (>1 arg), fvs         & no & yes & registers  & fast entry (enough args)
461 0 arg, no fvs \r,\s             & no & no  & n/a        & direct entry
462 0 arg, no fvs \u                & no & yes & n/a        & node
463 0 arg, fvs \r,\s                & no & yes & n/a        & direct entry
464 0 arg, fvs \u                   & no & yes & n/a        & node
465
466 Unknown                         & yes & yes & stack     & node
467 Known fun (>1 arg), no fvs      & yes & no  & registers & fast entry (enough args)
468                                                         & slow entry (otherwise)
469 Known fun (>1 arg), fvs         & yes & yes & registers & node
470 0 arg, no fvs \r,\s             & yes & no  & n/a       & direct entry 
471 0 arg, no fvs \u                & yes & yes & n/a       & node
472 0 arg, fvs \r,\s                & yes & yes & n/a       & node
473 0 arg, fvs \u                   & yes & yes & n/a       & node
474 \end{tabular}
475
476 When black-holing, single-entry closures could also be entered via node
477 (rather than directly) to catch double-entry. -}
478
479 data CallMethod
480   = EnterIt             -- No args, not a function
481
482   | JumpToIt            -- A join point 
483
484   | ReturnIt            -- It's a value (function, unboxed value,
485                         -- or constructor), so just return it.
486
487   | SlowCall            -- Unknown fun, or known fun with
488                         -- too few args.
489
490   | DirectEntry         -- Jump directly, with args in regs
491         CLabel          --   The code label
492         Int             --   Its arity
493
494 getCallMethod :: DynFlags
495               -> Name           -- Function being applied
496               -> CafInfo        -- Can it refer to CAF's?
497               -> LambdaFormInfo -- Its info
498               -> Int            -- Number of available arguments
499               -> CallMethod
500
501 getCallMethod _ _name _ lf_info _n_args
502   | nodeMustPointToIt lf_info && opt_Parallel
503   =     -- If we're parallel, then we must always enter via node.  
504         -- The reason is that the closure may have been         
505         -- fetched since we allocated it.
506     EnterIt
507
508 getCallMethod _ name caf (LFReEntrant _ arity _ _) n_args
509   | n_args == 0    = ASSERT( arity /= 0 )
510                      ReturnIt   -- No args at all
511   | n_args < arity = SlowCall   -- Not enough args
512   | otherwise      = DirectEntry (enterIdLabel name caf) arity
513
514 getCallMethod _ _name _ LFUnLifted n_args
515   = ASSERT( n_args == 0 ) ReturnIt
516
517 getCallMethod _ _name _ (LFCon _) n_args
518   = ASSERT( n_args == 0 ) ReturnIt
519
520 getCallMethod dflags name caf (LFThunk _ _ updatable std_form_info is_fun) n_args
521   | is_fun      -- it *might* be a function, so we must "call" it (which is always safe)
522   = SlowCall    -- We cannot just enter it [in eval/apply, the entry code
523                 -- is the fast-entry code]
524
525   -- Since is_fun is False, we are *definitely* looking at a data value
526   | updatable || doingTickyProfiling dflags -- to catch double entry
527       {- OLD: || opt_SMP
528          I decided to remove this, because in SMP mode it doesn't matter
529          if we enter the same thunk multiple times, so the optimisation
530          of jumping directly to the entry code is still valid.  --SDM
531         -}
532   = EnterIt
533     -- We used to have ASSERT( n_args == 0 ), but actually it is
534     -- possible for the optimiser to generate
535     --   let bot :: Int = error Int "urk"
536     --   in (bot `cast` unsafeCoerce Int (Int -> Int)) 3
537     -- This happens as a result of the case-of-error transformation
538     -- So the right thing to do is just to enter the thing
539
540   | otherwise   -- Jump direct to code for single-entry thunks
541   = ASSERT( n_args == 0 )
542     DirectEntry (thunkEntryLabel name caf std_form_info updatable) 0
543
544 getCallMethod _ _name _ (LFUnknown True) _n_args
545   = SlowCall -- might be a function
546
547 getCallMethod _ name _ (LFUnknown False) n_args
548   = ASSERT2 ( n_args == 0, ppr name <+> ppr n_args ) 
549     EnterIt -- Not a function
550
551 getCallMethod _ _name _ (LFBlackHole _) _n_args
552   = SlowCall    -- Presumably the black hole has by now
553                 -- been updated, but we don't know with
554                 -- what, so we slow call it
555
556 getCallMethod _ _name _ LFLetNoEscape _n_args
557   = JumpToIt
558
559 isStandardFormThunk :: LambdaFormInfo -> Bool
560 isStandardFormThunk (LFThunk _ _ _ (SelectorThunk _) _) = True
561 isStandardFormThunk (LFThunk _ _ _ (ApThunk _) _)       = True
562 isStandardFormThunk _other_lf_info                      = False
563
564 isKnownFun :: LambdaFormInfo -> Bool
565 isKnownFun (LFReEntrant _ _ _ _) = True
566 isKnownFun LFLetNoEscape         = True
567 isKnownFun _ = False
568
569 -----------------------------------------------------------------------------
570 --              staticClosureRequired
571 -----------------------------------------------------------------------------
572
573 {-  staticClosureRequired is never called (hence commented out)
574
575     SimonMar writes (Sept 07) It's an optimisation we used to apply at
576     one time, I believe, but it got lost probably in the rewrite of
577     the RTS/code generator.  I left that code there to remind me to
578     look into whether it was worth doing sometime
579
580 {- Avoiding generating entries and info tables
581    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
582 At present, for every function we generate all of the following,
583 just in case.  But they aren't always all needed, as noted below:
584
585 [NB1: all of this applies only to *functions*.  Thunks always
586 have closure, info table, and entry code.]
587
588 [NB2: All are needed if the function is *exported*, just to play safe.]
589
590 * Fast-entry code  ALWAYS NEEDED
591
592 * Slow-entry code
593         Needed iff (a) we have any un-saturated calls to the function
594         OR         (b) the function is passed as an arg
595         OR         (c) we're in the parallel world and the function has free vars
596                         [Reason: in parallel world, we always enter functions
597                         with free vars via the closure.]
598
599 * The function closure
600         Needed iff (a) we have any un-saturated calls to the function
601         OR         (b) the function is passed as an arg
602         OR         (c) if the function has free vars (ie not top level)
603
604   Why case (a) here?  Because if the arg-satis check fails,
605   UpdatePAP stuffs a pointer to the function closure in the PAP.
606   [Could be changed; UpdatePAP could stuff in a code ptr instead,
607    but doesn't seem worth it.]
608
609   [NB: these conditions imply that we might need the closure
610   without the slow-entry code.  Here's how.
611
612         f x y = let g w = ...x..y..w...
613                 in
614                 ...(g t)...
615
616   Here we need a closure for g which contains x and y,
617   but since the calls are all saturated we just jump to the
618   fast entry point for g, with R1 pointing to the closure for g.]
619
620
621 * Standard info table
622         Needed iff (a) we have any un-saturated calls to the function
623         OR         (b) the function is passed as an arg
624         OR         (c) the function has free vars (ie not top level)
625
626         NB.  In the sequential world, (c) is only required so that the function closure has
627         an info table to point to, to keep the storage manager happy.
628         If (c) alone is true we could fake up an info table by choosing
629         one of a standard family of info tables, whose entry code just
630         bombs out.
631
632         [NB In the parallel world (c) is needed regardless because
633         we enter functions with free vars via the closure.]
634
635         If (c) is retained, then we'll sometimes generate an info table
636         (for storage mgr purposes) without slow-entry code.  Then we need
637         to use an error label in the info table to substitute for the absent
638         slow entry code.
639 -}
640
641 staticClosureRequired
642         :: Name
643         -> StgBinderInfo
644         -> LambdaFormInfo
645         -> Bool
646 staticClosureRequired binder bndr_info
647                       (LFReEntrant top_level _ _ _)     -- It's a function
648   = ASSERT( isTopLevel top_level )
649         -- Assumption: it's a top-level, no-free-var binding
650         not (satCallsOnly bndr_info)
651
652 staticClosureRequired binder other_binder_info other_lf_info = True
653 -}
654
655 -----------------------------------------------------------------------------
656 --              Data types for closure information}
657 -----------------------------------------------------------------------------
658
659
660 {- Information about a closure, from the code generator's point of view.
661
662 A ClosureInfo decribes the info pointer of a closure.  It has
663 enough information 
664   a) to construct the info table itself
665   b) to allocate a closure containing that info pointer (i.e.
666         it knows the info table label)
667
668 We make a ClosureInfo for
669   - each let binding (both top level and not)
670   - each data constructor (for its shared static and
671         dynamic info tables)
672 -}
673
674 data ClosureInfo
675   = ClosureInfo {
676         closureName   :: !Name,           -- The thing bound to this closure
677         closureLFInfo :: !LambdaFormInfo, -- NOTE: not an LFCon (see below)
678         closureSMRep  :: !SMRep,          -- representation used by storage mgr
679         closureSRT    :: !C_SRT,          -- What SRT applies to this closure
680         closureType   :: !Type,           -- Type of closure (ToDo: remove)
681         closureDescr  :: !String,         -- closure description (for profiling)
682         closureCafs   :: !CafInfo         -- whether the closure may have CAFs
683     }
684
685   -- Constructor closures don't have a unique info table label (they use
686   -- the constructor's info table), and they don't have an SRT.
687   | ConInfo {
688         closureCon       :: !DataCon,
689         closureSMRep     :: !SMRep
690     }
691
692 {-      XXX temp imported from old ClosureInfo 
693 -- C_SRT is what StgSyn.SRT gets translated to... 
694 -- we add a label for the table, and expect only the 'offset/length' form
695
696 data C_SRT = NoC_SRT
697            | C_SRT !CLabel !WordOff !StgHalfWord {-bitmap or escape-}
698            deriving (Eq)
699
700 instance Outputable C_SRT where
701   ppr (NoC_SRT) = ptext SLIT("_no_srt_")
702   ppr (C_SRT label off bitmap) = parens (ppr label <> comma <> ppr off <> comma <> text (show bitmap))
703 -}
704
705 needsSRT :: C_SRT -> Bool
706 needsSRT NoC_SRT       = False
707 needsSRT (C_SRT _ _ _) = True
708
709
710 --------------------------------------
711 --      Building ClosureInfos
712 --------------------------------------
713
714 mkClosureInfo :: Bool           -- Is static
715               -> Id
716               -> LambdaFormInfo 
717               -> Int -> Int     -- Total and pointer words
718               -> C_SRT
719               -> String         -- String descriptor
720               -> ClosureInfo
721 mkClosureInfo is_static id lf_info tot_wds ptr_wds srt_info descr
722   = ClosureInfo { closureName = name, 
723                   closureLFInfo = lf_info,
724                   closureSMRep = sm_rep, 
725                   closureSRT = srt_info,
726                   closureType = idType id,
727                   closureDescr = descr,
728                   closureCafs = idCafInfo id }
729   where
730     name   = idName id
731     sm_rep = chooseSMRep is_static lf_info tot_wds ptr_wds
732
733 mkConInfo :: Bool       -- Is static
734           -> DataCon    
735           -> Int -> Int -- Total and pointer words
736           -> ClosureInfo
737 mkConInfo is_static data_con tot_wds ptr_wds
738    = ConInfo {  closureSMRep = sm_rep,
739                 closureCon = data_con }
740   where
741     sm_rep = chooseSMRep is_static (mkConLFInfo data_con) tot_wds ptr_wds
742
743
744 -- We need a black-hole closure info to pass to @allocDynClosure@ when we
745 -- want to allocate the black hole on entry to a CAF.  These are the only
746 -- ways to build an LFBlackHole, maintaining the invariant that it really
747 -- is a black hole and not something else.
748
749 cafBlackHoleClosureInfo :: ClosureInfo -> ClosureInfo
750 cafBlackHoleClosureInfo (ClosureInfo { closureName = nm,
751                                        closureType = ty,
752                                        closureCafs = cafs })
753   = ClosureInfo { closureName   = nm,
754                   closureLFInfo = LFBlackHole mkCAFBlackHoleInfoTableLabel,
755                   closureSMRep  = BlackHoleRep,
756                   closureSRT    = NoC_SRT,
757                   closureType   = ty,
758                   closureDescr  = "", 
759                   closureCafs   = cafs }
760 cafBlackHoleClosureInfo _ = panic "cafBlackHoleClosureInfo"
761
762
763 --------------------------------------
764 --   Extracting ClosureTypeInfo
765 --------------------------------------
766
767 -- JD: I've added the continuation arguments not for fun but because
768 -- I don't want to pipe the monad in here (circular module dependencies),
769 -- and I don't want to pull this code out of this module, which would
770 -- require us to expose a bunch of abstract types.
771
772 closureTypeInfo ::
773   ClosureInfo -> ((ConstrDescription -> ClosureTypeInfo) -> DataCon -> CLabel -> a) ->
774   (ClosureTypeInfo -> a) -> a
775 closureTypeInfo cl_info k_with_con_name k_simple
776    = case cl_info of
777         ConInfo { closureCon = con } 
778                 -> k_with_con_name (ConstrInfo (ptrs, nptrs)
779                                       (fromIntegral (dataConTagZ con))) con info_lbl
780                 where
781                   --con_name = panic "closureTypeInfo"
782                         -- Was: 
783                         -- cstr <- mkByteStringCLit $ dataConIdentity con
784                         -- con_name = makeRelativeRefTo info_lbl cstr
785
786         ClosureInfo { closureName   = name,
787                       closureLFInfo = LFReEntrant _ arity _ arg_descr,
788                       closureSRT    = srt }
789                 -> k_simple $ FunInfo (ptrs, nptrs)
790                                 srt 
791                                 (fromIntegral arity)
792                                 arg_descr 
793                                 (CmmLabel (mkSlowEntryLabel name (clHasCafRefs cl_info)))
794   
795         ClosureInfo { closureLFInfo = LFThunk _ _ _ (SelectorThunk offset) _, 
796                       closureSRT    = srt }
797                 -> k_simple $ ThunkSelectorInfo (fromIntegral offset) srt
798
799         ClosureInfo { closureLFInfo = LFThunk {}, 
800                       closureSRT    = srt }
801                 -> k_simple $ ThunkInfo (ptrs, nptrs) srt
802
803         _ -> panic "unexpected lambda form in mkCmmInfo"
804   where
805     info_lbl = infoTableLabelFromCI cl_info
806     ptrs     = fromIntegral $ closurePtrsSize cl_info
807     size     = fromIntegral $ closureNonHdrSize cl_info
808     nptrs    = size - ptrs
809
810 --------------------------------------
811 --   Functions about closure *sizes*
812 --------------------------------------
813
814 closureSize :: ClosureInfo -> WordOff
815 closureSize cl_info = hdr_size + closureNonHdrSize cl_info
816   where hdr_size  | closureIsThunk cl_info = thunkHdrSize
817                   | otherwise              = fixedHdrSize
818         -- All thunks use thunkHdrSize, even if they are non-updatable.
819         -- this is because we don't have separate closure types for
820         -- updatable vs. non-updatable thunks, so the GC can't tell the
821         -- difference.  If we ever have significant numbers of non-
822         -- updatable thunks, it might be worth fixing this.
823
824 closureNonHdrSize :: ClosureInfo -> WordOff
825 closureNonHdrSize cl_info
826   = tot_wds + computeSlopSize tot_wds cl_info
827   where
828     tot_wds = closureGoodStuffSize cl_info
829
830 closureGoodStuffSize :: ClosureInfo -> WordOff
831 closureGoodStuffSize cl_info
832   = let (ptrs, nonptrs) = sizes_from_SMRep (closureSMRep cl_info)
833     in  ptrs + nonptrs
834
835 closurePtrsSize :: ClosureInfo -> WordOff
836 closurePtrsSize cl_info
837   = let (ptrs, _) = sizes_from_SMRep (closureSMRep cl_info)
838     in  ptrs
839
840 -- not exported:
841 sizes_from_SMRep :: SMRep -> (WordOff,WordOff)
842 sizes_from_SMRep (GenericRep _ ptrs nonptrs _)   = (ptrs, nonptrs)
843 sizes_from_SMRep BlackHoleRep                    = (0, 0)
844
845 -- Computing slop size.  WARNING: this looks dodgy --- it has deep
846 -- knowledge of what the storage manager does with the various
847 -- representations...
848 --
849 -- Slop Requirements: every thunk gets an extra padding word in the
850 -- header, which takes the the updated value.
851
852 slopSize :: ClosureInfo -> WordOff
853 slopSize cl_info = computeSlopSize payload_size cl_info
854   where payload_size = closureGoodStuffSize cl_info
855
856 computeSlopSize :: WordOff -> ClosureInfo -> WordOff
857 computeSlopSize payload_size cl_info
858   = max 0 (minPayloadSize smrep updatable - payload_size)
859   where
860         smrep        = closureSMRep cl_info
861         updatable    = closureNeedsUpdSpace cl_info
862
863 closureNeedsUpdSpace :: ClosureInfo -> Bool
864 -- We leave space for an update if either (a) the closure is updatable
865 -- or (b) it is a static thunk.  This is because a static thunk needs
866 -- a static link field in a predictable place (after the slop), regardless
867 -- of whether it is updatable or not.
868 closureNeedsUpdSpace (ClosureInfo { closureLFInfo = 
869                                         LFThunk TopLevel _ _ _ _ }) = True
870 closureNeedsUpdSpace cl_info = closureUpdReqd cl_info
871
872 minPayloadSize :: SMRep -> Bool -> WordOff
873 minPayloadSize smrep updatable
874   = case smrep of
875         BlackHoleRep                            -> min_upd_size
876         GenericRep _ _ _ _      | updatable     -> min_upd_size
877         GenericRep True _ _ _                   -> 0 -- static
878         GenericRep False _ _ _                  -> mIN_PAYLOAD_SIZE
879           --       ^^^^^___ dynamic
880   where
881    min_upd_size =
882         ASSERT(mIN_PAYLOAD_SIZE <= sIZEOF_StgSMPThunkHeader)
883         0       -- check that we already have enough
884                 -- room for mIN_SIZE_NonUpdHeapObject,
885                 -- due to the extra header word in SMP
886
887 --------------------------------------
888 --   Other functions over ClosureInfo
889 --------------------------------------
890
891 blackHoleOnEntry :: DynFlags -> ClosureInfo -> Bool
892 -- Static closures are never themselves black-holed.
893 -- Updatable ones will be overwritten with a CAFList cell, which points to a 
894 -- black hole;
895 -- Single-entry ones have no fvs to plug, and we trust they don't form part 
896 -- of a loop.
897
898 blackHoleOnEntry _ ConInfo{} = False
899 blackHoleOnEntry dflags (ClosureInfo { closureLFInfo = lf_info, closureSMRep = rep })
900   | isStaticRep rep
901   = False       -- Never black-hole a static closure
902
903   | otherwise
904   = case lf_info of
905         LFReEntrant _ _ _ _       -> False
906         LFLetNoEscape             -> False
907         LFThunk _ no_fvs updatable _ _
908           -> if updatable
909              then not opt_OmitBlackHoling
910              else doingTickyProfiling dflags || not no_fvs
911                   -- the former to catch double entry,
912                   -- and the latter to plug space-leaks.  KSW/SDM 1999-04.
913
914         _other -> panic "blackHoleOnEntry"      -- Should never happen
915
916
917 staticClosureNeedsLink :: ClosureInfo -> Bool
918 -- A static closure needs a link field to aid the GC when traversing
919 -- the static closure graph.  But it only needs such a field if either
920 --      a) it has an SRT
921 --      b) it's a constructor with one or more pointer fields
922 -- In case (b), the constructor's fields themselves play the role
923 -- of the SRT.
924 staticClosureNeedsLink (ClosureInfo { closureSRT = srt })
925   = needsSRT srt
926 staticClosureNeedsLink (ConInfo { closureSMRep = sm_rep, closureCon = con })
927   = not (isNullaryRepDataCon con) && not_nocaf_constr
928   where
929     not_nocaf_constr = 
930         case sm_rep of 
931            GenericRep _ _ _ ConstrNoCaf -> False
932            _other                       -> True
933
934 isStaticClosure :: ClosureInfo -> Bool
935 isStaticClosure cl_info = isStaticRep (closureSMRep cl_info)
936
937 closureUpdReqd :: ClosureInfo -> Bool
938 closureUpdReqd ClosureInfo{ closureLFInfo = lf_info } = lfUpdatable lf_info
939 closureUpdReqd ConInfo{} = False
940
941 lfUpdatable :: LambdaFormInfo -> Bool
942 lfUpdatable (LFThunk _ _ upd _ _)  = upd
943 lfUpdatable (LFBlackHole _)        = True
944         -- Black-hole closures are allocated to receive the results of an
945         -- alg case with a named default... so they need to be updated.
946 lfUpdatable _ = False
947
948 closureIsThunk :: ClosureInfo -> Bool
949 closureIsThunk ClosureInfo{ closureLFInfo = lf_info } = isLFThunk lf_info
950 closureIsThunk ConInfo{} = False
951
952 closureSingleEntry :: ClosureInfo -> Bool
953 closureSingleEntry (ClosureInfo { closureLFInfo = LFThunk _ _ upd _ _}) = not upd
954 closureSingleEntry _ = False
955
956 closureReEntrant :: ClosureInfo -> Bool
957 closureReEntrant (ClosureInfo { closureLFInfo = LFReEntrant _ _ _ _ }) = True
958 closureReEntrant _ = False
959
960 isConstrClosure_maybe :: ClosureInfo -> Maybe DataCon
961 isConstrClosure_maybe (ConInfo { closureCon = data_con }) = Just data_con
962 isConstrClosure_maybe _                                   = Nothing
963
964 closureFunInfo :: ClosureInfo -> Maybe (Int, ArgDescr)
965 closureFunInfo (ClosureInfo { closureLFInfo = lf_info }) = lfFunInfo lf_info
966 closureFunInfo _ = Nothing
967
968 lfFunInfo :: LambdaFormInfo ->  Maybe (Int, ArgDescr)
969 lfFunInfo (LFReEntrant _ arity _ arg_desc)  = Just (arity, arg_desc)
970 lfFunInfo _                                 = Nothing
971
972 funTag :: ClosureInfo -> DynTag
973 funTag (ClosureInfo { closureLFInfo = lf_info }) = lfDynTag lf_info
974 funTag (ConInfo {})                              = panic "funTag"
975
976 isToplevClosure :: ClosureInfo -> Bool
977 isToplevClosure (ClosureInfo { closureLFInfo = lf_info })
978   = case lf_info of
979       LFReEntrant TopLevel _ _ _ -> True
980       LFThunk TopLevel _ _ _ _   -> True
981       _other                     -> False
982 isToplevClosure _ = False
983
984 --------------------------------------
985 --   Label generation
986 --------------------------------------
987
988 infoTableLabelFromCI :: ClosureInfo -> CLabel
989 infoTableLabelFromCI cl@(ClosureInfo { closureName = name,
990                                        closureLFInfo = lf_info })
991   = case lf_info of
992         LFBlackHole info -> info
993
994         LFThunk _ _ upd_flag (SelectorThunk offset) _ -> 
995                 mkSelectorInfoLabel upd_flag offset
996
997         LFThunk _ _ upd_flag (ApThunk arity) _ -> 
998                 mkApInfoTableLabel upd_flag arity
999
1000         LFThunk{}      -> mkLocalInfoTableLabel name $ clHasCafRefs cl
1001
1002         LFReEntrant _ _ _ _ -> mkLocalInfoTableLabel name $ clHasCafRefs cl
1003
1004         _other -> panic "infoTableLabelFromCI"
1005
1006 infoTableLabelFromCI cl@(ConInfo { closureCon = con, closureSMRep = rep })
1007   | isStaticRep rep = mkStaticInfoTableLabel  name $ clHasCafRefs cl
1008   | otherwise       = mkConInfoTableLabel     name $ clHasCafRefs cl
1009   where
1010     name = dataConName con
1011
1012 -- ClosureInfo for a closure (as opposed to a constructor) is always local
1013 closureLabelFromCI :: ClosureInfo -> CLabel
1014 closureLabelFromCI cl@(ClosureInfo { closureName = nm }) =
1015   mkLocalClosureLabel nm $ clHasCafRefs cl
1016 closureLabelFromCI _ = panic "closureLabelFromCI"
1017
1018 thunkEntryLabel :: Name -> CafInfo -> StandardFormInfo -> Bool -> CLabel
1019 -- thunkEntryLabel is a local help function, not exported.  It's used from both
1020 -- entryLabelFromCI and getCallMethod.
1021 thunkEntryLabel _thunk_id _ (ApThunk arity) upd_flag
1022   = enterApLabel upd_flag arity
1023 thunkEntryLabel _thunk_id _ (SelectorThunk offset) upd_flag
1024   = enterSelectorLabel upd_flag offset
1025 thunkEntryLabel thunk_id c _ _
1026   = enterIdLabel thunk_id c
1027
1028 enterApLabel :: Bool -> Arity -> CLabel
1029 enterApLabel is_updatable arity
1030   | tablesNextToCode = mkApInfoTableLabel is_updatable arity
1031   | otherwise        = mkApEntryLabel is_updatable arity
1032
1033 enterSelectorLabel :: Bool -> WordOff -> CLabel
1034 enterSelectorLabel upd_flag offset
1035   | tablesNextToCode = mkSelectorInfoLabel upd_flag offset
1036   | otherwise        = mkSelectorEntryLabel upd_flag offset
1037
1038 enterIdLabel :: Name -> CafInfo -> CLabel
1039 enterIdLabel id c
1040   | tablesNextToCode = mkInfoTableLabel id c
1041   | otherwise        = mkEntryLabel id c
1042
1043 enterLocalIdLabel :: Name -> CafInfo -> CLabel
1044 enterLocalIdLabel id c
1045   | tablesNextToCode = mkLocalInfoTableLabel id c
1046   | otherwise        = mkLocalEntryLabel id c
1047
1048
1049 --------------------------------------
1050 --   Profiling
1051 --------------------------------------
1052
1053 -- Profiling requires two pieces of information to be determined for
1054 -- each closure's info table --- description and type.
1055
1056 -- The description is stored directly in the @CClosureInfoTable@ when the
1057 -- info table is built.
1058
1059 -- The type is determined from the type information stored with the @Id@
1060 -- in the closure info using @closureTypeDescr@.
1061
1062 closureValDescr, closureTypeDescr :: ClosureInfo -> String
1063 closureValDescr (ClosureInfo {closureDescr = descr}) 
1064   = descr
1065 closureValDescr (ConInfo {closureCon = con})
1066   = occNameString (getOccName con)
1067
1068 closureTypeDescr (ClosureInfo { closureType = ty })
1069   = getTyDescription ty
1070 closureTypeDescr (ConInfo { closureCon = data_con })
1071   = occNameString (getOccName (dataConTyCon data_con))
1072
1073 getTyDescription :: Type -> String
1074 getTyDescription ty
1075   = case (tcSplitSigmaTy ty) of { (_, _, tau_ty) ->
1076     case tau_ty of
1077       TyVarTy _              -> "*"
1078       AppTy fun _            -> getTyDescription fun
1079       FunTy _ res            -> '-' : '>' : fun_result res
1080       TyConApp tycon _       -> getOccString tycon
1081       PredTy sty             -> getPredTyDescription sty
1082       ForAllTy _ ty          -> getTyDescription ty
1083     }
1084   where
1085     fun_result (FunTy _ res) = '>' : fun_result res
1086     fun_result other         = getTyDescription other
1087
1088 getPredTyDescription :: PredType -> String
1089 getPredTyDescription (ClassP cl _)     = getOccString cl
1090 getPredTyDescription (IParam ip _)     = getOccString (ipNameName ip)
1091 getPredTyDescription (EqPred ty1 _ty2) = getTyDescription ty1   -- Urk?
1092
1093
1094 --------------------------------------
1095 --   SRTs/CAFs
1096 --------------------------------------
1097
1098 -- We need to know whether a closure may have CAFs.
1099 clHasCafRefs :: ClosureInfo -> CafInfo
1100 clHasCafRefs (ClosureInfo {closureCafs = cafs}) = cafs
1101 clHasCafRefs (ConInfo {}) = NoCafRefs