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          ( 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
 104 getTyDescription = panic "ClosureInfo.getTyDescription (ToDo)"
 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 arityMaybe (getIdArity id) of
 367       Nothing   -> LFImported
 368       Just 0    -> LFThunk True{-top-lev-} True{-no fvs-}
 369                         True{-updatable-} NonStandardThunk
 370       Just n    -> LFReEntrant True n True  -- n > 0
 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                 -> StgExpr      -- Body of closure: passed so we
 387                                 -- can look for selector thunks!
 388                 -> LambdaFormInfo
 389
 390 mkClosureLFInfo top fvs upd_flag args@(_:_) body -- Non-empty args
 391   = LFReEntrant top (length args) (null fvs)
 392
 393 mkClosureLFInfo top fvs ReEntrant [] body
 394   = LFReEntrant top 0 (null fvs)
 395 \end{code}
 396
 397 OK, this is where we look at the body of the closure to see if it's a
 398 selector---turgid, but nothing deep.  We are looking for a closure of
 399 {\em exactly} the form:
 400 \begin{verbatim}
 401 ...  = [the_fv] \ u [] ->
 402          case the_fv of
 403            con a_1 ... a_n -> a_i
 404 \end{verbatim}
 405 Here we go:
 406 \begin{code}
 407 mkClosureLFInfo False       -- don't bother if at top-level
 408                 [the_fv]    -- just one...
 409                 Updatable
 410                 []          -- no args (a thunk)
 411                 (StgCase (StgApp (StgVarArg scrutinee) [{-no args-}] _)
 412                   _ _ _   -- ignore live vars and uniq...
 413                   (StgAlgAlts case_ty
 414                      [(con, params, use_mask,
 415                         (StgApp (StgVarArg selectee) [{-no args-}] _))]
 416                      StgNoDefault))
 417   |  the_fv == scrutinee                        -- Scrutinee is the only free variable
 418   && maybeToBool maybe_offset                   -- Selectee is a component of the tuple
 419   && maybeToBool offset_into_int_maybe
 420   && offset_into_int <= mAX_SPEC_SELECTEE_SIZE  -- Offset is small enough
 421   =
 422     -- ASSERT(is_single_constructor)            -- Should be true, by causes error for SpecTyCon
 423     LFThunk False False True (SelectorThunk scrutinee con offset_into_int)
 424   where
 425     (_, params_w_offsets) = layOutDynCon con idPrimRep params
 426     maybe_offset          = assocMaybe params_w_offsets selectee
 427     Just the_offset       = maybe_offset
 428     offset_into_int_maybe = intOffsetIntoGoods the_offset
 429     Just offset_into_int  = offset_into_int_maybe
 430     is_single_constructor = maybeToBool (maybeTyConSingleCon tycon)
 431     tycon                 = dataConTyCon con
 432 \end{code}
 433
 434 Same kind of thing, looking for vector-apply thunks, of the form:
 435
 436         x = [...] \ .. [] -> f a1 .. an
 437
 438 where f has arity n.  We rely on the arity info inside the Id being correct.
 439
 440 \begin{code}
 441 mkClosureLFInfo top_level
 442                 fvs
 443                 upd_flag
 444                 []                      -- No args; a thunk
 445                 (StgApp (StgVarArg fun_id) args _)
 446   | not top_level                       -- A top-level thunk would require a static
 447                                         -- vap_info table, which we don't generate just
 448                                         -- now; so top-level thunks are never standard
 449                                         -- form.
 450   && isLocallyDefined fun_id            -- Must be defined in this module
 451   && maybeToBool arity_maybe            -- A known function with known arity
 452   && fun_arity > 0                      -- It'd better be a function!
 453   && fun_arity == length args           -- Saturated application
 454   = LFThunk top_level (null fvs) (isUpdatable upd_flag) (VapThunk fun_id args store_fun_in_vap)
 455   where
 456     arity_maybe      = arityMaybe (getIdArity fun_id)
 457     Just fun_arity   = arity_maybe
 458
 459         -- If the function is a free variable then it must be stored
 460         -- in the thunk too; if it isn't a free variable it must be
 461         -- because it's constant, so it doesn't need to be stored in the thunk
 462     store_fun_in_vap = fun_id `is_elem` fvs
 463
 464     is_elem = isIn "mkClosureLFInfo"
 465 \end{code}
 466
 467 Finally, the general updatable-thing case:
 468 \begin{code}
 469 mkClosureLFInfo top fvs upd_flag [] body
 470   = LFThunk top (null fvs) (isUpdatable upd_flag) NonStandardThunk
 471
 472 isUpdatable ReEntrant   = False
 473 isUpdatable SingleEntry = False
 474 isUpdatable Updatable   = True
 475 \end{code}
 476
 477 @mkConLFInfo@ is similar, for constructors.
 478
 479 \begin{code}
 480 mkConLFInfo :: DataCon -> LambdaFormInfo
 481
 482 mkConLFInfo con
 483   = -- the isNullaryDataCon will do this: ASSERT(isDataCon con)
 484     (if isTupleCon con then LFTuple else LFCon) con (isNullaryDataCon con)
 485 \end{code}
 486
 487
 488 %************************************************************************
 489 %*                                                                      *
 490 \subsection[ClosureInfo-sizes]{Functions about closure {\em sizes}}
 491 %*                                                                      *
 492 %************************************************************************
 493
 494 \begin{code}
 495 closureSize :: ClosureInfo -> HeapOffset
 496 closureSize cl_info@(MkClosureInfo _ _ sm_rep)
 497   = totHdrSize sm_rep `addOff` (intOff (closureNonHdrSize cl_info))
 498
 499 closureSizeWithoutFixedHdr :: ClosureInfo -> HeapOffset
 500 closureSizeWithoutFixedHdr cl_info@(MkClosureInfo _ _ sm_rep)
 501   = varHdrSize sm_rep `addOff` (intOff (closureNonHdrSize cl_info))
 502
 503 closureHdrSize :: ClosureInfo -> HeapOffset
 504 closureHdrSize (MkClosureInfo _ _ sm_rep)
 505   = totHdrSize sm_rep
 506
 507 closureNonHdrSize :: ClosureInfo -> Int
 508 closureNonHdrSize cl_info@(MkClosureInfo _ lf_info sm_rep)
 509   = tot_wds + computeSlopSize tot_wds sm_rep (closureUpdReqd cl_info) --ToDo: pass lf_info?
 510   where
 511     tot_wds = closureGoodStuffSize cl_info
 512
 513 closureGoodStuffSize :: ClosureInfo -> Int
 514 closureGoodStuffSize (MkClosureInfo _ _ sm_rep)
 515   = let (ptrs, nonptrs) = sizes_from_SMRep sm_rep
 516     in  ptrs + nonptrs
 517
 518 closurePtrsSize :: ClosureInfo -> Int
 519 closurePtrsSize (MkClosureInfo _ _ sm_rep)
 520   = let (ptrs, _) = sizes_from_SMRep sm_rep
 521     in  ptrs
 522
 523 -- not exported:
 524 sizes_from_SMRep (SpecialisedRep k ptrs nonptrs _)   = (ptrs, nonptrs)
 525 sizes_from_SMRep (GenericRep       ptrs nonptrs _)   = (ptrs, nonptrs)
 526 sizes_from_SMRep (BigTupleRep      ptrs)             = (ptrs, 0)
 527 sizes_from_SMRep (MuTupleRep       ptrs)             = (ptrs, 0)
 528 sizes_from_SMRep (DataRep               nonptrs)     = (0, nonptrs)
 529 sizes_from_SMRep BlackHoleRep                        = (0, 0)
 530 sizes_from_SMRep (StaticRep        ptrs nonptrs)     = (ptrs, nonptrs)
 531 #ifdef DEBUG
 532 sizes_from_SMRep PhantomRep       = panic "sizes_from_SMRep: PhantomRep"
 533 sizes_from_SMRep DynamicRep       = panic "sizes_from_SMRep: DynamicRep"
 534 #endif
 535 \end{code}
 536
 537 \begin{code}
 538 fitsMinUpdSize :: ClosureInfo -> Bool
 539 fitsMinUpdSize (MkClosureInfo _ _ BlackHoleRep) = True
 540 fitsMinUpdSize cl_info = isSpecRep (closureSMRep cl_info) && closureNonHdrSize cl_info <= mIN_UPD_SIZE
 541 \end{code}
 542
 543 Computing slop size.  WARNING: this looks dodgy --- it has deep
 544 knowledge of what the storage manager does with the various
 545 representations...
 546
 547 Slop Requirements:
 548 \begin{itemize}
 549 \item
 550 Updateable closures must be @mIN_UPD_SIZE@.
 551         \begin{itemize}
 552         \item
 553         Cons cell requires 2 words
 554         \item
 555         Indirections require 1 word
 556         \item
 557         Appels collector indirections 2 words
 558         \end{itemize}
 559 THEREFORE: @mIN_UPD_SIZE = 2@.
 560
 561 \item
 562 Collectable closures which are allocated in the heap
 563 must be @mIN_SIZE_NonUpdHeapObject@.
 564
 565 Copying collector forward pointer requires 1 word
 566
 567 THEREFORE: @mIN_SIZE_NonUpdHeapObject = 1@
 568
 569 \item
 570 @SpecialisedRep@ closures closures may require slop:
 571         \begin{itemize}
 572         \item
 573         @ConstantRep@ and @CharLikeRep@ closures always use the address of
 574         a static closure. They are never allocated or
 575         collected (eg hold forwarding pointer) hence never any slop.
 576
 577         \item
 578         @IntLikeRep@ are never updatable.
 579         May need slop to be collected (as they will be size 1 or more
 580         this probably has no affect)
 581
 582         \item
 583         @SpecRep@ may be updateable and will be collectable
 584
 585         \item
 586         @StaticRep@ may require slop if updatable. Non-updatable ones are OK.
 587
 588         \item
 589         @GenericRep@ closures will always be larger so never require slop.
 590         \end{itemize}
 591
 592         ***** ToDo: keep an eye on this!
 593 \end{itemize}
 594
 595 \begin{code}
 596 slopSize cl_info@(MkClosureInfo _ lf_info sm_rep)
 597   = computeSlopSize (closureGoodStuffSize cl_info) sm_rep (closureUpdReqd cl_info)
 598
 599 computeSlopSize :: Int -> SMRep -> Bool -> Int
 600
 601 computeSlopSize tot_wds (SpecialisedRep ConstantRep _ _ _) _
 602   = 0
 603 computeSlopSize tot_wds (SpecialisedRep CharLikeRep _ _ _) _
 604   = 0
 605
 606 computeSlopSize tot_wds (SpecialisedRep _ _ _ _) True   -- Updatable
 607   = max 0 (mIN_UPD_SIZE - tot_wds)
 608 computeSlopSize tot_wds (StaticRep _ _) True            -- Updatable
 609   = max 0 (mIN_UPD_SIZE - tot_wds)
 610 computeSlopSize tot_wds BlackHoleRep _                  -- Updatable
 611   = max 0 (mIN_UPD_SIZE - tot_wds)
 612
 613 computeSlopSize tot_wds (SpecialisedRep _ _ _ _) False  -- Not updatable
 614   = max 0 (mIN_SIZE_NonUpdHeapObject - tot_wds)
 615
 616 computeSlopSize tot_wds other_rep _                     -- Any other rep
 617   = 0
 618 \end{code}
 619
 620 %************************************************************************
 621 %*                                                                      *
 622 \subsection[layOutDynClosure]{Lay out a dynamic closure}
 623 %*                                                                      *
 624 %************************************************************************
 625
 626 \begin{code}
 627 layOutDynClosure, layOutStaticClosure
 628         :: Id                       -- STG identifier w/ which this closure assoc'd
 629         -> (a -> PrimRep)           -- function w/ which to be able to get a PrimRep
 630         -> [a]                      -- the "things" being layed out
 631         -> LambdaFormInfo           -- what sort of closure it is
 632         -> (ClosureInfo,            -- info about the closure
 633             [(a, VirtualHeapOffset)])   -- things w/ offsets pinned on them
 634
 635 layOutDynClosure name kind_fn things lf_info
 636   = (MkClosureInfo name lf_info sm_rep,
 637      things_w_offsets)
 638   where
 639     (tot_wds,            -- #ptr_wds + #nonptr_wds
 640      ptr_wds,            -- #ptr_wds
 641      things_w_offsets) = mkVirtHeapOffsets sm_rep kind_fn things
 642     sm_rep = chooseDynSMRep lf_info tot_wds ptr_wds
 643
 644 layOutStaticClosure name kind_fn things lf_info
 645   = (MkClosureInfo name lf_info (StaticRep ptr_wds (tot_wds - ptr_wds)),
 646      things_w_offsets)
 647   where
 648     (tot_wds,            -- #ptr_wds + #nonptr_wds
 649      ptr_wds,            -- #ptr_wds
 650      things_w_offsets) = mkVirtHeapOffsets (StaticRep bot bot) kind_fn things
 651     bot = panic "layoutStaticClosure"
 652
 653 layOutStaticNoFVClosure :: Id -> LambdaFormInfo -> ClosureInfo
 654 layOutStaticNoFVClosure name lf_info
 655   = MkClosureInfo name lf_info (StaticRep ptr_wds nonptr_wds)
 656  where
 657   -- I am very uncertain that this is right - it will show up when testing
 658   -- my dynamic loading code.  ADR
 659   -- (If it's not right, we'll have to grab the kinds of the arguments from
 660   --  somewhere.)
 661   ptr_wds = 0
 662   nonptr_wds = 0
 663
 664 layOutPhantomClosure :: Id -> LambdaFormInfo -> ClosureInfo
 665 layOutPhantomClosure name lf_info = MkClosureInfo name lf_info PhantomRep
 666 \end{code}
 667
 668 A wrapper for when used with data constructors:
 669 \begin{code}
 670 layOutDynCon :: DataCon
 671              -> (a -> PrimRep)
 672              -> [a]
 673              -> (ClosureInfo, [(a,VirtualHeapOffset)])
 674
 675 layOutDynCon con kind_fn args
 676   = ASSERT(isDataCon con)
 677     layOutDynClosure con kind_fn args (mkConLFInfo con)
 678 \end{code}
 679
 680
 681 %************************************************************************
 682 %*                                                                      *
 683 \subsection[SMreps]{Choosing SM reps}
 684 %*                                                                      *
 685 %************************************************************************
 686
 687 \begin{code}
 688 chooseDynSMRep
 689         :: LambdaFormInfo
 690         -> Int -> Int           -- Tot wds, ptr wds
 691         -> SMRep
 692
 693 chooseDynSMRep lf_info tot_wds ptr_wds
 694   = let
 695          nonptr_wds = tot_wds - ptr_wds
 696
 697          updatekind = case lf_info of
 698              LFThunk _ _ upd _  -> if upd then SMUpdatable else SMSingleEntry
 699              LFBlackHole        -> SMUpdatable
 700              _                  -> SMNormalForm
 701     in
 702     if (nonptr_wds == 0 && ptr_wds <= mAX_SPEC_ALL_PTRS)
 703             || (tot_wds <= mAX_SPEC_MIXED_FIELDS)
 704             || (ptr_wds == 0 && nonptr_wds <= mAX_SPEC_ALL_NONPTRS) then
 705         let
 706           spec_kind  = case lf_info of
 707
 708            (LFTuple _ True) -> ConstantRep
 709
 710            (LFTuple _ _)  -> SpecRep
 711
 712            (LFCon _ True) -> ConstantRep
 713
 714            (LFCon con _ ) -> if maybeToBool (maybeCharLikeTyCon tycon) then CharLikeRep
 715                              else if maybeToBool (maybeIntLikeTyCon tycon) then IntLikeRep
 716                              else SpecRep
 717                              where
 718                              tycon = dataConTyCon con
 719
 720            _              -> SpecRep
 721         in
 722         SpecialisedRep spec_kind ptr_wds nonptr_wds updatekind
 723     else
 724         GenericRep ptr_wds nonptr_wds updatekind
 725 \end{code}
 726
 727
 728 %************************************************************************
 729 %*                                                                      *
 730 \subsection[mkVirtHeapOffsets]{Assigning heap offsets in a closure}
 731 %*                                                                      *
 732 %************************************************************************
 733
 734 @mkVirtHeapOffsets@ (the heap version) always returns boxed things with
 735 smaller offsets than the unboxed things, and furthermore, the offsets in
 736 the result list
 737
 738 \begin{code}
 739 mkVirtHeapOffsets :: SMRep      -- Representation to be used by storage manager
 740           -> (a -> PrimRep)     -- To be able to grab kinds;
 741                                 --      w/ a kind, we can find boxedness
 742           -> [a]                -- Things to make offsets for
 743           -> (Int,              -- *Total* number of words allocated
 744               Int,              -- Number of words allocated for *pointers*
 745               [(a, VirtualHeapOffset)])
 746                                 -- Things with their offsets from start of object
 747                                 --      in order of increasing offset
 748
 749 -- First in list gets lowest offset, which is initial offset + 1.
 750
 751 mkVirtHeapOffsets sm_rep kind_fun things
 752   = let (ptrs, non_ptrs)              = separateByPtrFollowness kind_fun things
 753         (wds_of_ptrs, ptrs_w_offsets) = mapAccumL computeOffset 0 ptrs
 754         (tot_wds, non_ptrs_w_offsets) = mapAccumL computeOffset wds_of_ptrs non_ptrs
 755     in
 756         (tot_wds, wds_of_ptrs, ptrs_w_offsets ++ non_ptrs_w_offsets)
 757   where
 758     offset_of_first_word = totHdrSize sm_rep
 759     computeOffset wds_so_far thing
 760       = (wds_so_far + (getPrimRepSize . kind_fun) thing,
 761          (thing, (offset_of_first_word `addOff` (intOff wds_so_far)))
 762         )
 763 \end{code}
 764
 765 %************************************************************************
 766 %*                                                                      *
 767 \subsection[ClosureInfo-4-questions]{Four major questions about @ClosureInfo@}
 768 %*                                                                      *
 769 %************************************************************************
 770
 771 Be sure to see the stg-details notes about these...
 772
 773 \begin{code}
 774 nodeMustPointToIt :: LambdaFormInfo -> FCode Bool
 775 nodeMustPointToIt lf_info
 776   = let
 777         do_profiling = opt_SccProfilingOn
 778     in
 779     case lf_info of
 780         LFReEntrant top arity no_fvs -> returnFC (
 781             not no_fvs ||   -- Certainly if it has fvs we need to point to it
 782
 783             not top -- If it is not top level we will point to it
 784                     --   We can have a \r closure with no_fvs which
 785                     --   is not top level as special case cgRhsClosure
 786                     --   has been dissabled in favour of let floating
 787
 788                 -- For lex_profiling we also access the cost centre for a
 789                 -- non-inherited function i.e. not top level
 790                 -- the  not top  case above ensures this is ok.
 791             )
 792
 793         LFCon   _ zero_arity -> returnFC True
 794         LFTuple _ zero_arity -> returnFC True
 795
 796         -- Strictly speaking, the above two don't need Node to point
 797         -- to it if the arity = 0.  But this is a *really* unlikely
 798         -- situation.  If we know it's nil (say) and we are entering
 799         -- it. Eg: let x = [] in x then we will certainly have inlined
 800         -- x, since nil is a simple atom.  So we gain little by not
 801         -- having Node point to known zero-arity things.  On the other
 802         -- hand, we do lose something; Patrick's code for figuring out
 803         -- when something has been updated but not entered relies on
 804         -- having Node point to the result of an update.  SLPJ
 805         -- 27/11/92.
 806
 807         LFThunk _ no_fvs updatable _
 808           -> returnFC (updatable || not no_fvs || do_profiling)
 809
 810           -- For the non-updatable (single-entry case):
 811           --
 812           -- True if has fvs (in which case we need access to them, and we
 813           --                should black-hole it)
 814           -- or profiling (in which case we need to recover the cost centre
 815           --             from inside it)
 816
 817         LFArgument  -> returnFC True
 818         LFImported  -> returnFC True
 819         LFBlackHole -> returnFC True
 820                     -- BH entry may require Node to point
 821
 822         LFLetNoEscape _ _ -> returnFC False
 823 \end{code}
 824
 825 The entry conventions depend on the type of closure being entered,
 826 whether or not it has free variables, and whether we're running
 827 sequentially or in parallel.
 828
 829 \begin{tabular}{lllll}
 830 Closure Characteristics & Parallel & Node Req'd & Argument Passing & Enter Via \\
 831 Unknown                         & no & yes & stack      & node \\
 832 Known fun ($\ge$ 1 arg), no fvs         & no & no  & registers  & fast entry (enough args) \\
 833 \ & \ & \ & \                                           & slow entry (otherwise) \\
 834 Known fun ($\ge$ 1 arg), fvs    & no & yes & registers  & fast entry (enough args) \\
 835 0 arg, no fvs @\r,\s@           & no & no  & n/a        & direct entry \\
 836 0 arg, no fvs @\u@              & no & yes & n/a        & node \\
 837 0 arg, fvs @\r,\s@              & no & yes & n/a        & direct entry \\
 838 0 arg, fvs @\u@                 & no & yes & n/a        & node \\
 839
 840 Unknown                         & yes & yes & stack     & node \\
 841 Known fun ($\ge$ 1 arg), no fvs         & yes & no  & registers & fast entry (enough args) \\
 842 \ & \ & \ & \                                           & slow entry (otherwise) \\
 843 Known fun ($\ge$ 1 arg), fvs    & yes & yes & registers & node \\
 844 0 arg, no fvs @\r,\s@           & yes & no  & n/a       & direct entry \\
 845 0 arg, no fvs @\u@              & yes & yes & n/a       & node \\
 846 0 arg, fvs @\r,\s@              & yes & yes & n/a       & node \\
 847 0 arg, fvs @\u@                 & yes & yes & n/a       & node\\
 848 \end{tabular}
 849
 850 When black-holing, single-entry closures could also be entered via node
 851 (rather than directly) to catch double-entry.
 852
 853 \begin{code}
 854 data EntryConvention
 855   = ViaNode                             -- The "normal" convention
 856
 857   | StdEntry CLabel                     -- Jump to this code, with args on stack
 858              (Maybe CLabel)             -- possibly setting infoptr to this
 859
 860   | DirectEntry                         -- Jump directly to code, with args in regs
 861         CLabel                          --   The code label
 862         Int                             --   Its arity
 863         [MagicId]                       --   Its register assignments (possibly empty)
 864
 865 getEntryConvention :: Id                -- Function being applied
 866                    -> LambdaFormInfo    -- Its info
 867                    -> [PrimRep]         -- Available arguments
 868                    -> FCode EntryConvention
 869
 870 getEntryConvention id lf_info arg_kinds
 871  =  nodeMustPointToIt lf_info   `thenFC` \ node_points ->
 872     let
 873         is_concurrent = opt_ForConcurrent
 874     in
 875     returnFC (
 876
 877     if (node_points && is_concurrent) then ViaNode else
 878
 879     case lf_info of
 880
 881         LFReEntrant _ arity _ ->
 882             if arity == 0 || (length arg_kinds) < arity then
 883                 StdEntry (mkStdEntryLabel id) Nothing
 884             else
 885                 DirectEntry (mkFastEntryLabel id arity) arity arg_regs
 886           where
 887             (arg_regs, _) = assignRegs live_regs (take arity arg_kinds)
 888             live_regs = if node_points then [node] else []
 889
 890         LFCon con zero_arity
 891                           -> let itbl = if zero_arity then
 892                                         mkPhantomInfoTableLabel con
 893                                         else
 894                                         mkConInfoTableLabel con
 895                              in
 896                              --false:ASSERT (null arg_kinds)    -- Should have no args (meaning what?)
 897                              StdEntry (mkConEntryLabel con) (Just itbl)
 898
 899         LFTuple tup zero_arity
 900                           -> --false:ASSERT (null arg_kinds)    -- Should have no args (meaning what?)
 901                              StdEntry (mkConEntryLabel tup) (Just (mkConInfoTableLabel tup))
 902
 903         LFThunk _ _ updatable std_form_info
 904           -> if updatable
 905              then ViaNode
 906              else StdEntry (thunkEntryLabel id std_form_info updatable) Nothing
 907
 908         LFArgument  -> ViaNode
 909         LFImported  -> ViaNode
 910         LFBlackHole -> ViaNode  -- Presumably the black hole has by now
 911                                 -- been updated, but we don't know with
 912                                 -- what, so we enter via Node
 913
 914         LFLetNoEscape arity _
 915           -> ASSERT(arity == length arg_kinds)
 916              DirectEntry (mkStdEntryLabel id) arity arg_regs
 917          where
 918             (arg_regs, _) = assignRegs live_regs arg_kinds
 919             live_regs     = if node_points then [node] else []
 920     )
 921
 922 blackHoleOnEntry :: Bool        -- No-black-holing flag
 923                  -> ClosureInfo
 924                  -> Bool
 925
 926 -- Static closures are never themselves black-holed.
 927 -- Updatable ones will be overwritten with a CAFList cell, which points to a black hole;
 928 -- Single-entry ones have no fvs to plug, and we trust they don't form part of a loop.
 929
 930 blackHoleOnEntry no_black_holing (MkClosureInfo _ _ (StaticRep _ _)) = False
 931
 932 blackHoleOnEntry no_black_holing (MkClosureInfo _ lf_info _)
 933   = case lf_info of
 934         LFReEntrant _ _ _         -> False
 935         LFThunk _ no_fvs updatable _
 936           -> if updatable
 937              then not no_black_holing
 938              else not no_fvs
 939         other -> panic "blackHoleOnEntry"       -- Should never happen
 940
 941 getStandardFormThunkInfo
 942         :: LambdaFormInfo
 943         -> Maybe [StgArg]               -- Nothing    => not a standard-form thunk
 944                                         -- Just atoms => a standard-form thunk with payload atoms
 945
 946 getStandardFormThunkInfo (LFThunk _ _ _ (SelectorThunk scrutinee _ _))
 947   = --trace "Selector thunk: missed opportunity to save info table + code"
 948     Nothing
 949         -- Just [StgVarArg scrutinee]
 950         -- We can't save the info tbl + code until we have a way to generate
 951         -- a fixed family thereof.
 952
 953 getStandardFormThunkInfo (LFThunk _ _ _ (VapThunk fun_id args fun_in_payload))
 954   | fun_in_payload = Just (StgVarArg fun_id : args)
 955   | otherwise      = Just args
 956
 957 getStandardFormThunkInfo other_lf_info = Nothing
 958
 959 maybeSelectorInfo (MkClosureInfo _ (LFThunk _ _ _ (SelectorThunk _ con offset)) _) = Just (con,offset)
 960 maybeSelectorInfo _ = Nothing
 961 \end{code}
 962
 963 Avoiding generating entries and info tables
 964 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 965 At present, for every function we generate all of the following,
 966 just in case.  But they aren't always all needed, as noted below:
 967
 968 [NB1: all of this applies only to *functions*.  Thunks always
 969 have closure, info table, and entry code.]
 970
 971 [NB2: All are needed if the function is *exported*, just to play safe.]
 972
 973
 974 * Fast-entry code  ALWAYS NEEDED
 975
 976 * Slow-entry code
 977         Needed iff (a) we have any un-saturated calls to the function
 978         OR         (b) the function is passed as an arg
 979         OR         (c) we're in the parallel world and the function has free vars
 980                         [Reason: in parallel world, we always enter functions
 981                         with free vars via the closure.]
 982
 983 * The function closure
 984         Needed iff (a) we have any un-saturated calls to the function
 985         OR         (b) the function is passed as an arg
 986         OR         (c) if the function has free vars (ie not top level)
 987
 988   Why case (a) here?  Because if the arg-satis check fails,
 989   UpdatePAP stuffs a pointer to the function closure in the PAP.
 990   [Could be changed; UpdatePAP could stuff in a code ptr instead,
 991    but doesn't seem worth it.]
 992
 993   [NB: these conditions imply that we might need the closure
 994   without the slow-entry code.  Here's how.
 995
 996         f x y = let g w = ...x..y..w...
 997                 in
 998                 ...(g t)...
 999
1000   Here we need a closure for g which contains x and y,
1001   but since the calls are all saturated we just jump to the
1002   fast entry point for g, with R1 pointing to the closure for g.]
1003
1004
1005 * Standard info table
1006         Needed iff (a) we have any un-saturated calls to the function
1007         OR         (b) the function is passed as an arg
1008         OR         (c) the function has free vars (ie not top level)
1009
1010         NB.  In the sequential world, (c) is only required so that the function closure has
1011         an info table to point to, to keep the storage manager happy.
1012         If (c) alone is true we could fake up an info table by choosing
1013         one of a standard family of info tables, whose entry code just
1014         bombs out.
1015
1016         [NB In the parallel world (c) is needed regardless because
1017         we enter functions with free vars via the closure.]
1018
1019         If (c) is retained, then we'll sometimes generate an info table
1020         (for storage mgr purposes) without slow-entry code.  Then we need
1021         to use an error label in the info table to substitute for the absent
1022         slow entry code.
1023
1024 * Standard vap-entry code
1025   Standard vap-entry info table
1026         Needed iff we have any updatable thunks of the standard vap-entry shape.
1027
1028 * Single-update vap-entry code
1029   Single-update vap-entry info table
1030         Needed iff we have any non-updatable thunks of the
1031         standard vap-entry shape.
1032
1033
1034 \begin{code}
1035 staticClosureRequired
1036         :: Id
1037         -> StgBinderInfo
1038         -> LambdaFormInfo
1039         -> Bool
1040 staticClosureRequired binder (StgBinderInfo arg_occ unsat_occ _ _ _)
1041                       (LFReEntrant top_level _ _)       -- It's a function
1042   = ASSERT( top_level )                 -- Assumption: it's a top-level, no-free-var binding
1043     arg_occ             -- There's an argument occurrence
1044     || unsat_occ        -- There's an unsaturated call
1045     || externallyVisibleId binder
1046
1047 staticClosureRequired binder other_binder_info other_lf_info = True
1048
1049 slowFunEntryCodeRequired        -- Assumption: it's a function, not a thunk.
1050         :: Id
1051         -> StgBinderInfo
1052         -> Bool
1053 slowFunEntryCodeRequired binder (StgBinderInfo arg_occ unsat_occ _ _ _)
1054   = arg_occ             -- There's an argument occurrence
1055     || unsat_occ        -- There's an unsaturated call
1056     || externallyVisibleId binder
1057     {- HAS FREE VARS AND IS PARALLEL WORLD -}
1058
1059 slowFunEntryCodeRequired binder NoStgBinderInfo = True
1060
1061 funInfoTableRequired
1062         :: Id
1063         -> StgBinderInfo
1064         -> LambdaFormInfo
1065         -> Bool
1066 funInfoTableRequired  binder (StgBinderInfo arg_occ unsat_occ _ _ _)
1067                      (LFReEntrant top_level _ _)
1068   = not top_level
1069     || arg_occ          -- There's an argument occurrence
1070     || unsat_occ        -- There's an unsaturated call
1071     || externallyVisibleId binder
1072
1073 funInfoTableRequired other_binder_info binder other_lf_info = True
1074
1075 -- We need the vector-apply entry points for a function if
1076 -- there's a vector-apply occurrence in this module
1077
1078 stdVapRequired, noUpdVapRequired :: StgBinderInfo -> Bool
1079
1080 stdVapRequired binder_info
1081   = case binder_info of
1082       StgBinderInfo _ _ std_vap_occ _ _ -> std_vap_occ
1083       _                                 -> False
1084
1085 noUpdVapRequired binder_info
1086   = case binder_info of
1087       StgBinderInfo _ _ _ no_upd_vap_occ _ -> no_upd_vap_occ
1088       _                                    -> False
1089 \end{code}
1090
1091 %************************************************************************
1092 %*                                                                      *
1093 \subsection[ClosureInfo-misc-funs]{Misc functions about @ClosureInfo@, etc.}
1094 %*                                                                      *
1095 %************************************************************************
1096
1097 \begin{code}
1098
1099 isStaticClosure :: ClosureInfo -> Bool
1100 isStaticClosure  (MkClosureInfo _ _ rep) = isStaticRep  rep
1101
1102 closureId :: ClosureInfo -> Id
1103 closureId (MkClosureInfo id _ _) = id
1104
1105 closureSMRep :: ClosureInfo -> SMRep
1106 closureSMRep (MkClosureInfo _ _ sm_rep) = sm_rep
1107
1108 closureLFInfo :: ClosureInfo -> LambdaFormInfo
1109 closureLFInfo (MkClosureInfo _ lf_info _) = lf_info
1110
1111 closureUpdReqd :: ClosureInfo -> Bool
1112
1113 closureUpdReqd (MkClosureInfo _ (LFThunk _ _ upd _) _) = upd
1114 closureUpdReqd (MkClosureInfo _ LFBlackHole _)         = True
1115         -- Black-hole closures are allocated to receive the results of an
1116         -- alg case with a named default... so they need to be updated.
1117 closureUpdReqd other_closure                           = False
1118
1119 closureSingleEntry :: ClosureInfo -> Bool
1120
1121 closureSingleEntry (MkClosureInfo _ (LFThunk _ _ upd _) _) = not upd
1122 closureSingleEntry other_closure                           = False
1123 \end{code}
1124
1125 Note: @closureType@ returns appropriately specialised tycon and
1126 datacons.
1127 \begin{code}
1128 closureType :: ClosureInfo -> Maybe (TyCon, [Type], [Id])
1129
1130 -- First, a turgid special case.  When we are generating the
1131 -- standard code and info-table for Vaps (which is done when the function
1132 -- defn is encountered), we don't have a convenient Id to hand whose
1133 -- type is that of (f x y z).  So we need to figure out the type
1134 -- rather than take it from the Id. The Id is probably just "f"!
1135
1136 closureType (MkClosureInfo id (LFThunk _ _ _ (VapThunk fun_id args _)) _)
1137   = maybeAppSpecDataTyConExpandingDicts (fun_result_ty (length args) fun_id)
1138
1139 closureType (MkClosureInfo id lf _) = maybeAppSpecDataTyConExpandingDicts (idType id)
1140 \end{code}
1141
1142 @closureReturnsUnboxedType@ is used to check whether a closure, {\em
1143 once it has eaten its arguments}, returns an unboxed type.  For
1144 example, the closure for a function:
1145 \begin{verbatim}
1146         f :: Int -> Int#
1147 \end{verbatim}
1148 returns an unboxed type.  This is important when dealing with stack
1149 overflow checks.
1150 \begin{code}
1151 closureReturnsUnboxedType :: ClosureInfo -> Bool
1152
1153 closureReturnsUnboxedType (MkClosureInfo fun_id (LFReEntrant _ arity _) _)
1154   = isPrimType (fun_result_ty arity fun_id)
1155
1156 closureReturnsUnboxedType other_closure = False
1157         -- All non-function closures aren't functions,
1158         -- and hence are boxed, since they are heap alloc'd
1159
1160 -- ToDo: need anything like this in Type.lhs?
1161 fun_result_ty arity id
1162   = let
1163         (_, de_foralld_ty) = splitForAllTy (idType id)
1164         (arg_tys, res_ty)  = splitFunTyExpandingDictsAndPeeking de_foralld_ty
1165     in
1166     -- ASSERT(arity >= 0 && length arg_tys >= arity)
1167     (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)])) $
1168     mkFunTys (drop arity arg_tys) res_ty
1169 \end{code}
1170
1171 \begin{code}
1172 closureSemiTag :: ClosureInfo -> Int
1173
1174 closureSemiTag (MkClosureInfo _ lf_info _)
1175   = case lf_info of
1176       LFCon data_con _ -> dataConTag data_con - fIRST_TAG
1177       LFTuple _ _      -> 0
1178       _                -> fromInteger oTHER_TAG
1179 \end{code}
1180
1181 \begin{code}
1182 isToplevClosure :: ClosureInfo -> Bool
1183
1184 isToplevClosure (MkClosureInfo _ lf_info _)
1185   = case lf_info of
1186       LFReEntrant top _ _ -> top
1187       LFThunk top _ _ _   -> top
1188       _ -> panic "ClosureInfo:isToplevClosure"
1189 \end{code}
1190
1191 Label generation.
1192
1193 \begin{code}
1194 infoTableLabelFromCI :: ClosureInfo -> CLabel
1195
1196 infoTableLabelFromCI (MkClosureInfo id lf_info rep)
1197   = case lf_info of
1198         LFCon con _     -> mkConInfoPtr con rep
1199         LFTuple tup _   -> mkConInfoPtr tup rep
1200
1201         LFBlackHole     -> mkBlackHoleInfoTableLabel
1202
1203         LFThunk _ _ upd_flag (VapThunk fun_id args _) -> mkVapInfoTableLabel fun_id upd_flag
1204                                         -- Use the standard vap info table
1205                                         -- for the function, rather than a one-off one
1206                                         -- for this particular closure
1207
1208 {-      For now, we generate individual info table and entry code for selector thunks,
1209         so their info table should be labelled in the standard way.
1210         The only special thing about them is that the info table has a field which
1211         tells the GC that it really is a selector.
1212
1213         Later, perhaps, we'll have some standard RTS code for selector-thunk info tables,
1214         in which case this line will spring back to life.
1215
1216         LFThunk _ _ upd_flag (SelectorThunk _ _ offset) -> mkSelectorInfoTableLabel upd_flag offset
1217                                         -- Ditto for selectors
1218 -}
1219
1220         other -> {-NO: if isStaticRep rep
1221                  then mkStaticInfoTableLabel id
1222                  else -} mkInfoTableLabel id
1223
1224 mkConInfoPtr :: Id -> SMRep -> CLabel
1225 mkConInfoPtr con rep
1226   = ASSERT(isDataCon con)
1227     case rep of
1228       PhantomRep    -> mkPhantomInfoTableLabel con
1229       StaticRep _ _ -> mkStaticInfoTableLabel  con
1230       _             -> mkConInfoTableLabel     con
1231
1232 mkConEntryPtr :: Id -> SMRep -> CLabel
1233 mkConEntryPtr con rep
1234   = ASSERT(isDataCon con)
1235     case rep of
1236       StaticRep _ _ -> mkStaticConEntryLabel con
1237       _             -> mkConEntryLabel con
1238
1239
1240 closureLabelFromCI (MkClosureInfo id _ _) = mkClosureLabel id
1241
1242 entryLabelFromCI :: ClosureInfo -> CLabel
1243 entryLabelFromCI (MkClosureInfo id lf_info rep)
1244   = case lf_info of
1245         LFThunk _ _ upd_flag std_form_info -> thunkEntryLabel id std_form_info upd_flag
1246         LFCon con _                        -> mkConEntryPtr con rep
1247         LFTuple tup _                      -> mkConEntryPtr tup rep
1248         other                              -> mkStdEntryLabel id
1249
1250 -- thunkEntryLabel is a local help function, not exported.  It's used from both
1251 -- entryLabelFromCI and getEntryConvention.
1252 -- I don't think it needs to deal with the SelectorThunk case
1253 -- Well, it's falling over now, so I've made it deal with it.  (JSM)
1254
1255 thunkEntryLabel thunk_id (VapThunk fun_id args _) is_updatable
1256   = mkVapEntryLabel fun_id is_updatable
1257 thunkEntryLabel thunk_id _ is_updatable
1258   = mkStdEntryLabel thunk_id
1259
1260 fastLabelFromCI :: ClosureInfo -> CLabel
1261 fastLabelFromCI (MkClosureInfo id _ _) = mkFastEntryLabel id fun_arity
1262   where
1263     arity_maybe = arityMaybe (getIdArity id)
1264     fun_arity   = case arity_maybe of
1265                     Just x -> x
1266                     _      -> pprPanic "fastLabelFromCI:no arity:" (ppr PprShowAll id)
1267 \end{code}
1268
1269 \begin{code}
1270 allocProfilingMsg :: ClosureInfo -> FAST_STRING
1271
1272 allocProfilingMsg (MkClosureInfo _ lf_info _)
1273   = case lf_info of
1274       LFReEntrant _ _ _         -> SLIT("ALLOC_FUN")
1275       LFCon _ _                 -> SLIT("ALLOC_CON")
1276       LFTuple _ _               -> SLIT("ALLOC_CON")
1277       LFThunk _ _ _ _           -> SLIT("ALLOC_THK")
1278       LFBlackHole               -> SLIT("ALLOC_BH")
1279       LFImported                -> panic "ALLOC_IMP"
1280 \end{code}
1281
1282 We need a black-hole closure info to pass to @allocDynClosure@ when we
1283 want to allocate the black hole on entry to a CAF.
1284
1285 \begin{code}
1286 blackHoleClosureInfo (MkClosureInfo id _ _)
1287   = MkClosureInfo id LFBlackHole BlackHoleRep
1288 \end{code}
1289
1290 The register liveness when returning from a constructor.  For
1291 simplicity, we claim just [node] is live for all but PhantomRep's.  In
1292 truth, this means that non-constructor info tables also claim node,
1293 but since their liveness information is never used, we don't care.
1294
1295 \begin{code}
1296 dataConLiveness (MkClosureInfo con _ PhantomRep)
1297   = case (dataReturnConvAlg con) of
1298       ReturnInRegs regs -> mkLiveRegsMask regs
1299       ReturnInHeap -> panic "dataConLiveness:PhantomRep in heap???"
1300
1301 dataConLiveness _ = mkLiveRegsMask [node]
1302 \end{code}
1303
1304 %************************************************************************
1305 %*                                                                      *
1306 \subsection[ClosureInfo-Profiling-funs]{Misc functions about for profiling info.}
1307 %*                                                                      *
1308 %************************************************************************
1309
1310 Profiling requires three pices of information to be determined for
1311 each closure's info table --- kind, description and type.
1312
1313 The description is stored directly in the @CClosureInfoTable@ when the
1314 info table is built.
1315
1316 The kind is determined from the @LambdaForm@ stored in the closure
1317 info using @closureKind@.
1318
1319 The type is determined from the type information stored with the @Id@
1320 in the closure info using @closureTypeDescr@.
1321
1322 \begin{code}
1323 closureKind :: ClosureInfo -> String
1324
1325 closureKind (MkClosureInfo _ lf _)
1326   = case lf of
1327       LFReEntrant _ n _         -> if n > 0 then "FN_K" else "THK_K"
1328       LFCon _ _                 -> "CON_K"
1329       LFTuple _ _               -> "CON_K"
1330       LFThunk _ _ _ _           -> "THK_K"
1331       LFBlackHole               -> "THK_K" -- consider BHs as thunks for the moment... (ToDo?)
1332       LFImported                -> panic "IMP_KIND"
1333
1334 closureTypeDescr :: ClosureInfo -> String
1335 closureTypeDescr (MkClosureInfo id lf _)
1336   = if (isDataCon id) then                           -- DataCon has function types
1337         _UNPK_ (nameOf (origName "closureTypeDescr" (dataConTyCon id))) -- We want the TyCon not the ->
1338     else
1339         getTyDescription (idType id)
1340 \end{code}