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