fix the eager-blackholing check, which I inadvertently broke in
[ghc.git] / compiler / codeGen / ClosureInfo.lhs
1 %
2 % (c) The University of Glasgow 2006
3 % (c) The Univserity of Glasgow 1992-2004
4 %
5
6         Data structures which describe closures, and
7         operations over those data structures
8
9                 Nothing monadic in here
10
11 Much of the rationale for these things is in the ``details'' part of
12 the STG paper.
13
14 \begin{code}
15 module ClosureInfo (
16         ClosureInfo(..), LambdaFormInfo(..),    -- would be abstract but
17         StandardFormInfo(..),                   -- mkCmmInfo looks inside
18         SMRep,
19
20         ArgDescr(..), Liveness, 
21         C_SRT(..), needsSRT,
22
23         mkLFThunk, mkLFReEntrant, mkConLFInfo, mkSelectorLFInfo,
24         mkApLFInfo, mkLFImported, mkLFArgument, mkLFLetNoEscape,
25
26         mkClosureInfo, mkConInfo, maybeIsLFCon,
27         closureSize,
28
29         ConTagZ, dataConTagZ,
30
31         infoTableLabelFromCI, entryLabelFromCI,
32         closureLabelFromCI,
33         isLFThunk, closureUpdReqd,
34         closureNeedsUpdSpace, closureIsThunk,
35         closureSingleEntry, closureReEntrant, isConstrClosure_maybe,
36         closureFunInfo, isKnownFun,
37         funTag, funTagLFInfo, tagForArity, clHasCafRefs,
38
39         enterIdLabel, enterLocalIdLabel, enterReturnPtLabel,
40
41         nodeMustPointToIt, 
42         CallMethod(..), getCallMethod,
43
44         blackHoleOnEntry,
45
46         staticClosureRequired,
47
48         isToplevClosure,
49         closureValDescr, closureTypeDescr,      -- profiling
50
51         isStaticClosure,
52         cafBlackHoleClosureInfo,
53
54         staticClosureNeedsLink,
55
56         -- CgRep and its functions
57         CgRep(..), nonVoidArg,
58         argMachRep, primRepToCgRep, 
59         isFollowableArg, isVoidArg, 
60         isFloatingArg, is64BitArg,
61         separateByPtrFollowness,
62         cgRepSizeW, cgRepSizeB,
63         retAddrSizeW,
64         typeCgRep, idCgRep, tyConCgRep, 
65
66     ) where
67
68 #include "../includes/MachDeps.h"
69 #include "HsVersions.h"
70
71 import StgSyn
72 import SMRep
73
74 import CLabel
75 import Cmm
76 import Unique
77 import StaticFlags
78 import Var
79 import Id
80 import IdInfo
81 import DataCon
82 import Name
83 import Type
84 import TypeRep
85 import TcType
86 import TyCon
87 import BasicTypes
88 import Outputable
89 import FastString
90 import Constants
91 import DynFlags
92 \end{code}
93
94
95 %************************************************************************
96 %*                                                                      *
97 \subsection[ClosureInfo-datatypes]{Data types for closure information}
98 %*                                                                      *
99 %************************************************************************
100
101 Information about a closure, from the code generator's point of view.
102
103 A ClosureInfo decribes the info pointer of a closure.  It has
104 enough information 
105   a) to construct the info table itself
106   b) to allocate a closure containing that info pointer (i.e.
107         it knows the info table label)
108
109 We make a ClosureInfo for
110         - each let binding (both top level and not)
111         - each data constructor (for its shared static and
112                 dynamic info tables)
113
114 \begin{code}
115 data ClosureInfo
116   = ClosureInfo {
117         closureName   :: !Name,           -- The thing bound to this closure
118         closureLFInfo :: !LambdaFormInfo, -- NOTE: not an LFCon (see below)
119         closureSMRep  :: !SMRep,          -- representation used by storage mgr
120         closureSRT    :: !C_SRT,          -- What SRT applies to this closure
121         closureType   :: !Type,           -- Type of closure (ToDo: remove)
122         closureDescr  :: !String,         -- closure description (for profiling)
123         closureInfLcl :: Bool             -- can the info pointer be a local symbol?
124     }
125
126   -- Constructor closures don't have a unique info table label (they use
127   -- the constructor's info table), and they don't have an SRT.
128   | ConInfo {
129         closureCon       :: !DataCon,
130         closureSMRep     :: !SMRep
131     }
132 \end{code}
133
134 %************************************************************************
135 %*                                                                      *
136 \subsubsection[LambdaFormInfo-datatype]{@LambdaFormInfo@: source-derivable info}
137 %*                                                                      *
138 %************************************************************************
139
140 Information about an identifier, from the code generator's point of
141 view.  Every identifier is bound to a LambdaFormInfo in the
142 environment, which gives the code generator enough info to be able to
143 tail call or return that identifier.
144
145 Note that a closure is usually bound to an identifier, so a
146 ClosureInfo contains a LambdaFormInfo.
147
148 \begin{code}
149 data LambdaFormInfo
150   = LFReEntrant         -- Reentrant closure (a function)
151         TopLevelFlag    -- True if top level
152         !Int            -- Arity. Invariant: always > 0
153         !Bool           -- True <=> no fvs
154         ArgDescr        -- Argument descriptor (should reall be in ClosureInfo)
155
156   | LFCon               -- A saturated constructor application
157         DataCon         -- The constructor
158
159   | LFThunk             -- Thunk (zero arity)
160         TopLevelFlag
161         !Bool           -- True <=> no free vars
162         !Bool           -- True <=> updatable (i.e., *not* single-entry)
163         StandardFormInfo
164         !Bool           -- True <=> *might* be a function type
165
166   | LFUnknown           -- Used for function arguments and imported things.
167                         --  We know nothing about  this closure.  Treat like
168                         -- updatable "LFThunk"...
169                         -- Imported things which we do know something about use
170                         -- one of the other LF constructors (eg LFReEntrant for
171                         -- known functions)
172         !Bool           -- True <=> *might* be a function type
173
174   | LFLetNoEscape       -- See LetNoEscape module for precise description of
175                         -- these "lets".
176         !Int            -- arity;
177
178   | LFBlackHole         -- Used for the closures allocated to hold the result
179                         -- of a CAF.  We want the target of the update frame to
180                         -- be in the heap, so we make a black hole to hold it.
181
182
183
184 -------------------------
185 -- StandardFormInfo tells whether this thunk has one of 
186 -- a small number of standard forms
187
188 data StandardFormInfo
189   = NonStandardThunk
190         -- Not of of the standard forms
191
192   | SelectorThunk
193         -- A SelectorThunk is of form
194         --      case x of
195         --             con a1,..,an -> ak
196         -- and the constructor is from a single-constr type.
197        WordOff                  -- 0-origin offset of ak within the "goods" of 
198                         -- constructor (Recall that the a1,...,an may be laid
199                         -- out in the heap in a non-obvious order.)
200
201   | ApThunk 
202         -- An ApThunk is of form
203         --      x1 ... xn
204         -- The code for the thunk just pushes x2..xn on the stack and enters x1.
205         -- There are a few of these (for 1 <= n <= MAX_SPEC_AP_SIZE) pre-compiled
206         -- in the RTS to save space.
207         Int             -- Arity, n
208 \end{code}
209
210
211 %************************************************************************
212 %*                                                                      *
213                         CgRep
214 %*                                                                      *
215 %************************************************************************
216
217 An CgRep is an abstraction of a Type which tells the code generator
218 all it needs to know about the calling convention for arguments (and
219 results) of that type.  In particular, the ArgReps of a function's
220 arguments are used to decide which of the RTS's generic apply
221 functions to call when applying an unknown function.
222
223 It contains more information than the back-end data type MachRep,
224 so one can easily convert from CgRep -> MachRep.  (Except that
225 there's no MachRep for a VoidRep.)
226
227 It distinguishes 
228         pointers from non-pointers (we sort the pointers together
229         when building closures)
230
231         void from other types: a void argument is different from no argument
232
233 All 64-bit types map to the same CgRep, because they're passed in the
234 same register, but a PtrArg is still different from an NonPtrArg
235 because the function's entry convention has to take into account the
236 pointer-hood of arguments for the purposes of describing the stack on
237 entry to the garbage collector.
238
239 \begin{code}
240 data CgRep 
241   = VoidArg     -- Void
242   | PtrArg      -- Word-sized heap pointer, followed
243                 -- by the garbage collector
244   | NonPtrArg   -- Word-sized non-pointer
245                 -- (including addresses not followed by GC)
246   | LongArg     -- 64-bit non-pointer
247   | FloatArg    -- 32-bit float
248   | DoubleArg   -- 64-bit float
249   deriving Eq
250
251 instance Outputable CgRep where
252     ppr VoidArg   = ptext (sLit "V_")
253     ppr PtrArg    = ptext (sLit "P_")
254     ppr NonPtrArg = ptext (sLit "I_")
255     ppr LongArg   = ptext (sLit "L_")
256     ppr FloatArg  = ptext (sLit "F_")
257     ppr DoubleArg = ptext (sLit "D_")
258
259 argMachRep :: CgRep -> CmmType
260 argMachRep PtrArg    = gcWord
261 argMachRep NonPtrArg = bWord
262 argMachRep LongArg   = b64
263 argMachRep FloatArg  = f32
264 argMachRep DoubleArg = f64
265 argMachRep VoidArg   = panic "argMachRep:VoidRep"
266
267 primRepToCgRep :: PrimRep -> CgRep
268 primRepToCgRep VoidRep    = VoidArg
269 primRepToCgRep PtrRep     = PtrArg
270 primRepToCgRep IntRep     = NonPtrArg
271 primRepToCgRep WordRep    = NonPtrArg
272 primRepToCgRep Int64Rep   = LongArg
273 primRepToCgRep Word64Rep  = LongArg
274 primRepToCgRep AddrRep    = NonPtrArg
275 primRepToCgRep FloatRep   = FloatArg
276 primRepToCgRep DoubleRep  = DoubleArg
277
278 idCgRep :: Id -> CgRep
279 idCgRep x = typeCgRep . idType $ x
280
281 tyConCgRep :: TyCon -> CgRep
282 tyConCgRep = primRepToCgRep . tyConPrimRep
283
284 typeCgRep :: Type -> CgRep
285 typeCgRep = primRepToCgRep . typePrimRep 
286 \end{code}
287
288 Whether or not the thing is a pointer that the garbage-collector
289 should follow. Or, to put it another (less confusing) way, whether
290 the object in question is a heap object. 
291
292 Depending on the outcome, this predicate determines what stack
293 the pointer/object possibly will have to be saved onto, and the
294 computation of GC liveness info.
295
296 \begin{code}
297 isFollowableArg :: CgRep -> Bool  -- True <=> points to a heap object
298 isFollowableArg PtrArg  = True
299 isFollowableArg _       = False
300
301 isVoidArg :: CgRep -> Bool
302 isVoidArg VoidArg = True
303 isVoidArg _       = False
304
305 nonVoidArg :: CgRep -> Bool
306 nonVoidArg VoidArg = False
307 nonVoidArg _       = True
308
309 -- isFloatingArg is used to distinguish @Double@ and @Float@ which
310 -- cause inadvertent numeric conversions if you aren't jolly careful.
311 -- See codeGen/CgCon:cgTopRhsCon.
312
313 isFloatingArg :: CgRep -> Bool
314 isFloatingArg DoubleArg = True
315 isFloatingArg FloatArg  = True
316 isFloatingArg _         = False
317
318 is64BitArg :: CgRep -> Bool
319 is64BitArg LongArg = True
320 is64BitArg _       = False
321 \end{code}
322
323 \begin{code}
324 separateByPtrFollowness :: [(CgRep,a)] -> ([(CgRep,a)], [(CgRep,a)])
325 -- Returns (ptrs, non-ptrs)
326 separateByPtrFollowness things
327   = sep_things things [] []
328     -- accumulating params for follow-able and don't-follow things...
329   where
330     sep_things []              bs us = (reverse bs, reverse us)
331     sep_things ((PtrArg,a):ts) bs us = sep_things ts ((PtrArg,a):bs) us
332     sep_things (t         :ts) bs us = sep_things ts bs              (t:us)
333 \end{code}
334
335 \begin{code}
336 cgRepSizeB :: CgRep -> ByteOff
337 cgRepSizeB DoubleArg = dOUBLE_SIZE
338 cgRepSizeB LongArg   = wORD64_SIZE
339 cgRepSizeB VoidArg   = 0
340 cgRepSizeB _         = wORD_SIZE
341
342 cgRepSizeW :: CgRep -> ByteOff
343 cgRepSizeW DoubleArg = dOUBLE_SIZE `quot` wORD_SIZE
344 cgRepSizeW LongArg   = wORD64_SIZE `quot` wORD_SIZE
345 cgRepSizeW VoidArg   = 0
346 cgRepSizeW _         = 1
347
348 retAddrSizeW :: WordOff
349 retAddrSizeW = 1        -- One word
350 \end{code}
351
352 %************************************************************************
353 %*                                                                      *
354 \subsection[ClosureInfo-construction]{Functions which build LFInfos}
355 %*                                                                      *
356 %************************************************************************
357
358 \begin{code}
359 mkLFReEntrant :: TopLevelFlag   -- True of top level
360               -> [Id]           -- Free vars
361               -> [Id]           -- Args
362               -> ArgDescr       -- Argument descriptor
363               -> LambdaFormInfo
364
365 mkLFReEntrant top fvs args arg_descr 
366   = LFReEntrant top (length args) (null fvs) arg_descr
367
368 mkLFThunk :: Type -> TopLevelFlag -> [Var] -> UpdateFlag -> LambdaFormInfo
369 mkLFThunk thunk_ty top fvs upd_flag
370   = ASSERT2( not (isUpdatable upd_flag) || not (isUnLiftedType thunk_ty), ppr thunk_ty $$ ppr fvs )
371     LFThunk top (null fvs) 
372             (isUpdatable upd_flag)
373             NonStandardThunk 
374             (might_be_a_function thunk_ty)
375
376 might_be_a_function :: Type -> Bool
377 -- Return False only if we are *sure* it's a data type
378 -- Look through newtypes etc as much as poss
379 might_be_a_function ty
380   = case tyConAppTyCon_maybe (repType ty) of
381         Just tc -> not (isDataTyCon tc)
382         Nothing -> True
383 \end{code}
384
385 @mkConLFInfo@ is similar, for constructors.
386
387 \begin{code}
388 mkConLFInfo :: DataCon -> LambdaFormInfo
389 mkConLFInfo con = LFCon con
390
391 maybeIsLFCon :: LambdaFormInfo -> Maybe DataCon
392 maybeIsLFCon (LFCon con) = Just con
393 maybeIsLFCon _ = Nothing
394
395 mkSelectorLFInfo :: Id -> WordOff -> Bool -> LambdaFormInfo
396 mkSelectorLFInfo id offset updatable
397   = LFThunk NotTopLevel False updatable (SelectorThunk offset) 
398         (might_be_a_function (idType id))
399
400 mkApLFInfo :: Id -> UpdateFlag -> Int -> LambdaFormInfo
401 mkApLFInfo id upd_flag arity
402   = LFThunk NotTopLevel (arity == 0) (isUpdatable upd_flag) (ApThunk arity)
403         (might_be_a_function (idType id))
404 \end{code}
405
406 Miscellaneous LF-infos.
407
408 \begin{code}
409 mkLFArgument :: Id -> LambdaFormInfo
410 mkLFArgument id = LFUnknown (might_be_a_function (idType id))
411
412 mkLFLetNoEscape :: Int -> LambdaFormInfo
413 mkLFLetNoEscape = LFLetNoEscape
414
415 mkLFImported :: Id -> LambdaFormInfo
416 mkLFImported id
417   = case idArity id of
418       n | n > 0 -> LFReEntrant TopLevel n True (panic "arg_descr")  -- n > 0
419       _ -> mkLFArgument id -- Not sure of exact arity
420 \end{code}
421
422 \begin{code}
423 isLFThunk :: LambdaFormInfo -> Bool
424 isLFThunk (LFThunk _ _ _ _ _)  = True
425 isLFThunk LFBlackHole          = True
426         -- return True for a blackhole: this function is used to determine
427         -- whether to use the thunk header in SMP mode, and a blackhole
428         -- must have one.
429 isLFThunk _ = False
430 \end{code}
431
432 \begin{code}
433 -- We keep the *zero-indexed* tag in the srt_len field of the info
434 -- table of a data constructor.
435 type ConTagZ = Int      -- A *zero-indexed* contructor tag
436
437 dataConTagZ :: DataCon -> ConTagZ
438 dataConTagZ con = dataConTag con - fIRST_TAG
439 \end{code}
440
441
442 %************************************************************************
443 %*                                                                      *
444         Building ClosureInfos
445 %*                                                                      *
446 %************************************************************************
447
448 \begin{code}
449 mkClosureInfo :: Bool           -- Is static
450               -> Id
451               -> LambdaFormInfo 
452               -> Int -> Int     -- Total and pointer words
453               -> C_SRT
454               -> String         -- String descriptor
455               -> ClosureInfo
456 mkClosureInfo is_static id lf_info tot_wds ptr_wds srt_info descr
457   = ClosureInfo { closureName = name, 
458                   closureLFInfo = lf_info,
459                   closureSMRep = sm_rep, 
460                   closureSRT = srt_info,
461                   closureType = idType id,
462                   closureDescr = descr,
463                   closureInfLcl = isDataConWorkId id }
464                     -- Make the _info pointer for the implicit datacon worker binding
465                     -- local. The reason we can do this is that importing code always
466                     -- either uses the _closure or _con_info. By the invariants in CorePrep
467                     -- anything else gets eta expanded.
468   where
469     name   = idName id
470     sm_rep = mkHeapRep is_static ptr_wds nonptr_wds (lfClosureType lf_info)
471     nonptr_wds = tot_wds - ptr_wds
472
473 mkConInfo :: Bool       -- Is static
474           -> DataCon    
475           -> Int -> Int -- Total and pointer words
476           -> ClosureInfo
477 mkConInfo is_static data_con tot_wds ptr_wds
478    = ConInfo {  closureSMRep = sm_rep,
479                 closureCon = data_con }
480   where
481     sm_rep  = mkHeapRep is_static ptr_wds nonptr_wds (lfClosureType lf_info)
482     lf_info = mkConLFInfo data_con
483     nonptr_wds = tot_wds - ptr_wds
484 \end{code}
485
486 %************************************************************************
487 %*                                                                      *
488 \subsection[ClosureInfo-sizes]{Functions about closure {\em sizes}}
489 %*                                                                      *
490 %************************************************************************
491
492 \begin{code}
493 closureSize :: ClosureInfo -> WordOff
494 closureSize cl_info = heapClosureSize (closureSMRep cl_info)
495 \end{code}
496
497 \begin{code}
498 -- we leave space for an update if either (a) the closure is updatable
499 -- or (b) it is a static thunk.  This is because a static thunk needs
500 -- a static link field in a predictable place (after the slop), regardless
501 -- of whether it is updatable or not.
502 closureNeedsUpdSpace :: ClosureInfo -> Bool
503 closureNeedsUpdSpace (ClosureInfo { closureLFInfo = 
504                                         LFThunk TopLevel _ _ _ _ }) = True
505 closureNeedsUpdSpace cl_info = closureUpdReqd cl_info
506 \end{code}
507
508 %************************************************************************
509 %*                                                                      *
510 \subsection[SMreps]{Choosing SM reps}
511 %*                                                                      *
512 %************************************************************************
513
514 \begin{code}
515 lfClosureType :: LambdaFormInfo -> ClosureTypeInfo
516 lfClosureType (LFReEntrant _ arity _ argd) = Fun (fromIntegral arity) argd
517 lfClosureType (LFCon con)                  = Constr (fromIntegral (dataConTagZ con))
518                                                     (dataConIdentity con)
519 lfClosureType (LFThunk _ _ _ is_sel _)     = thunkClosureType is_sel
520 lfClosureType _                            = panic "lfClosureType"
521
522 thunkClosureType :: StandardFormInfo -> ClosureTypeInfo
523 thunkClosureType (SelectorThunk off) = ThunkSelector (fromIntegral off)
524 thunkClosureType _                   = Thunk
525
526 -- We *do* get non-updatable top-level thunks sometimes.  eg. f = g
527 -- gets compiled to a jump to g (if g has non-zero arity), instead of
528 -- messing around with update frames and PAPs.  We set the closure type
529 -- to FUN_STATIC in this case.
530 \end{code}
531
532 %************************************************************************
533 %*                                                                      *
534 \subsection[ClosureInfo-4-questions]{Four major questions about @ClosureInfo@}
535 %*                                                                      *
536 %************************************************************************
537
538 Be sure to see the stg-details notes about these...
539
540 \begin{code}
541 nodeMustPointToIt :: LambdaFormInfo -> Bool
542 nodeMustPointToIt (LFReEntrant top _ no_fvs _)
543   = not no_fvs ||   -- Certainly if it has fvs we need to point to it
544     isNotTopLevel top
545                     -- If it is not top level we will point to it
546                     --   We can have a \r closure with no_fvs which
547                     --   is not top level as special case cgRhsClosure
548                     --   has been dissabled in favour of let floating
549
550                 -- For lex_profiling we also access the cost centre for a
551                 -- non-inherited function i.e. not top level
552                 -- the  not top  case above ensures this is ok.
553
554 nodeMustPointToIt (LFCon _) = True
555
556         -- Strictly speaking, the above two don't need Node to point
557         -- to it if the arity = 0.  But this is a *really* unlikely
558         -- situation.  If we know it's nil (say) and we are entering
559         -- it. Eg: let x = [] in x then we will certainly have inlined
560         -- x, since nil is a simple atom.  So we gain little by not
561         -- having Node point to known zero-arity things.  On the other
562         -- hand, we do lose something; Patrick's code for figuring out
563         -- when something has been updated but not entered relies on
564         -- having Node point to the result of an update.  SLPJ
565         -- 27/11/92.
566
567 nodeMustPointToIt (LFThunk _ no_fvs updatable NonStandardThunk _)
568   = updatable || not no_fvs || opt_SccProfilingOn
569           -- For the non-updatable (single-entry case):
570           --
571           -- True if has fvs (in which case we need access to them, and we
572           --                should black-hole it)
573           -- or profiling (in which case we need to recover the cost centre
574           --             from inside it)
575
576 nodeMustPointToIt (LFThunk _ _ _ _ _)
577   = True  -- Node must point to any standard-form thunk
578
579 nodeMustPointToIt (LFUnknown _)     = True
580 nodeMustPointToIt LFBlackHole       = True    -- BH entry may require Node to point
581 nodeMustPointToIt (LFLetNoEscape _) = False 
582 \end{code}
583
584 The entry conventions depend on the type of closure being entered,
585 whether or not it has free variables, and whether we're running
586 sequentially or in parallel.
587
588 \begin{tabular}{lllll}
589 Closure Characteristics & Parallel & Node Req'd & Argument Passing & Enter Via \\
590 Unknown                         & no & yes & stack      & node \\
591 Known fun ($\ge$ 1 arg), no fvs         & no & no  & registers  & fast entry (enough args) \\
592 \ & \ & \ & \                                           & slow entry (otherwise) \\
593 Known fun ($\ge$ 1 arg), fvs    & no & yes & registers  & fast entry (enough args) \\
594 0 arg, no fvs @\r,\s@           & no & no  & n/a        & direct entry \\
595 0 arg, no fvs @\u@              & no & yes & n/a        & node \\
596 0 arg, fvs @\r,\s@              & no & yes & n/a        & direct entry \\
597 0 arg, fvs @\u@                 & no & yes & n/a        & node \\
598
599 Unknown                         & yes & yes & stack     & node \\
600 Known fun ($\ge$ 1 arg), no fvs         & yes & no  & registers & fast entry (enough args) \\
601 \ & \ & \ & \                                           & slow entry (otherwise) \\
602 Known fun ($\ge$ 1 arg), fvs    & yes & yes & registers & node \\
603 0 arg, no fvs @\r,\s@           & yes & no  & n/a       & direct entry \\
604 0 arg, no fvs @\u@              & yes & yes & n/a       & node \\
605 0 arg, fvs @\r,\s@              & yes & yes & n/a       & node \\
606 0 arg, fvs @\u@                 & yes & yes & n/a       & node\\
607 \end{tabular}
608
609 When black-holing, single-entry closures could also be entered via node
610 (rather than directly) to catch double-entry.
611
612 \begin{code}
613 data CallMethod
614   = EnterIt                             -- no args, not a function
615
616   | JumpToIt CLabel                     -- no args, not a function, but we
617                                         -- know what its entry code is
618
619   | ReturnIt                            -- it's a function, but we have
620                                         -- zero args to apply to it, so just
621                                         -- return it.
622
623   | ReturnCon DataCon                   -- It's a data constructor, just return it
624
625   | SlowCall                            -- Unknown fun, or known fun with
626                                         -- too few args.
627
628   | DirectEntry                         -- Jump directly, with args in regs
629         CLabel                          --   The code label
630         Int                             --   Its arity
631
632 getCallMethod :: DynFlags
633               -> Name           -- Function being applied
634               -> CafInfo        -- Can it refer to CAF's?
635               -> LambdaFormInfo -- Its info
636               -> Int            -- Number of available arguments
637               -> CallMethod
638
639 getCallMethod _ _ _ lf_info _
640   | nodeMustPointToIt lf_info && opt_Parallel
641   =     -- If we're parallel, then we must always enter via node.  
642         -- The reason is that the closure may have been         
643         -- fetched since we allocated it.
644     EnterIt
645
646 getCallMethod _ name caf (LFReEntrant _ arity _ _) n_args
647   | n_args == 0    = ASSERT( arity /= 0 )
648                      ReturnIt   -- No args at all
649   | n_args < arity = SlowCall   -- Not enough args
650   | otherwise      = DirectEntry (enterIdLabel name caf) arity
651
652 getCallMethod _ _ _ (LFCon con) n_args
653   | opt_SccProfilingOn     -- when profiling, we must always enter
654   = EnterIt                -- a closure when we use it, so that the closure
655                            -- can be recorded as used for LDV profiling.
656   | otherwise
657   = ASSERT( n_args == 0 )
658     ReturnCon con
659
660 getCallMethod _dflags _name _caf (LFThunk _ _ _updatable _std_form_info is_fun) _n_args
661   | is_fun      -- it *might* be a function, so we must "call" it (which is
662                 -- always safe)
663   = SlowCall    -- We cannot just enter it [in eval/apply, the entry code
664                 -- is the fast-entry code]
665
666   -- Since is_fun is False, we are *definitely* looking at a data value
667   | otherwise
668   = EnterIt
669     -- We used to have ASSERT( n_args == 0 ), but actually it is
670     -- possible for the optimiser to generate
671     --   let bot :: Int = error Int "urk"
672     --   in (bot `cast` unsafeCoerce Int (Int -> Int)) 3
673     -- This happens as a result of the case-of-error transformation
674     -- So the right thing to do is just to enter the thing
675
676 -- Old version:
677 --  | updatable || doingTickyProfiling dflags -- to catch double entry
678 --  = EnterIt
679 --  | otherwise -- Jump direct to code for single-entry thunks
680 --  = JumpToIt (thunkEntryLabel name caf std_form_info updatable)
681 --
682 -- Now we never use JumpToIt, even if the thunk is single-entry, since
683 -- the thunk may have already been entered and blackholed by another
684 -- processor.
685
686
687 getCallMethod _ _ _ (LFUnknown True) _
688   = SlowCall -- Might be a function
689
690 getCallMethod _ name _ (LFUnknown False) n_args
691   | n_args > 0 
692   = WARN( True, ppr name <+> ppr n_args ) 
693     SlowCall    -- Note [Unsafe coerce complications]
694
695   | otherwise
696   = EnterIt -- Not a function
697
698 getCallMethod _ _ _ LFBlackHole _
699   = SlowCall    -- Presumably the black hole has by now
700                 -- been updated, but we don't know with
701                 -- what, so we slow call it
702
703 getCallMethod _ name _ (LFLetNoEscape 0) _
704   = JumpToIt (enterReturnPtLabel (nameUnique name))
705
706 getCallMethod _ name _ (LFLetNoEscape arity) n_args
707   | n_args == arity = DirectEntry (enterReturnPtLabel (nameUnique name)) arity
708   | otherwise = pprPanic "let-no-escape: " (ppr name <+> ppr arity)
709
710
711 blackHoleOnEntry :: ClosureInfo -> Bool
712 blackHoleOnEntry ConInfo{} = False
713 blackHoleOnEntry cl_info
714   | isStaticRep (closureSMRep cl_info)
715   = False       -- Never black-hole a static closure
716
717   | otherwise
718   = case closureLFInfo cl_info of
719         LFReEntrant _ _ _ _       -> False
720         LFLetNoEscape _           -> False
721         LFThunk _ no_fvs _updatable _ _ -> not no_fvs -- to plug space-leaks.
722         _other -> panic "blackHoleOnEntry"      -- Should never happen
723
724 isKnownFun :: LambdaFormInfo -> Bool
725 isKnownFun (LFReEntrant _ _ _ _) = True
726 isKnownFun (LFLetNoEscape _) = True
727 isKnownFun _ = False
728 \end{code}
729
730 Note [Unsafe coerce complications]
731 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
732 In some (badly-optimised) DPH code we see this
733    Module X:    rr :: Int = error Int "Urk"
734    Module Y:    ...((X.rr |> g) True) ...
735      where g is an (unsafe) coercion of kind (Int ~ Bool->Bool), say
736
737 It's badly optimised, because knowing that 'X.rr' is bottom, we should
738 have dumped the application to True.  But it should still work. These
739 strange unsafe coercions arise from the case-of-error transformation:
740         (case (error Int "foo") of { ... }) True
741 --->    (error Int "foo" |> g) True
742
743 Anyway, the net effect is that in STG-land, when casts are discarded,
744 we *can* see a value of type Int applied to an argument.  This only happens
745 if (a) the programmer made a mistake, or (b) the value of type Int is
746 actually bottom.
747
748 So it's wrong to trigger an ASSERT failure in this circumstance.  Instead
749 we now emit a WARN -- mainly to draw attention to a probably-badly-optimised
750 program fragment -- and do the conservative thing which is SlowCall.
751
752
753 -----------------------------------------------------------------------------
754 SRT-related stuff
755
756 \begin{code}
757 staticClosureNeedsLink :: ClosureInfo -> Bool
758 -- A static closure needs a link field to aid the GC when traversing
759 -- the static closure graph.  But it only needs such a field if either
760 --      a) it has an SRT
761 --      b) it's a constructor with one or more pointer fields
762 -- In case (b), the constructor's fields themselves play the role
763 -- of the SRT.
764 staticClosureNeedsLink (ClosureInfo { closureSRT = srt })
765   = needsSRT srt
766 staticClosureNeedsLink (ConInfo { closureSMRep = rep })
767   = not (isStaticNoCafCon rep)
768 \end{code}
769
770 Note [Entering error thunks]
771 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
772 Consider this
773
774         fail :: Int
775         fail = error Int "Urk"
776
777         foo :: Bool -> Bool 
778         foo True  y = (fail `cast` Bool -> Bool) y
779         foo False y = False
780
781 This looks silly, but it can arise from case-of-error.  Even if it
782 does, we'd usually see that 'fail' is a bottoming function and would
783 discard the extra argument 'y'.  But even if that does not occur,
784 this program is still OK.  We will enter 'fail', which never returns.
785
786 The WARN is just to alert me to the fact that we aren't spotting that
787 'fail' is bottoming.
788
789 (We are careful never to make a funtion value look like a data type,
790 because we can't enter a function closure -- but that is not the 
791 problem here.)
792
793
794 Avoiding generating entries and info tables
795 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
796 At present, for every function we generate all of the following,
797 just in case.  But they aren't always all needed, as noted below:
798
799 [NB1: all of this applies only to *functions*.  Thunks always
800 have closure, info table, and entry code.]
801
802 [NB2: All are needed if the function is *exported*, just to play safe.]
803
804
805 * Fast-entry code  ALWAYS NEEDED
806
807 * Slow-entry code
808         Needed iff (a) we have any un-saturated calls to the function
809         OR         (b) the function is passed as an arg
810         OR         (c) we're in the parallel world and the function has free vars
811                         [Reason: in parallel world, we always enter functions
812                         with free vars via the closure.]
813
814 * The function closure
815         Needed iff (a) we have any un-saturated calls to the function
816         OR         (b) the function is passed as an arg
817         OR         (c) if the function has free vars (ie not top level)
818
819   Why case (a) here?  Because if the arg-satis check fails,
820   UpdatePAP stuffs a pointer to the function closure in the PAP.
821   [Could be changed; UpdatePAP could stuff in a code ptr instead,
822    but doesn't seem worth it.]
823
824   [NB: these conditions imply that we might need the closure
825   without the slow-entry code.  Here's how.
826
827         f x y = let g w = ...x..y..w...
828                 in
829                 ...(g t)...
830
831   Here we need a closure for g which contains x and y,
832   but since the calls are all saturated we just jump to the
833   fast entry point for g, with R1 pointing to the closure for g.]
834
835
836 * Standard info table
837         Needed iff (a) we have any un-saturated calls to the function
838         OR         (b) the function is passed as an arg
839         OR         (c) the function has free vars (ie not top level)
840
841         NB.  In the sequential world, (c) is only required so that the function closure has
842         an info table to point to, to keep the storage manager happy.
843         If (c) alone is true we could fake up an info table by choosing
844         one of a standard family of info tables, whose entry code just
845         bombs out.
846
847         [NB In the parallel world (c) is needed regardless because
848         we enter functions with free vars via the closure.]
849
850         If (c) is retained, then we'll sometimes generate an info table
851         (for storage mgr purposes) without slow-entry code.  Then we need
852         to use an error label in the info table to substitute for the absent
853         slow entry code.
854
855 \begin{code}
856 staticClosureRequired
857         :: Name
858         -> StgBinderInfo
859         -> LambdaFormInfo
860         -> Bool
861 staticClosureRequired _ bndr_info
862                       (LFReEntrant top_level _ _ _)     -- It's a function
863   = ASSERT( isTopLevel top_level )
864         -- Assumption: it's a top-level, no-free-var binding
865         not (satCallsOnly bndr_info)
866
867 staticClosureRequired _ _ _ = True
868 \end{code}
869
870 %************************************************************************
871 %*                                                                      *
872 \subsection[ClosureInfo-misc-funs]{Misc functions about @ClosureInfo@, etc.}
873 %*                                                                      *
874 %************************************************************************
875
876 \begin{code}
877 isStaticClosure :: ClosureInfo -> Bool
878 isStaticClosure cl_info = isStaticRep (closureSMRep cl_info)
879
880 closureUpdReqd :: ClosureInfo -> Bool
881 closureUpdReqd ClosureInfo{ closureLFInfo = lf_info } = lfUpdatable lf_info
882 closureUpdReqd ConInfo{} = False
883
884 lfUpdatable :: LambdaFormInfo -> Bool
885 lfUpdatable (LFThunk _ _ upd _ _)  = upd
886 lfUpdatable LFBlackHole            = True
887         -- Black-hole closures are allocated to receive the results of an
888         -- alg case with a named default... so they need to be updated.
889 lfUpdatable _ = False
890
891 closureIsThunk :: ClosureInfo -> Bool
892 closureIsThunk ClosureInfo{ closureLFInfo = lf_info } = isLFThunk lf_info
893 closureIsThunk ConInfo{} = False
894
895 closureSingleEntry :: ClosureInfo -> Bool
896 closureSingleEntry (ClosureInfo { closureLFInfo = LFThunk _ _ upd _ _}) = not upd
897 closureSingleEntry _ = False
898
899 closureReEntrant :: ClosureInfo -> Bool
900 closureReEntrant (ClosureInfo { closureLFInfo = LFReEntrant _ _ _ _ }) = True
901 closureReEntrant _ = False
902
903 isConstrClosure_maybe :: ClosureInfo -> Maybe DataCon
904 isConstrClosure_maybe (ConInfo { closureCon = data_con }) = Just data_con
905 isConstrClosure_maybe _                                   = Nothing
906
907 closureFunInfo :: ClosureInfo -> Maybe (Int, ArgDescr)
908 closureFunInfo (ClosureInfo { closureLFInfo = lf_info }) = lfFunInfo lf_info
909 closureFunInfo _ = Nothing
910
911 lfFunInfo :: LambdaFormInfo ->  Maybe (Int, ArgDescr)
912 lfFunInfo (LFReEntrant _ arity _ arg_desc)  = Just (arity, arg_desc)
913 lfFunInfo _                                 = Nothing
914
915 funTag :: ClosureInfo -> Int
916 funTag (ClosureInfo { closureLFInfo = lf_info }) = funTagLFInfo lf_info
917 funTag _ = 0
918
919 -- maybe this should do constructor tags too?
920 funTagLFInfo :: LambdaFormInfo -> Int
921 funTagLFInfo lf
922     -- A function is tagged with its arity
923   | Just (arity,_) <- lfFunInfo lf,
924     Just tag <- tagForArity arity
925   = tag
926
927     -- other closures (and unknown ones) are not tagged
928   | otherwise
929   = 0
930
931 tagForArity :: Int -> Maybe Int
932 tagForArity i | i <= mAX_PTR_TAG = Just i
933               | otherwise        = Nothing
934
935 clHasCafRefs :: ClosureInfo -> CafInfo
936 clHasCafRefs (ClosureInfo {closureSRT = srt}) = 
937   case srt of NoC_SRT -> NoCafRefs
938               _       -> MayHaveCafRefs
939 clHasCafRefs (ConInfo {}) = NoCafRefs
940 \end{code}
941
942 \begin{code}
943 isToplevClosure :: ClosureInfo -> Bool
944 isToplevClosure (ClosureInfo { closureLFInfo = lf_info })
945   = case lf_info of
946       LFReEntrant TopLevel _ _ _ -> True
947       LFThunk TopLevel _ _ _ _   -> True
948       _ -> False
949 isToplevClosure _ = False
950 \end{code}
951
952 Label generation.
953
954 \begin{code}
955 infoTableLabelFromCI :: ClosureInfo -> CLabel
956 infoTableLabelFromCI = fst . labelsFromCI
957
958 entryLabelFromCI :: ClosureInfo -> CLabel
959 entryLabelFromCI = snd . labelsFromCI
960
961 labelsFromCI :: ClosureInfo -> (CLabel, CLabel) -- (Info, Entry)
962 labelsFromCI cl@(ClosureInfo { closureName = name,
963                                closureLFInfo = lf_info,
964                                closureInfLcl = is_lcl })
965   = case lf_info of
966         LFBlackHole -> (mkCAFBlackHoleInfoTableLabel, mkCAFBlackHoleEntryLabel)
967
968         LFThunk _ _ upd_flag (SelectorThunk offset) _ -> 
969                 bothL (mkSelectorInfoLabel, mkSelectorEntryLabel) upd_flag offset
970
971         LFThunk _ _ upd_flag (ApThunk arity) _ -> 
972                 bothL (mkApInfoTableLabel, mkApEntryLabel) upd_flag arity
973
974         LFThunk{}      -> bothL std_mk_lbls name $ clHasCafRefs cl
975
976         LFReEntrant _ _ _ _ -> bothL std_mk_lbls name $ clHasCafRefs cl
977
978         _ -> panic "labelsFromCI"
979   where std_mk_lbls = if is_lcl then (mkLocalInfoTableLabel, mkLocalEntryLabel) else (mkInfoTableLabel, mkEntryLabel)
980
981 labelsFromCI cl@(ConInfo { closureCon = con, 
982                                    closureSMRep = rep })
983   | isStaticRep rep = bothL (mkStaticInfoTableLabel, mkStaticConEntryLabel)  name $ clHasCafRefs cl
984   | otherwise       = bothL (mkConInfoTableLabel,    mkConEntryLabel)        name $ clHasCafRefs cl
985   where
986     name = dataConName con
987
988 bothL :: (a -> b -> c, a -> b -> c) -> a -> b -> (c, c)
989 bothL (f, g) x y = (f x y, g x y)
990
991 -- ClosureInfo for a closure (as opposed to a constructor) is always local
992 closureLabelFromCI :: ClosureInfo -> CLabel
993 closureLabelFromCI cl@(ClosureInfo { closureName = nm }) = mkLocalClosureLabel nm $ clHasCafRefs cl
994 closureLabelFromCI _ = panic "closureLabelFromCI"
995
996 -- thunkEntryLabel is a local help function, not exported.  It's used from both
997 -- entryLabelFromCI and getCallMethod.
998
999 {- UNUSED:
1000 thunkEntryLabel :: Name -> CafInfo -> StandardFormInfo -> Bool -> CLabel
1001 thunkEntryLabel _thunk_id _ (ApThunk arity) is_updatable
1002   = enterApLabel is_updatable arity
1003 thunkEntryLabel _thunk_id _ (SelectorThunk offset) upd_flag
1004   = enterSelectorLabel upd_flag offset
1005 thunkEntryLabel thunk_id caf _ _is_updatable
1006   = enterIdLabel thunk_id caf
1007 -}
1008
1009 {- UNUSED:
1010 enterApLabel :: Bool -> Int -> CLabel
1011 enterApLabel is_updatable arity
1012   | tablesNextToCode = mkApInfoTableLabel is_updatable arity
1013   | otherwise        = mkApEntryLabel is_updatable arity
1014 -}
1015
1016 {- UNUSED:
1017 enterSelectorLabel :: Bool -> Int -> CLabel
1018 enterSelectorLabel upd_flag offset
1019   | tablesNextToCode = mkSelectorInfoLabel upd_flag offset
1020   | otherwise        = mkSelectorEntryLabel upd_flag offset
1021 -}
1022
1023 enterIdLabel :: Name -> CafInfo -> CLabel
1024 enterIdLabel id
1025   | tablesNextToCode = mkInfoTableLabel id
1026   | otherwise        = mkEntryLabel id
1027
1028 enterLocalIdLabel :: Name -> CafInfo -> CLabel
1029 enterLocalIdLabel id
1030   | tablesNextToCode = mkLocalInfoTableLabel id
1031   | otherwise        = mkLocalEntryLabel id
1032
1033 enterReturnPtLabel :: Unique -> CLabel
1034 enterReturnPtLabel name
1035   | tablesNextToCode = mkReturnInfoLabel name
1036   | otherwise        = mkReturnPtLabel name
1037 \end{code}
1038
1039
1040 We need a black-hole closure info to pass to @allocDynClosure@ when we
1041 want to allocate the black hole on entry to a CAF.  These are the only
1042 ways to build an LFBlackHole, maintaining the invariant that it really
1043 is a black hole and not something else.
1044
1045 \begin{code}
1046 cafBlackHoleClosureInfo :: ClosureInfo -> ClosureInfo
1047 cafBlackHoleClosureInfo (ClosureInfo { closureName = nm,
1048                                        closureType = ty })
1049   = ClosureInfo { closureName   = nm,
1050                   closureLFInfo = LFBlackHole,
1051                   closureSMRep  = blackHoleRep,
1052                   closureSRT    = NoC_SRT,
1053                   closureType   = ty,
1054                   closureDescr  = "",
1055                   closureInfLcl = False }
1056 cafBlackHoleClosureInfo _ = panic "cafBlackHoleClosureInfo"
1057 \end{code}
1058
1059 %************************************************************************
1060 %*                                                                      *
1061 \subsection[ClosureInfo-Profiling-funs]{Misc functions about for profiling info.}
1062 %*                                                                      *
1063 %************************************************************************
1064
1065 Profiling requires two pieces of information to be determined for
1066 each closure's info table --- description and type.
1067
1068 The description is stored directly in the @CClosureInfoTable@ when the
1069 info table is built.
1070
1071 The type is determined from the type information stored with the @Id@
1072 in the closure info using @closureTypeDescr@.
1073
1074 \begin{code}
1075 closureValDescr, closureTypeDescr :: ClosureInfo -> String
1076 closureValDescr (ClosureInfo {closureDescr = descr}) 
1077   = descr
1078 closureValDescr (ConInfo {closureCon = con})
1079   = occNameString (getOccName con)
1080
1081 closureTypeDescr (ClosureInfo { closureType = ty })
1082   = getTyDescription ty
1083 closureTypeDescr (ConInfo { closureCon = data_con })
1084   = occNameString (getOccName (dataConTyCon data_con))
1085
1086 getTyDescription :: Type -> String
1087 getTyDescription ty
1088   = case (tcSplitSigmaTy ty) of { (_, _, tau_ty) ->
1089     case tau_ty of
1090       TyVarTy _              -> "*"
1091       AppTy fun _            -> getTyDescription fun
1092       FunTy _ res            -> '-' : '>' : fun_result res
1093       TyConApp tycon _       -> getOccString tycon
1094       PredTy sty             -> getPredTyDescription sty
1095       ForAllTy _ ty          -> getTyDescription ty
1096     }
1097   where
1098     fun_result (FunTy _ res) = '>' : fun_result res
1099     fun_result other         = getTyDescription other
1100
1101 getPredTyDescription :: PredType -> String
1102 getPredTyDescription (ClassP cl _) = getOccString cl
1103 getPredTyDescription (IParam ip _) = getOccString (ipNameName ip)
1104 getPredTyDescription (EqPred _ _)  = "Type equality"
1105 \end{code}