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