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