ghc/compiler/codeGen/ClosureInfo.lhs

   1
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   3 %
   4 \section[ClosureInfo]{Data structures which describe closures}
   5
   6 Much of the rationale for these things is in the ``details'' part of
   7 the STG paper.
   8
   9 \begin{code}
  10 #include "HsVersions.h"
  11
  12 module ClosureInfo (
  13         ClosureInfo, LambdaFormInfo, SMRep,     -- all abstract
  14         StandardFormInfo,
  15
  16         EntryConvention(..),
  17
  18         mkClosureLFInfo, mkConLFInfo, mkSelectorLFInfo, mkVapLFInfo,
  19         mkLFImported, mkLFArgument, mkLFLetNoEscape,
  20
  21         closureSize, closureHdrSize,
  22         closureNonHdrSize, closureSizeWithoutFixedHdr,
  23         closureGoodStuffSize, closurePtrsSize,
  24         slopSize, fitsMinUpdSize,
  25
  26         layOutDynClosure, layOutDynCon, layOutStaticClosure,
  27         layOutStaticNoFVClosure, layOutPhantomClosure,
  28         mkVirtHeapOffsets,
  29
  30         nodeMustPointToIt, getEntryConvention,
  31         blackHoleOnEntry,
  32
  33         staticClosureRequired,
  34         slowFunEntryCodeRequired, funInfoTableRequired,
  35         stdVapRequired, noUpdVapRequired,
  36
  37         closureId, infoTableLabelFromCI, fastLabelFromCI,
  38         closureLabelFromCI,
  39         entryLabelFromCI,
  40         closureLFInfo, closureSMRep, closureUpdReqd,
  41         closureSingleEntry, closureSemiTag, closureType,
  42         closureReturnsUnboxedType, getStandardFormThunkInfo,
  43
  44         isToplevClosure,
  45         closureKind, closureTypeDescr,          -- profiling
  46
  47         isStaticClosure, allocProfilingMsg,
  48         blackHoleClosureInfo,
  49         maybeSelectorInfo,
  50
  51         dataConLiveness                         -- concurrency
  52     ) where
  53
  54 IMP_Ubiq(){-uitous-}
  55 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
  56 IMPORT_DELOOPER(AbsCLoop)               -- here for paranoia-checking
  57 #endif
  58
  59 import AbsCSyn          ( MagicId, node, mkLiveRegsMask,
  60                           {- GHC 0.29 only -} AbstractC, CAddrMode
  61                         )
  62 import StgSyn
  63 import CgMonad
  64
  65 import Constants        ( mIN_UPD_SIZE, mIN_SIZE_NonUpdHeapObject,
  66                           mAX_SPEC_ALL_PTRS, mAX_SPEC_MIXED_FIELDS,
  67                           mAX_SPEC_ALL_NONPTRS,
  68                           oTHER_TAG
  69                         )
  70 import CgRetConv        ( assignRegs, dataReturnConvAlg,
  71                           DataReturnConvention(..)
  72                         )
  73 import CLabel           ( CLabel, mkStdEntryLabel, mkFastEntryLabel,
  74                           mkPhantomInfoTableLabel, mkInfoTableLabel,
  75                           mkConInfoTableLabel, mkStaticClosureLabel,
  76                           mkBlackHoleInfoTableLabel, mkVapInfoTableLabel,
  77                           mkStaticInfoTableLabel, mkStaticConEntryLabel,
  78                           mkConEntryLabel, mkClosureLabel, mkVapEntryLabel
  79                         )
  80 import CmdLineOpts      ( opt_SccProfilingOn, opt_ForConcurrent )
  81 import HeapOffs         ( intOff, addOff, totHdrSize, varHdrSize,
  82                           SYN_IE(VirtualHeapOffset), HeapOffset
  83                         )
  84 import Id               ( idType, getIdArity,
  85                           externallyVisibleId,
  86                           dataConTag, fIRST_TAG,
  87                           isDataCon, isNullaryDataCon, dataConTyCon,
  88                           isTupleCon, SYN_IE(DataCon),
  89                           GenId{-instance Eq-}, SYN_IE(Id)
  90                         )
  91 import IdInfo           ( ArityInfo(..) )
  92 import Maybes           ( maybeToBool )
  93 import Name             ( getOccString )
  94 import Outputable       ( PprStyle(..), Outputable(..) )
  95 import PprType          ( getTyDescription, GenType{-instance Outputable-} )
  96 import Pretty           --ToDo:rm
  97 import PrelInfo         ( maybeCharLikeTyCon, maybeIntLikeTyCon )
  98 import PrimRep          ( getPrimRepSize, separateByPtrFollowness, PrimRep )
  99 import SMRep            -- all of it
 100 import TyCon            ( TyCon{-instance NamedThing-} )
 101 import Type             ( isPrimType, splitFunTyExpandingDictsAndPeeking,
 102                           mkFunTys, maybeAppSpecDataTyConExpandingDicts,
 103                           SYN_IE(Type)
 104                         )
 105 import Util             ( isIn, mapAccumL, panic, pprPanic, assertPanic )
 106 \end{code}
 107
 108 The ``wrapper'' data type for closure information:
 109
 110 \begin{code}
 111 data ClosureInfo
 112   = MkClosureInfo
 113         Id                      -- The thing bound to this closure
 114         LambdaFormInfo          -- info derivable from the *source*
 115         SMRep                   -- representation used by storage manager
 116 \end{code}
 117
 118 %************************************************************************
 119 %*                                                                      *
 120 \subsection[ClosureInfo-OLD-DOC]{OLD DOCUMENTATION PROBABLY SUPERCEDED BY stg-details}
 121 %*                                                                      *
 122 %************************************************************************
 123
 124 We can optimise the function-entry code as follows.
 125 \begin{itemize}
 126
 127 \item   If the ``function'' is not updatable, we can jump directly to its
 128         entry code, rather than indirecting via the info pointer in the
 129         closure.  (For updatable thunks we must go via the closure, in
 130         case it has been updated.)
 131
 132 \item   If the former bullet applies, and the application we are
 133         compiling gives the function as many arguments as it needs, we
 134         can jump to its fast-entry code.  (This only applies if the
 135         function has one or more args, because zero-arg closures have
 136         no fast-entry code.)
 137
 138 \item   If the function is a top-level non-constructor or imported, there
 139         is no need to make Node point to its closure.  In order for
 140         this to be right, we need to ensure that:
 141         \begin{itemize}
 142         \item   If such closures are updatable then they push their
 143                 static address in the update frame, not Node. Actually
 144                 we create a black hole and push its address.
 145
 146         \item   The arg satisfaction check should load Node before jumping to
 147                 UpdatePAP.
 148
 149         \item   Top-level constructor closures need careful handling.  If we are to
 150                 jump direct to the constructor code, we must load Node first, even
 151                 though they are top-level.  But if we go to their ``own''
 152                 standard-entry code (which loads Node and then jumps to the
 153                 constructor code) we don't need to load Node.
 154         \end{itemize}
 155 \end{itemize}
 156
 157
 158 {\em Top level constructors (@mkStaticConEntryInfo@)}
 159
 160 \begin{verbatim}
 161         x = {y,ys} \ {} Cons {y,ys}     -- Std form constructor
 162 \end{verbatim}
 163
 164 x-closure: Cons-info-table, y-closure, ys-closure
 165
 166 x-entry: Node = x-closure; jump( Cons-entry )
 167
 168 x's EntryInfo in its own module:
 169 \begin{verbatim}
 170                 Base-label = Cons               -- Not x!!
 171                 NodeMustPoint = True
 172                 ClosureClass = Constructor
 173 \end{verbatim}
 174
 175         So if x is entered, Node will be set up and
 176         we'll jump direct to the Cons code.
 177
 178 x's EntryInfo in another module: (which may not know that x is a constructor)
 179 \begin{verbatim}
 180                 Base-label = x                  -- Is x!!
 181                 NodeMustPoint = False           -- All imported things have False
 182                 ClosureClass = non-committal
 183 \end{verbatim}
 184
 185         If x is entered, we'll jump to x-entry, which will set up Node
 186         before jumping to the standard Cons code
 187
 188 {\em Top level non-constructors (@mkStaticEntryInfo@)}
 189 \begin{verbatim}
 190         x = ...
 191 \end{verbatim}
 192
 193 For updatable thunks, x-entry must push an allocated BH in update frame, not Node.
 194
 195 For non-zero arity, arg satis check must load Node before jumping to
 196         UpdatePAP.
 197
 198 x's EntryInfo in its own module:
 199 \begin{verbatim}
 200                 Base-label = x
 201                 NodeMustPoint = False
 202                 ClosureClass = whatever
 203 \end{verbatim}
 204
 205 {\em Inner constructors (@mkConEntryInfo@)}
 206
 207 \begin{verbatim}
 208                 Base-label = Cons               -- Not x!!
 209                 NodeMustPoint = True            -- If its arity were zero, it would
 210                                                 -- have been lifted to top level
 211                 ClosureClass = Constructor
 212 \end{verbatim}
 213
 214 {\em Inner non-constructors (@mkEntryInfo@)}
 215
 216 \begin{verbatim}
 217                 Base-label = x
 218                 NodeMustPoint = True            -- If no free vars, would have been
 219                                                 -- lifted to top level
 220                 ClosureClass = whatever
 221 \end{verbatim}
 222
 223 {\em Imported}
 224
 225 \begin{verbatim}
 226                 Nothing,
 227         or
 228                 Base-label = x
 229                 NodeMustPoint = False
 230                 ClosureClass = whatever
 231 \end{verbatim}
 232
 233 ==============
 234 THINK: we could omit making Node point to top-level constructors
 235 of arity zero; but that might interact nastily with updates.
 236 ==============
 237
 238
 239 ==========
 240 The info we need to import for imported things is:
 241
 242 \begin{verbatim}
 243         data ImportInfo = UnknownImportInfo
 244                         | HnfImport Int         -- Not updatable, arity given
 245                                                 -- Arity can be zero, for (eg) constrs
 246                         | UpdatableImport       -- Must enter via the closure
 247 \end{verbatim}
 248
 249 ToDo: move this stuff???
 250
 251 \begin{pseudocode}
 252 mkStaticEntryInfo lbl cl_class
 253   = MkEntryInfo lbl False cl_class
 254
 255 mkStaticConEntryInfo lbl
 256   = MkEntryInfo lbl True ConstructorClosure
 257
 258 mkEntryInfo lbl cl_class
 259   = MkEntryInfo lbl True cl_class
 260
 261 mkConEntryInfo lbl
 262   = MkEntryInfo lbl True ConstructorClosure
 263 \end{pseudocode}
 264
 265 %************************************************************************
 266 %*                                                                      *
 267 \subsection[ClosureInfo-datatypes]{Data types for closure information}
 268 %*                                                                      *
 269 %************************************************************************
 270
 271 %************************************************************************
 272 %*                                                                      *
 273 \subsubsection[LambdaFormInfo-datatype]{@LambdaFormInfo@: source-derivable info}
 274 %*                                                                      *
 275 %************************************************************************
 276
 277 \begin{code}
 278 data LambdaFormInfo
 279   = LFReEntrant         -- Reentrant closure; used for PAPs too
 280         Bool            -- True if top level
 281         Int             -- Arity
 282         Bool            -- True <=> no fvs
 283
 284   | LFCon               -- Constructor
 285         DataCon         -- The constructor (may be specialised)
 286         Bool            -- True <=> zero arity
 287
 288   | LFTuple             -- Tuples
 289         DataCon         -- The tuple constructor (may be specialised)
 290         Bool            -- True <=> zero arity
 291
 292   | LFThunk             -- Thunk (zero arity)
 293         Bool            -- True <=> top level
 294         Bool            -- True <=> no free vars
 295         Bool            -- True <=> updatable (i.e., *not* single-entry)
 296         StandardFormInfo
 297
 298   | LFArgument          -- Used for function arguments.  We know nothing about
 299                         -- this closure.  Treat like updatable "LFThunk"...
 300
 301   | LFImported          -- Used for imported things.  We know nothing about this
 302                         -- closure.  Treat like updatable "LFThunk"...
 303                         -- Imported things which we do know something about use
 304                         -- one of the other LF constructors (eg LFReEntrant for
 305                         -- known functions)
 306
 307   | LFLetNoEscape       -- See LetNoEscape module for precise description of
 308                         -- these "lets".
 309         Int             -- arity;
 310         StgLiveVars-- list of variables live in the RHS of the let.
 311                         -- (ToDo: maybe not used)
 312
 313   | LFBlackHole         -- Used for the closures allocated to hold the result
 314                         -- of a CAF.  We want the target of the update frame to
 315                         -- be in the heap, so we make a black hole to hold it.
 316
 317   -- This last one is really only for completeness;
 318   -- it isn't actually used for anything interesting
 319   {- | LFIndirection -}
 320
 321 data StandardFormInfo   -- Tells whether this thunk has one of a small number
 322                         -- of standard forms
 323
 324   = NonStandardThunk    -- No, it isn't
 325
 326  | SelectorThunk
 327        Id               -- Scrutinee
 328        DataCon          -- Constructor
 329        Int              -- 0-origin offset of ak within the "goods" of constructor
 330                         -- (Recall that the a1,...,an may be laid out in the heap
 331                         --  in a non-obvious order.)
 332
 333 {- A SelectorThunk is of form
 334
 335      case x of
 336        con a1,..,an -> ak
 337
 338    and the constructor is from a single-constr type.
 339    If we can't convert the heap-offset of the selectee into an Int, e.g.,
 340    it's "GEN_VHS+i", we just give up.
 341 -}
 342
 343   | VapThunk
 344         Id                      -- Function
 345         [StgArg]                -- Args
 346         Bool                    -- True <=> the function is not top-level, so
 347                                 -- must be stored in the thunk too
 348
 349 {- A VapThunk is of form
 350
 351         f a1 ... an
 352
 353    where f is a known function, with arity n
 354    So for this thunk we can use the label for f's heap-entry
 355    info table (generated when f's defn was dealt with),
 356    rather than generating a one-off info table and entry code
 357    for this one thunk.
 358 -}
 359
 360
 361 mkLFArgument    = LFArgument
 362 mkLFBlackHole   = LFBlackHole
 363 mkLFLetNoEscape = LFLetNoEscape
 364
 365 mkLFImported :: Id -> LambdaFormInfo
 366 mkLFImported id
 367   = case getIdArity id of
 368       ArityExactly 0    -> LFThunk True{-top-lev-} True{-no fvs-}
 369                                    True{-updatable-} NonStandardThunk
 370       ArityExactly n    -> LFReEntrant True n True  -- n > 0
 371       other             -> LFImported   -- Not sure of exact arity
 372 \end{code}
 373
 374 %************************************************************************
 375 %*                                                                      *
 376 \subsection[ClosureInfo-construction]{Functions which build LFInfos}
 377 %*                                                                      *
 378 %************************************************************************
 379
 380 @mkClosureLFInfo@ figures out the appropriate LFInfo for the closure.
 381
 382 \begin{code}
 383 mkClosureLFInfo :: Bool         -- True of top level
 384                 -> [Id]         -- Free vars
 385                 -> UpdateFlag   -- Update flag
 386                 -> [Id]         -- Args
 387                 -> LambdaFormInfo
 388
 389 mkClosureLFInfo top fvs upd_flag args@(_:_)  -- Non-empty args
 390   = LFReEntrant top (length args) (null fvs)
 391
 392 mkClosureLFInfo top fvs ReEntrant []
 393   = LFReEntrant top 0 (null fvs)
 394
 395 mkClosureLFInfo top fvs upd_flag []
 396   = LFThunk top (null fvs) (isUpdatable upd_flag) NonStandardThunk
 397
 398 isUpdatable ReEntrant   = False
 399 isUpdatable SingleEntry = False
 400 isUpdatable Updatable   = True
 401 \end{code}
 402
 403 @mkConLFInfo@ is similar, for constructors.
 404
 405 \begin{code}
 406 mkConLFInfo :: DataCon -> LambdaFormInfo
 407
 408 mkConLFInfo con
 409   = -- the isNullaryDataCon will do this: ASSERT(isDataCon con)
 410     (if isTupleCon con then LFTuple else LFCon) con (isNullaryDataCon con)
 411
 412 mkSelectorLFInfo scrutinee con offset
 413   = LFThunk False False True (SelectorThunk scrutinee con offset)
 414
 415 mkVapLFInfo fvs upd_flag fun_id args fun_in_vap
 416   = LFThunk False (null fvs) (isUpdatable upd_flag) (VapThunk fun_id args fun_in_vap)
 417 \end{code}
 418
 419
 420 %************************************************************************
 421 %*                                                                      *
 422 \subsection[ClosureInfo-sizes]{Functions about closure {\em sizes}}
 423 %*                                                                      *
 424 %************************************************************************
 425
 426 \begin{code}
 427 closureSize :: ClosureInfo -> HeapOffset
 428 closureSize cl_info@(MkClosureInfo _ _ sm_rep)
 429   = totHdrSize sm_rep `addOff` (intOff (closureNonHdrSize cl_info))
 430
 431 closureSizeWithoutFixedHdr :: ClosureInfo -> HeapOffset
 432 closureSizeWithoutFixedHdr cl_info@(MkClosureInfo _ _ sm_rep)
 433   = varHdrSize sm_rep `addOff` (intOff (closureNonHdrSize cl_info))
 434
 435 closureHdrSize :: ClosureInfo -> HeapOffset
 436 closureHdrSize (MkClosureInfo _ _ sm_rep)
 437   = totHdrSize sm_rep
 438
 439 closureNonHdrSize :: ClosureInfo -> Int
 440 closureNonHdrSize cl_info@(MkClosureInfo _ lf_info sm_rep)
 441   = tot_wds + computeSlopSize tot_wds sm_rep (closureUpdReqd cl_info) --ToDo: pass lf_info?
 442   where
 443     tot_wds = closureGoodStuffSize cl_info
 444
 445 closureGoodStuffSize :: ClosureInfo -> Int
 446 closureGoodStuffSize (MkClosureInfo _ _ sm_rep)
 447   = let (ptrs, nonptrs) = sizes_from_SMRep sm_rep
 448     in  ptrs + nonptrs
 449
 450 closurePtrsSize :: ClosureInfo -> Int
 451 closurePtrsSize (MkClosureInfo _ _ sm_rep)
 452   = let (ptrs, _) = sizes_from_SMRep sm_rep
 453     in  ptrs
 454
 455 -- not exported:
 456 sizes_from_SMRep (SpecialisedRep k ptrs nonptrs _)   = (ptrs, nonptrs)
 457 sizes_from_SMRep (GenericRep       ptrs nonptrs _)   = (ptrs, nonptrs)
 458 sizes_from_SMRep (BigTupleRep      ptrs)             = (ptrs, 0)
 459 sizes_from_SMRep (MuTupleRep       ptrs)             = (ptrs, 0)
 460 sizes_from_SMRep (DataRep               nonptrs)     = (0, nonptrs)
 461 sizes_from_SMRep BlackHoleRep                        = (0, 0)
 462 sizes_from_SMRep (StaticRep        ptrs nonptrs)     = (ptrs, nonptrs)
 463 #ifdef DEBUG
 464 sizes_from_SMRep PhantomRep       = panic "sizes_from_SMRep: PhantomRep"
 465 sizes_from_SMRep DynamicRep       = panic "sizes_from_SMRep: DynamicRep"
 466 #endif
 467 \end{code}
 468
 469 \begin{code}
 470 fitsMinUpdSize :: ClosureInfo -> Bool
 471 fitsMinUpdSize (MkClosureInfo _ _ BlackHoleRep) = True
 472 fitsMinUpdSize cl_info = isSpecRep (closureSMRep cl_info) && closureNonHdrSize cl_info <= mIN_UPD_SIZE
 473 \end{code}
 474
 475 Computing slop size.  WARNING: this looks dodgy --- it has deep
 476 knowledge of what the storage manager does with the various
 477 representations...
 478
 479 Slop Requirements:
 480 \begin{itemize}
 481 \item
 482 Updateable closures must be @mIN_UPD_SIZE@.
 483         \begin{itemize}
 484         \item
 485         Cons cell requires 2 words
 486         \item
 487         Indirections require 1 word
 488         \item
 489         Appels collector indirections 2 words
 490         \end{itemize}
 491 THEREFORE: @mIN_UPD_SIZE = 2@.
 492
 493 \item
 494 Collectable closures which are allocated in the heap
 495 must be @mIN_SIZE_NonUpdHeapObject@.
 496
 497 Copying collector forward pointer requires 1 word
 498
 499 THEREFORE: @mIN_SIZE_NonUpdHeapObject = 1@
 500
 501 \item
 502 @SpecialisedRep@ closures closures may require slop:
 503         \begin{itemize}
 504         \item
 505         @ConstantRep@ and @CharLikeRep@ closures always use the address of
 506         a static closure. They are never allocated or
 507         collected (eg hold forwarding pointer) hence never any slop.
 508
 509         \item
 510         @IntLikeRep@ are never updatable.
 511         May need slop to be collected (as they will be size 1 or more
 512         this probably has no affect)
 513
 514         \item
 515         @SpecRep@ may be updateable and will be collectable
 516
 517         \item
 518         @StaticRep@ may require slop if updatable. Non-updatable ones are OK.
 519
 520         \item
 521         @GenericRep@ closures will always be larger so never require slop.
 522         \end{itemize}
 523
 524         ***** ToDo: keep an eye on this!
 525 \end{itemize}
 526
 527 \begin{code}
 528 slopSize cl_info@(MkClosureInfo _ lf_info sm_rep)
 529   = computeSlopSize (closureGoodStuffSize cl_info) sm_rep (closureUpdReqd cl_info)
 530
 531 computeSlopSize :: Int -> SMRep -> Bool -> Int
 532
 533 computeSlopSize tot_wds (SpecialisedRep ConstantRep _ _ _) _
 534   = 0
 535 computeSlopSize tot_wds (SpecialisedRep CharLikeRep _ _ _) _
 536   = 0
 537
 538 computeSlopSize tot_wds (SpecialisedRep _ _ _ _) True   -- Updatable
 539   = max 0 (mIN_UPD_SIZE - tot_wds)
 540 computeSlopSize tot_wds (StaticRep _ _) True            -- Updatable
 541   = max 0 (mIN_UPD_SIZE - tot_wds)
 542 computeSlopSize tot_wds BlackHoleRep _                  -- Updatable
 543   = max 0 (mIN_UPD_SIZE - tot_wds)
 544
 545 computeSlopSize tot_wds (SpecialisedRep _ _ _ _) False  -- Not updatable
 546   = max 0 (mIN_SIZE_NonUpdHeapObject - tot_wds)
 547
 548 computeSlopSize tot_wds other_rep _                     -- Any other rep
 549   = 0
 550 \end{code}
 551
 552 %************************************************************************
 553 %*                                                                      *
 554 \subsection[layOutDynClosure]{Lay out a dynamic closure}
 555 %*                                                                      *
 556 %************************************************************************
 557
 558 \begin{code}
 559 layOutDynClosure, layOutStaticClosure
 560         :: Id                       -- STG identifier w/ which this closure assoc'd
 561         -> (a -> PrimRep)           -- function w/ which to be able to get a PrimRep
 562         -> [a]                      -- the "things" being layed out
 563         -> LambdaFormInfo           -- what sort of closure it is
 564         -> (ClosureInfo,            -- info about the closure
 565             [(a, VirtualHeapOffset)])   -- things w/ offsets pinned on them
 566
 567 layOutDynClosure name kind_fn things lf_info
 568   = (MkClosureInfo name lf_info sm_rep,
 569      things_w_offsets)
 570   where
 571     (tot_wds,            -- #ptr_wds + #nonptr_wds
 572      ptr_wds,            -- #ptr_wds
 573      things_w_offsets) = mkVirtHeapOffsets sm_rep kind_fn things
 574     sm_rep = chooseDynSMRep lf_info tot_wds ptr_wds
 575
 576 layOutStaticClosure name kind_fn things lf_info
 577   = (MkClosureInfo name lf_info (StaticRep ptr_wds (tot_wds - ptr_wds)),
 578      things_w_offsets)
 579   where
 580     (tot_wds,            -- #ptr_wds + #nonptr_wds
 581      ptr_wds,            -- #ptr_wds
 582      things_w_offsets) = mkVirtHeapOffsets (StaticRep bot bot) kind_fn things
 583     bot = panic "layoutStaticClosure"
 584
 585 layOutStaticNoFVClosure :: Id -> LambdaFormInfo -> ClosureInfo
 586 layOutStaticNoFVClosure name lf_info
 587   = MkClosureInfo name lf_info (StaticRep ptr_wds nonptr_wds)
 588  where
 589   -- I am very uncertain that this is right - it will show up when testing
 590   -- my dynamic loading code.  ADR
 591   -- (If it's not right, we'll have to grab the kinds of the arguments from
 592   --  somewhere.)
 593   ptr_wds = 0
 594   nonptr_wds = 0
 595
 596 layOutPhantomClosure :: Id -> LambdaFormInfo -> ClosureInfo
 597 layOutPhantomClosure name lf_info = MkClosureInfo name lf_info PhantomRep
 598 \end{code}
 599
 600 A wrapper for when used with data constructors:
 601 \begin{code}
 602 layOutDynCon :: DataCon
 603              -> (a -> PrimRep)
 604              -> [a]
 605              -> (ClosureInfo, [(a,VirtualHeapOffset)])
 606
 607 layOutDynCon con kind_fn args
 608   = ASSERT(isDataCon con)
 609     layOutDynClosure con kind_fn args (mkConLFInfo con)
 610 \end{code}
 611
 612
 613 %************************************************************************
 614 %*                                                                      *
 615 \subsection[SMreps]{Choosing SM reps}
 616 %*                                                                      *
 617 %************************************************************************
 618
 619 \begin{code}
 620 chooseDynSMRep
 621         :: LambdaFormInfo
 622         -> Int -> Int           -- Tot wds, ptr wds
 623         -> SMRep
 624
 625 chooseDynSMRep lf_info tot_wds ptr_wds
 626   = let
 627          nonptr_wds = tot_wds - ptr_wds
 628
 629          updatekind = case lf_info of
 630              LFThunk _ _ upd _  -> if upd then SMUpdatable else SMSingleEntry
 631              LFBlackHole        -> SMUpdatable
 632              _                  -> SMNormalForm
 633     in
 634     if (nonptr_wds == 0 && ptr_wds <= mAX_SPEC_ALL_PTRS)
 635             || (tot_wds <= mAX_SPEC_MIXED_FIELDS)
 636             || (ptr_wds == 0 && nonptr_wds <= mAX_SPEC_ALL_NONPTRS) then
 637         let
 638           spec_kind  = case lf_info of
 639
 640            (LFTuple _ True) -> ConstantRep
 641
 642            (LFTuple _ _)  -> SpecRep
 643
 644            (LFCon _ True) -> ConstantRep
 645
 646            (LFCon con _ ) -> if maybeToBool (maybeCharLikeTyCon tycon) then CharLikeRep
 647                              else if maybeToBool (maybeIntLikeTyCon tycon) then IntLikeRep
 648                              else SpecRep
 649                              where
 650                              tycon = dataConTyCon con
 651
 652            _              -> SpecRep
 653         in
 654         SpecialisedRep spec_kind ptr_wds nonptr_wds updatekind
 655     else
 656         GenericRep ptr_wds nonptr_wds updatekind
 657 \end{code}
 658
 659
 660 %************************************************************************
 661 %*                                                                      *
 662 \subsection[mkVirtHeapOffsets]{Assigning heap offsets in a closure}
 663 %*                                                                      *
 664 %************************************************************************
 665
 666 @mkVirtHeapOffsets@ (the heap version) always returns boxed things with
 667 smaller offsets than the unboxed things, and furthermore, the offsets in
 668 the result list
 669
 670 \begin{code}
 671 mkVirtHeapOffsets :: SMRep      -- Representation to be used by storage manager
 672           -> (a -> PrimRep)     -- To be able to grab kinds;
 673                                 --      w/ a kind, we can find boxedness
 674           -> [a]                -- Things to make offsets for
 675           -> (Int,              -- *Total* number of words allocated
 676               Int,              -- Number of words allocated for *pointers*
 677               [(a, VirtualHeapOffset)])
 678                                 -- Things with their offsets from start of object
 679                                 --      in order of increasing offset
 680
 681 -- First in list gets lowest offset, which is initial offset + 1.
 682
 683 mkVirtHeapOffsets sm_rep kind_fun things
 684   = let (ptrs, non_ptrs)              = separateByPtrFollowness kind_fun things
 685         (wds_of_ptrs, ptrs_w_offsets) = mapAccumL computeOffset 0 ptrs
 686         (tot_wds, non_ptrs_w_offsets) = mapAccumL computeOffset wds_of_ptrs non_ptrs
 687     in
 688         (tot_wds, wds_of_ptrs, ptrs_w_offsets ++ non_ptrs_w_offsets)
 689   where
 690     offset_of_first_word = totHdrSize sm_rep
 691     computeOffset wds_so_far thing
 692       = (wds_so_far + (getPrimRepSize . kind_fun) thing,
 693          (thing, (offset_of_first_word `addOff` (intOff wds_so_far)))
 694         )
 695 \end{code}
 696
 697 %************************************************************************
 698 %*                                                                      *
 699 \subsection[ClosureInfo-4-questions]{Four major questions about @ClosureInfo@}
 700 %*                                                                      *
 701 %************************************************************************
 702
 703 Be sure to see the stg-details notes about these...
 704
 705 \begin{code}
 706 nodeMustPointToIt :: LambdaFormInfo -> FCode Bool
 707 nodeMustPointToIt lf_info
 708   = let
 709         do_profiling = opt_SccProfilingOn
 710     in
 711     case lf_info of
 712         LFReEntrant top arity no_fvs -> returnFC (
 713             not no_fvs ||   -- Certainly if it has fvs we need to point to it
 714
 715             not top -- If it is not top level we will point to it
 716                     --   We can have a \r closure with no_fvs which
 717                     --   is not top level as special case cgRhsClosure
 718                     --   has been dissabled in favour of let floating
 719
 720                 -- For lex_profiling we also access the cost centre for a
 721                 -- non-inherited function i.e. not top level
 722                 -- the  not top  case above ensures this is ok.
 723             )
 724
 725         LFCon   _ zero_arity -> returnFC True
 726         LFTuple _ zero_arity -> returnFC True
 727
 728         -- Strictly speaking, the above two don't need Node to point
 729         -- to it if the arity = 0.  But this is a *really* unlikely
 730         -- situation.  If we know it's nil (say) and we are entering
 731         -- it. Eg: let x = [] in x then we will certainly have inlined
 732         -- x, since nil is a simple atom.  So we gain little by not
 733         -- having Node point to known zero-arity things.  On the other
 734         -- hand, we do lose something; Patrick's code for figuring out
 735         -- when something has been updated but not entered relies on
 736         -- having Node point to the result of an update.  SLPJ
 737         -- 27/11/92.
 738
 739         LFThunk _ no_fvs updatable NonStandardThunk
 740           -> returnFC (updatable || not no_fvs || do_profiling)
 741
 742           -- For the non-updatable (single-entry case):
 743           --
 744           -- True if has fvs (in which case we need access to them, and we
 745           --                should black-hole it)
 746           -- or profiling (in which case we need to recover the cost centre
 747           --             from inside it)
 748
 749         LFThunk _ no_fvs updatable some_standard_form_thunk
 750           -> returnFC True
 751           -- Node must point to any standard-form thunk.
 752           -- For example,
 753           --            x = f y
 754           -- generates a Vap thunk for (f y), and even if y is a global
 755           -- variable we must still make Node point to the thunk before entering it
 756           -- because that's what the standard-form code expects.
 757
 758         LFArgument  -> returnFC True
 759         LFImported  -> returnFC True
 760         LFBlackHole -> returnFC True
 761                     -- BH entry may require Node to point
 762
 763         LFLetNoEscape _ _ -> returnFC False
 764 \end{code}
 765
 766 The entry conventions depend on the type of closure being entered,
 767 whether or not it has free variables, and whether we're running
 768 sequentially or in parallel.
 769
 770 \begin{tabular}{lllll}
 771 Closure Characteristics & Parallel & Node Req'd & Argument Passing & Enter Via \\
 772 Unknown                         & no & yes & stack      & node \\
 773 Known fun ($\ge$ 1 arg), no fvs         & no & no  & registers  & fast entry (enough args) \\
 774 \ & \ & \ & \                                           & slow entry (otherwise) \\
 775 Known fun ($\ge$ 1 arg), fvs    & no & yes & registers  & fast entry (enough args) \\
 776 0 arg, no fvs @\r,\s@           & no & no  & n/a        & direct entry \\
 777 0 arg, no fvs @\u@              & no & yes & n/a        & node \\
 778 0 arg, fvs @\r,\s@              & no & yes & n/a        & direct entry \\
 779 0 arg, fvs @\u@                 & no & yes & n/a        & node \\
 780
 781 Unknown                         & yes & yes & stack     & node \\
 782 Known fun ($\ge$ 1 arg), no fvs         & yes & no  & registers & fast entry (enough args) \\
 783 \ & \ & \ & \                                           & slow entry (otherwise) \\
 784 Known fun ($\ge$ 1 arg), fvs    & yes & yes & registers & node \\
 785 0 arg, no fvs @\r,\s@           & yes & no  & n/a       & direct entry \\
 786 0 arg, no fvs @\u@              & yes & yes & n/a       & node \\
 787 0 arg, fvs @\r,\s@              & yes & yes & n/a       & node \\
 788 0 arg, fvs @\u@                 & yes & yes & n/a       & node\\
 789 \end{tabular}
 790
 791 When black-holing, single-entry closures could also be entered via node
 792 (rather than directly) to catch double-entry.
 793
 794 \begin{code}
 795 data EntryConvention
 796   = ViaNode                             -- The "normal" convention
 797
 798   | StdEntry CLabel                     -- Jump to this code, with args on stack
 799              (Maybe CLabel)             -- possibly setting infoptr to this
 800
 801   | DirectEntry                         -- Jump directly to code, with args in regs
 802         CLabel                          --   The code label
 803         Int                             --   Its arity
 804         [MagicId]                       --   Its register assignments (possibly empty)
 805
 806 getEntryConvention :: Id                -- Function being applied
 807                    -> LambdaFormInfo    -- Its info
 808                    -> [PrimRep]         -- Available arguments
 809                    -> FCode EntryConvention
 810
 811 getEntryConvention id lf_info arg_kinds
 812  =  nodeMustPointToIt lf_info   `thenFC` \ node_points ->
 813     let
 814         is_concurrent = opt_ForConcurrent
 815     in
 816     returnFC (
 817
 818     if (node_points && is_concurrent) then ViaNode else
 819
 820     case lf_info of
 821
 822         LFReEntrant _ arity _ ->
 823             if arity == 0 || (length arg_kinds) < arity then
 824                 StdEntry (mkStdEntryLabel id) Nothing
 825             else
 826                 DirectEntry (mkFastEntryLabel id arity) arity arg_regs
 827           where
 828             (arg_regs, _) = assignRegs live_regs (take arity arg_kinds)
 829             live_regs = if node_points then [node] else []
 830
 831         LFCon con zero_arity
 832                           -> let itbl = if zero_arity then
 833                                         mkPhantomInfoTableLabel con
 834                                         else
 835                                         mkConInfoTableLabel con
 836                              in
 837                              --false:ASSERT (null arg_kinds)    -- Should have no args (meaning what?)
 838                              StdEntry (mkConEntryLabel con) (Just itbl)
 839
 840         LFTuple tup zero_arity
 841                           -> --false:ASSERT (null arg_kinds)    -- Should have no args (meaning what?)
 842                              StdEntry (mkConEntryLabel tup) (Just (mkConInfoTableLabel tup))
 843
 844         LFThunk _ _ updatable std_form_info
 845           -> if updatable
 846              then ViaNode
 847              else StdEntry (thunkEntryLabel id std_form_info updatable) Nothing
 848
 849         LFArgument  -> ViaNode
 850         LFImported  -> ViaNode
 851         LFBlackHole -> ViaNode  -- Presumably the black hole has by now
 852                                 -- been updated, but we don't know with
 853                                 -- what, so we enter via Node
 854
 855         LFLetNoEscape arity _
 856           -> ASSERT(arity == length arg_kinds)
 857              DirectEntry (mkStdEntryLabel id) arity arg_regs
 858          where
 859             (arg_regs, _) = assignRegs live_regs arg_kinds
 860             live_regs     = if node_points then [node] else []
 861     )
 862
 863 blackHoleOnEntry :: Bool        -- No-black-holing flag
 864                  -> ClosureInfo
 865                  -> Bool
 866
 867 -- Static closures are never themselves black-holed.
 868 -- Updatable ones will be overwritten with a CAFList cell, which points to a black hole;
 869 -- Single-entry ones have no fvs to plug, and we trust they don't form part of a loop.
 870
 871 blackHoleOnEntry no_black_holing (MkClosureInfo _ _ (StaticRep _ _)) = False
 872
 873 blackHoleOnEntry no_black_holing (MkClosureInfo _ lf_info _)
 874   = case lf_info of
 875         LFReEntrant _ _ _         -> False
 876         LFThunk _ no_fvs updatable _
 877           -> if updatable
 878              then not no_black_holing
 879              else not no_fvs
 880         other -> panic "blackHoleOnEntry"       -- Should never happen
 881
 882 getStandardFormThunkInfo
 883         :: LambdaFormInfo
 884         -> Maybe [StgArg]               -- Nothing    => not a standard-form thunk
 885                                         -- Just atoms => a standard-form thunk with payload atoms
 886
 887 getStandardFormThunkInfo (LFThunk _ _ _ (SelectorThunk scrutinee _ _))
 888   = --trace "Selector thunk: missed opportunity to save info table + code"
 889     Nothing
 890         -- Just [StgVarArg scrutinee]
 891         -- We can't save the info tbl + code until we have a way to generate
 892         -- a fixed family thereof.
 893
 894 getStandardFormThunkInfo (LFThunk _ _ _ (VapThunk fun_id args fun_in_payload))
 895   | fun_in_payload = Just (StgVarArg fun_id : args)
 896   | otherwise      = Just args
 897
 898 getStandardFormThunkInfo other_lf_info = Nothing
 899
 900 maybeSelectorInfo (MkClosureInfo _ (LFThunk _ _ _ (SelectorThunk _ con offset)) _) = Just (con,offset)
 901 maybeSelectorInfo _ = Nothing
 902 \end{code}
 903
 904 Avoiding generating entries and info tables
 905 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 906 At present, for every function we generate all of the following,
 907 just in case.  But they aren't always all needed, as noted below:
 908
 909 [NB1: all of this applies only to *functions*.  Thunks always
 910 have closure, info table, and entry code.]
 911
 912 [NB2: All are needed if the function is *exported*, just to play safe.]
 913
 914
 915 * Fast-entry code  ALWAYS NEEDED
 916
 917 * Slow-entry code
 918         Needed iff (a) we have any un-saturated calls to the function
 919         OR         (b) the function is passed as an arg
 920         OR         (c) we're in the parallel world and the function has free vars
 921                         [Reason: in parallel world, we always enter functions
 922                         with free vars via the closure.]
 923
 924 * The function closure
 925         Needed iff (a) we have any un-saturated calls to the function
 926         OR         (b) the function is passed as an arg
 927         OR         (c) if the function has free vars (ie not top level)
 928
 929   Why case (a) here?  Because if the arg-satis check fails,
 930   UpdatePAP stuffs a pointer to the function closure in the PAP.
 931   [Could be changed; UpdatePAP could stuff in a code ptr instead,
 932    but doesn't seem worth it.]
 933
 934   [NB: these conditions imply that we might need the closure
 935   without the slow-entry code.  Here's how.
 936
 937         f x y = let g w = ...x..y..w...
 938                 in
 939                 ...(g t)...
 940
 941   Here we need a closure for g which contains x and y,
 942   but since the calls are all saturated we just jump to the
 943   fast entry point for g, with R1 pointing to the closure for g.]
 944
 945
 946 * Standard info table
 947         Needed iff (a) we have any un-saturated calls to the function
 948         OR         (b) the function is passed as an arg
 949         OR         (c) the function has free vars (ie not top level)
 950
 951         NB.  In the sequential world, (c) is only required so that the function closure has
 952         an info table to point to, to keep the storage manager happy.
 953         If (c) alone is true we could fake up an info table by choosing
 954         one of a standard family of info tables, whose entry code just
 955         bombs out.
 956
 957         [NB In the parallel world (c) is needed regardless because
 958         we enter functions with free vars via the closure.]
 959
 960         If (c) is retained, then we'll sometimes generate an info table
 961         (for storage mgr purposes) without slow-entry code.  Then we need
 962         to use an error label in the info table to substitute for the absent
 963         slow entry code.
 964
 965 * Standard vap-entry code
 966   Standard vap-entry info table
 967         Needed iff we have any updatable thunks of the standard vap-entry shape.
 968
 969 * Single-update vap-entry code
 970   Single-update vap-entry info table
 971         Needed iff we have any non-updatable thunks of the
 972         standard vap-entry shape.
 973
 974
 975 \begin{code}
 976 staticClosureRequired
 977         :: Id
 978         -> StgBinderInfo
 979         -> LambdaFormInfo
 980         -> Bool
 981 staticClosureRequired binder (StgBinderInfo arg_occ unsat_occ _ _ _)
 982                       (LFReEntrant top_level _ _)       -- It's a function
 983   = ASSERT( top_level )                 -- Assumption: it's a top-level, no-free-var binding
 984     arg_occ             -- There's an argument occurrence
 985     || unsat_occ        -- There's an unsaturated call
 986     || externallyVisibleId binder
 987
 988 staticClosureRequired binder other_binder_info other_lf_info = True
 989
 990 slowFunEntryCodeRequired        -- Assumption: it's a function, not a thunk.
 991         :: Id
 992         -> StgBinderInfo
 993         -> EntryConvention
 994         -> Bool
 995 slowFunEntryCodeRequired binder (StgBinderInfo arg_occ unsat_occ _ _ _) entry_conv
 996   = arg_occ             -- There's an argument occurrence
 997     || unsat_occ        -- There's an unsaturated call
 998     || externallyVisibleId binder
 999     || (case entry_conv of { DirectEntry _ _ _ -> False; other -> True })
1000             {- The last case deals with the parallel world; a function usually
1001                as a DirectEntry convention, but if it doesn't we must generate slow-entry code -}
1002
1003 slowFunEntryCodeRequired binder NoStgBinderInfo _ = True
1004
1005 funInfoTableRequired
1006         :: Id
1007         -> StgBinderInfo
1008         -> LambdaFormInfo
1009         -> Bool
1010 funInfoTableRequired  binder (StgBinderInfo arg_occ unsat_occ _ _ _)
1011                      (LFReEntrant top_level _ _)
1012   = not top_level
1013     || arg_occ          -- There's an argument occurrence
1014     || unsat_occ        -- There's an unsaturated call
1015     || externallyVisibleId binder
1016
1017 funInfoTableRequired other_binder_info binder other_lf_info = True
1018
1019 -- We need the vector-apply entry points for a function if
1020 -- there's a vector-apply occurrence in this module
1021
1022 stdVapRequired, noUpdVapRequired :: StgBinderInfo -> Bool
1023
1024 stdVapRequired binder_info
1025   = case binder_info of
1026       StgBinderInfo _ _ std_vap_occ _ _ -> std_vap_occ
1027       _                                 -> False
1028
1029 noUpdVapRequired binder_info
1030   = case binder_info of
1031       StgBinderInfo _ _ _ no_upd_vap_occ _ -> no_upd_vap_occ
1032       _                                    -> False
1033 \end{code}
1034
1035 @lfArity@ extracts the arity of a function from its LFInfo
1036
1037 \begin{code}
1038 {- Not needed any more
1039
1040 lfArity_maybe (LFReEntrant _ arity _) = Just arity
1041
1042 -- Removed SLPJ March 97. I don't believe these two;
1043 -- LFCon is used for construcor *applications*, not constructors!
1044 --
1045 -- lfArity_maybe (LFCon con _)        = Just (dataConArity con)
1046 -- lfArity_maybe (LFTuple con _)              = Just (dataConArity con)
1047
1048 lfArity_maybe other                   = Nothing
1049 -}
1050 \end{code}
1051
1052 %************************************************************************
1053 %*                                                                      *
1054 \subsection[ClosureInfo-misc-funs]{Misc functions about @ClosureInfo@, etc.}
1055 %*                                                                      *
1056 %************************************************************************
1057
1058 \begin{code}
1059
1060 isStaticClosure :: ClosureInfo -> Bool
1061 isStaticClosure  (MkClosureInfo _ _ rep) = isStaticRep  rep
1062
1063 closureId :: ClosureInfo -> Id
1064 closureId (MkClosureInfo id _ _) = id
1065
1066 closureSMRep :: ClosureInfo -> SMRep
1067 closureSMRep (MkClosureInfo _ _ sm_rep) = sm_rep
1068
1069 closureLFInfo :: ClosureInfo -> LambdaFormInfo
1070 closureLFInfo (MkClosureInfo _ lf_info _) = lf_info
1071
1072 closureUpdReqd :: ClosureInfo -> Bool
1073
1074 closureUpdReqd (MkClosureInfo _ (LFThunk _ _ upd _) _) = upd
1075 closureUpdReqd (MkClosureInfo _ LFBlackHole _)         = True
1076         -- Black-hole closures are allocated to receive the results of an
1077         -- alg case with a named default... so they need to be updated.
1078 closureUpdReqd other_closure                           = False
1079
1080 closureSingleEntry :: ClosureInfo -> Bool
1081
1082 closureSingleEntry (MkClosureInfo _ (LFThunk _ _ upd _) _) = not upd
1083 closureSingleEntry other_closure                           = False
1084 \end{code}
1085
1086 Note: @closureType@ returns appropriately specialised tycon and
1087 datacons.
1088 \begin{code}
1089 closureType :: ClosureInfo -> Maybe (TyCon, [Type], [Id])
1090
1091 -- First, a turgid special case.  When we are generating the
1092 -- standard code and info-table for Vaps (which is done when the function
1093 -- defn is encountered), we don't have a convenient Id to hand whose
1094 -- type is that of (f x y z).  So we need to figure out the type
1095 -- rather than take it from the Id. The Id is probably just "f"!
1096
1097 closureType (MkClosureInfo id (LFThunk _ _ _ (VapThunk fun_id args _)) _)
1098   = maybeAppSpecDataTyConExpandingDicts (fun_result_ty (length args) fun_id)
1099
1100 closureType (MkClosureInfo id lf _) = maybeAppSpecDataTyConExpandingDicts (idType id)
1101 \end{code}
1102
1103 @closureReturnsUnboxedType@ is used to check whether a closure, {\em
1104 once it has eaten its arguments}, returns an unboxed type.  For
1105 example, the closure for a function:
1106 \begin{verbatim}
1107         f :: Int -> Int#
1108 \end{verbatim}
1109 returns an unboxed type.  This is important when dealing with stack
1110 overflow checks.
1111 \begin{code}
1112 closureReturnsUnboxedType :: ClosureInfo -> Bool
1113
1114 closureReturnsUnboxedType (MkClosureInfo fun_id (LFReEntrant _ arity _) _)
1115   = isPrimType (fun_result_ty arity fun_id)
1116
1117 closureReturnsUnboxedType other_closure = False
1118         -- All non-function closures aren't functions,
1119         -- and hence are boxed, since they are heap alloc'd
1120
1121 -- ToDo: need anything like this in Type.lhs?
1122 fun_result_ty arity id
1123   = let
1124         (arg_tys, res_ty)  = splitFunTyExpandingDictsAndPeeking (idType id)
1125     in
1126 --    ASSERT(arity >= 0 && length arg_tys >= arity)
1127     (if (arity >= 0 && length arg_tys >= arity) then (\x->x) else pprPanic "fun_result_ty:" (hsep [int arity, ppr PprShowAll id, ppr PprDebug (idType id)])) $
1128     mkFunTys (drop arity arg_tys) res_ty
1129 \end{code}
1130
1131 \begin{code}
1132 closureSemiTag :: ClosureInfo -> Int
1133
1134 closureSemiTag (MkClosureInfo _ lf_info _)
1135   = case lf_info of
1136       LFCon data_con _ -> dataConTag data_con - fIRST_TAG
1137       LFTuple _ _      -> 0
1138       _                -> fromInteger oTHER_TAG
1139 \end{code}
1140
1141 \begin{code}
1142 isToplevClosure :: ClosureInfo -> Bool
1143
1144 isToplevClosure (MkClosureInfo _ lf_info _)
1145   = case lf_info of
1146       LFReEntrant top _ _ -> top
1147       LFThunk top _ _ _   -> top
1148       _ -> panic "ClosureInfo:isToplevClosure"
1149 \end{code}
1150
1151 Label generation.
1152
1153 \begin{code}
1154 fastLabelFromCI :: ClosureInfo -> CLabel
1155 fastLabelFromCI (MkClosureInfo id lf_info _)
1156 {-      [SLPJ Changed March 97]
1157          (was ok, but is the only call to lfArity,
1158           and the id should guarantee to have the correct arity in it.
1159
1160   = case lfArity_maybe lf_info of
1161         Just arity ->
1162 -}
1163   = case getIdArity id of
1164         ArityExactly arity -> mkFastEntryLabel id arity
1165         other              -> pprPanic "fastLabelFromCI" (ppr PprDebug id)
1166
1167 infoTableLabelFromCI :: ClosureInfo -> CLabel
1168 infoTableLabelFromCI (MkClosureInfo id lf_info rep)
1169   = case lf_info of
1170         LFCon con _     -> mkConInfoPtr con rep
1171         LFTuple tup _   -> mkConInfoPtr tup rep
1172
1173         LFBlackHole     -> mkBlackHoleInfoTableLabel
1174
1175         LFThunk _ _ upd_flag (VapThunk fun_id args _) -> mkVapInfoTableLabel fun_id upd_flag
1176                                         -- Use the standard vap info table
1177                                         -- for the function, rather than a one-off one
1178                                         -- for this particular closure
1179
1180 {-      For now, we generate individual info table and entry code for selector thunks,
1181         so their info table should be labelled in the standard way.
1182         The only special thing about them is that the info table has a field which
1183         tells the GC that it really is a selector.
1184
1185         Later, perhaps, we'll have some standard RTS code for selector-thunk info tables,
1186         in which case this line will spring back to life.
1187
1188         LFThunk _ _ upd_flag (SelectorThunk _ _ offset) -> mkSelectorInfoTableLabel upd_flag offset
1189                                         -- Ditto for selectors
1190 -}
1191
1192         other -> {-NO: if isStaticRep rep
1193                  then mkStaticInfoTableLabel id
1194                  else -} mkInfoTableLabel id
1195
1196 mkConInfoPtr :: Id -> SMRep -> CLabel
1197 mkConInfoPtr con rep
1198   = ASSERT(isDataCon con)
1199     case rep of
1200       PhantomRep    -> mkPhantomInfoTableLabel con
1201       StaticRep _ _ -> mkStaticInfoTableLabel  con
1202       _             -> mkConInfoTableLabel     con
1203
1204 mkConEntryPtr :: Id -> SMRep -> CLabel
1205 mkConEntryPtr con rep
1206   = ASSERT(isDataCon con)
1207     case rep of
1208       StaticRep _ _ -> mkStaticConEntryLabel con
1209       _             -> mkConEntryLabel con
1210
1211
1212 closureLabelFromCI (MkClosureInfo id _ rep)
1213         | isConstantRep rep
1214         = mkStaticClosureLabel id
1215         -- This case catches those pesky static closures for nullary constructors
1216
1217 closureLabelFromCI (MkClosureInfo id _ other_rep)   = mkClosureLabel id
1218
1219 entryLabelFromCI :: ClosureInfo -> CLabel
1220 entryLabelFromCI (MkClosureInfo id lf_info rep)
1221   = case lf_info of
1222         LFThunk _ _ upd_flag std_form_info -> thunkEntryLabel id std_form_info upd_flag
1223         LFCon con _                        -> mkConEntryPtr con rep
1224         LFTuple tup _                      -> mkConEntryPtr tup rep
1225         other                              -> mkStdEntryLabel id
1226
1227 -- thunkEntryLabel is a local help function, not exported.  It's used from both
1228 -- entryLabelFromCI and getEntryConvention.
1229 -- I don't think it needs to deal with the SelectorThunk case
1230 -- Well, it's falling over now, so I've made it deal with it.  (JSM)
1231
1232 thunkEntryLabel thunk_id (VapThunk fun_id args _) is_updatable
1233   = mkVapEntryLabel fun_id is_updatable
1234 thunkEntryLabel thunk_id _ is_updatable
1235   = mkStdEntryLabel thunk_id
1236 \end{code}
1237
1238 \begin{code}
1239 allocProfilingMsg :: ClosureInfo -> FAST_STRING
1240
1241 allocProfilingMsg (MkClosureInfo _ lf_info _)
1242   = case lf_info of
1243       LFReEntrant _ _ _         -> SLIT("ALLOC_FUN")
1244       LFCon _ _                 -> SLIT("ALLOC_CON")
1245       LFTuple _ _               -> SLIT("ALLOC_CON")
1246       LFThunk _ _ _ _           -> SLIT("ALLOC_THK")
1247       LFBlackHole               -> SLIT("ALLOC_BH")
1248       LFImported                -> panic "ALLOC_IMP"
1249 \end{code}
1250
1251 We need a black-hole closure info to pass to @allocDynClosure@ when we
1252 want to allocate the black hole on entry to a CAF.
1253
1254 \begin{code}
1255 blackHoleClosureInfo (MkClosureInfo id _ _)
1256   = MkClosureInfo id LFBlackHole BlackHoleRep
1257 \end{code}
1258
1259 The register liveness when returning from a constructor.  For
1260 simplicity, we claim just [node] is live for all but PhantomRep's.  In
1261 truth, this means that non-constructor info tables also claim node,
1262 but since their liveness information is never used, we don't care.
1263
1264 \begin{code}
1265 dataConLiveness (MkClosureInfo con _ PhantomRep)
1266   = case (dataReturnConvAlg con) of
1267       ReturnInRegs regs -> mkLiveRegsMask regs
1268       ReturnInHeap -> panic "dataConLiveness:PhantomRep in heap???"
1269
1270 dataConLiveness _ = mkLiveRegsMask [node]
1271 \end{code}
1272
1273 %************************************************************************
1274 %*                                                                      *
1275 \subsection[ClosureInfo-Profiling-funs]{Misc functions about for profiling info.}
1276 %*                                                                      *
1277 %************************************************************************
1278
1279 Profiling requires three pices of information to be determined for
1280 each closure's info table --- kind, description and type.
1281
1282 The description is stored directly in the @CClosureInfoTable@ when the
1283 info table is built.
1284
1285 The kind is determined from the @LambdaForm@ stored in the closure
1286 info using @closureKind@.
1287
1288 The type is determined from the type information stored with the @Id@
1289 in the closure info using @closureTypeDescr@.
1290
1291 \begin{code}
1292 closureKind :: ClosureInfo -> String
1293
1294 closureKind (MkClosureInfo _ lf _)
1295   = case lf of
1296       LFReEntrant _ n _         -> if n > 0 then "FN_K" else "THK_K"
1297       LFCon _ _                 -> "CON_K"
1298       LFTuple _ _               -> "CON_K"
1299       LFThunk _ _ _ _           -> "THK_K"
1300       LFBlackHole               -> "THK_K" -- consider BHs as thunks for the moment... (ToDo?)
1301       LFImported                -> panic "IMP_KIND"
1302
1303 closureTypeDescr :: ClosureInfo -> String
1304 closureTypeDescr (MkClosureInfo id lf _)
1305   = if (isDataCon id) then                       -- DataCon has function types
1306         getOccString (dataConTyCon id)           -- We want the TyCon not the ->
1307     else
1308         getTyDescription (idType id)
1309 \end{code}