ghc/compiler/codeGen/ClosureInfo.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 % $Id: ClosureInfo.lhs,v 1.54 2002/12/11 15:36:28 simonmar Exp $
   5 %
   6 \section[ClosureInfo]{Data structures which describe closures}
   7
   8 Much of the rationale for these things is in the ``details'' part of
   9 the STG paper.
  10
  11 \begin{code}
  12 module ClosureInfo (
  13         ClosureInfo, LambdaFormInfo, SMRep,     -- all abstract
  14         StandardFormInfo, ArgDescr(..),
  15
  16         CallingConvention(..),
  17
  18         mkClosureLFInfo, mkConLFInfo, mkSelectorLFInfo,
  19         mkApLFInfo, mkLFImported, mkLFArgument, mkLFLetNoEscape,
  20         UpdateFlag,
  21
  22         closureSize, closureNonHdrSize,
  23         closureGoodStuffSize, closurePtrsSize,
  24         slopSize,
  25
  26         layOutDynClosure, layOutStaticClosure, layOutStaticNoFVClosure,
  27         layOutDynConstr, layOutStaticConstr,
  28         mkVirtHeapOffsets, mkStaticClosure,
  29
  30         nodeMustPointToIt, getEntryConvention,
  31         FCode, CgInfoDownwards, CgState,
  32
  33         blackHoleOnEntry,
  34
  35         staticClosureRequired,
  36
  37         closureName, infoTableLabelFromCI,
  38         closureLabelFromCI, closureSRT,
  39         entryLabelFromCI,
  40         closureLFInfo, closureSMRep, closureUpdReqd,
  41         closureSingleEntry, closureReEntrant, closureSemiTag,
  42         closureFunInfo, isStandardFormThunk,
  43         GenStgArg,
  44
  45         isToplevClosure,
  46         closureTypeDescr,               -- profiling
  47
  48         isStaticClosure,
  49         allocProfilingMsg,
  50         cafBlackHoleClosureInfo, seCafBlackHoleClosureInfo,
  51
  52         staticClosureNeedsLink,
  53
  54         mkInfoTable, mkRetInfoTable, mkVecInfoTable,
  55     ) where
  56
  57 #include "../includes/config.h"
  58 #include "../includes/MachDeps.h"
  59 #include "HsVersions.h"
  60
  61 import AbsCSyn
  62 import StgSyn
  63 import CgMonad
  64
  65 import Constants        ( mIN_UPD_SIZE, mIN_SIZE_NonUpdHeapObject )
  66 import CgRetConv        ( assignRegs )
  67 import CLabel
  68 import CmdLineOpts      ( opt_SccProfilingOn, opt_OmitBlackHoling,
  69                           opt_Parallel, opt_DoTickyProfiling,
  70                           opt_SMP, opt_Unregisterised )
  71 import Id               ( Id, idType, idArity, idName, idPrimRep )
  72 import DataCon          ( DataCon, dataConTag, fIRST_TAG, dataConTyCon,
  73                           isNullaryDataCon, dataConName
  74                         )
  75 import Name             ( Name, nameUnique, getOccName, getName )
  76 import OccName          ( occNameUserString )
  77 import PprType          ( getTyDescription )
  78 import PrimRep
  79 import SMRep            -- all of it
  80 import Type             ( isUnLiftedType, Type, repType, splitTyConApp_maybe )
  81 import TyCon            ( isFunTyCon )
  82 import BasicTypes       ( TopLevelFlag(..), isNotTopLevel, isTopLevel )
  83 import Util             ( mapAccumL, listLengthCmp, lengthIs )
  84 import FastString
  85 import Outputable
  86 import Literal
  87 import Constants
  88 import BitSet
  89
  90 import Maybe            ( isJust )
  91 import DATA_WORD
  92 import DATA_BITS
  93 \end{code}
  94
  95 %************************************************************************
  96 %*                                                                      *
  97 \subsection[ClosureInfo-datatypes]{Data types for closure information}
  98 %*                                                                      *
  99 %************************************************************************
 100
 101 Information about a closure, from the code generator's point of view.
 102
 103 A ClosureInfo decribes the info pointer of a closure.  It has
 104 enough information
 105   a) to construct the info table itself
 106   b) to allocate a closure containing that info pointer (i.e.
 107         it knows the info table label)
 108
 109 We make a ClosureInfo for
 110         - each let binding (both top level and not)
 111         - each data constructor (for its shared static and
 112                 dynamic info tables)
 113
 114 \begin{code}
 115 data ClosureInfo
 116   = ClosureInfo {
 117         closureName   :: !Name,           -- The thing bound to this closure
 118         closureLFInfo :: !LambdaFormInfo, -- NOTE: not an LFCon (see below)
 119         closureSMRep  :: !SMRep,          -- representation used by storage mgr
 120         closureSRT    :: !C_SRT,          -- What SRT applies to this closure
 121         closureType   :: !Type,           -- Type of closure (ToDo: remove)
 122         closureDescr  :: !String          -- closure description (for profiling)
 123     }
 124
 125   -- constructor closures don't have a unique info table label (they use
 126   -- the constructor's info table), and they don't have an SRT.
 127   | ConInfo {
 128         closureCon       :: !DataCon,
 129         closureSMRep     :: !SMRep
 130     }
 131 \end{code}
 132
 133 %************************************************************************
 134 %*                                                                      *
 135 \subsubsection[LambdaFormInfo-datatype]{@LambdaFormInfo@: source-derivable info}
 136 %*                                                                      *
 137 %************************************************************************
 138
 139 Information about an identifier, from the code generator's point of
 140 view.  Every identifier is bound to a LambdaFormInfo in the
 141 environment, which gives the code generator enough info to be able to
 142 tail call or return that identifier.
 143
 144 Note that a closure is usually bound to an identifier, so a
 145 ClosureInfo contains a LambdaFormInfo.
 146
 147 \begin{code}
 148 data LambdaFormInfo
 149   = LFReEntrant         -- Reentrant closure (a function)
 150         TopLevelFlag    -- True if top level
 151         !Int            -- Arity
 152         !Bool           -- True <=> no fvs
 153         ArgDescr        -- Argument descriptor (should reall be in ClosureInfo)
 154
 155   | LFCon               -- Constructor
 156         DataCon         -- The constructor
 157
 158   | LFThunk             -- Thunk (zero arity)
 159         TopLevelFlag
 160         !Bool           -- True <=> no free vars
 161         !Bool           -- True <=> updatable (i.e., *not* single-entry)
 162         StandardFormInfo
 163         !Bool           -- True <=> *might* be a function type
 164
 165   | LFUnknown           -- Used for function arguments and imported things.
 166                         --  We know nothing about  this closure.  Treat like
 167                         -- updatable "LFThunk"...
 168                         -- Imported things which we do know something about use
 169                         -- one of the other LF constructors (eg LFReEntrant for
 170                         -- known functions)
 171         !Bool           -- True <=> *might* be a function type
 172
 173   | LFLetNoEscape       -- See LetNoEscape module for precise description of
 174                         -- these "lets".
 175         !Int            -- arity;
 176
 177   | LFBlackHole         -- Used for the closures allocated to hold the result
 178                         -- of a CAF.  We want the target of the update frame to
 179                         -- be in the heap, so we make a black hole to hold it.
 180         CLabel          -- Flavour (info label, eg CAF_BLACKHOLE_info).
 181
 182
 183 data StandardFormInfo   -- Tells whether this thunk has one of a small number
 184                         -- of standard forms
 185
 186   = NonStandardThunk    -- No, it isn't
 187
 188   | SelectorThunk
 189        Int              -- 0-origin offset of ak within the "goods" of
 190                         -- constructor (Recall that the a1,...,an may be laid
 191                         -- out in the heap in a non-obvious order.)
 192
 193 {- A SelectorThunk is of form
 194
 195      case x of
 196        con a1,..,an -> ak
 197
 198    and the constructor is from a single-constr type.
 199 -}
 200
 201   | ApThunk
 202         Int             -- arity
 203
 204 {- An ApThunk is of form
 205
 206         x1 ... xn
 207
 208    The code for the thunk just pushes x2..xn on the stack and enters x1.
 209    There are a few of these (for 1 <= n <= MAX_SPEC_AP_SIZE) pre-compiled
 210    in the RTS to save space.
 211 -}
 212
 213 \end{code}
 214
 215 %************************************************************************
 216 %*                                                                      *
 217 \subsection[ClosureInfo-construction]{Functions which build LFInfos}
 218 %*                                                                      *
 219 %************************************************************************
 220
 221 @mkClosureLFInfo@ figures out the appropriate LFInfo for the closure.
 222
 223 \begin{code}
 224 mkClosureLFInfo :: Id           -- The binder
 225                 -> TopLevelFlag -- True of top level
 226                 -> [Id]         -- Free vars
 227                 -> UpdateFlag   -- Update flag
 228                 -> [Id]         -- Args
 229                 -> LambdaFormInfo
 230
 231 mkClosureLFInfo bndr top fvs upd_flag args@(_:_) -- Non-empty args
 232   = LFReEntrant top (length args) (null fvs) (mkArgDescr (getName bndr) args)
 233
 234 mkClosureLFInfo bndr top fvs upd_flag []
 235   = ASSERT( not updatable || not (isUnLiftedType id_ty) )
 236     LFThunk top (null fvs) updatable NonStandardThunk
 237         (might_be_a_function id_ty)
 238   where
 239         updatable = isUpdatable upd_flag
 240         id_ty = idType bndr
 241
 242 might_be_a_function :: Type -> Bool
 243 might_be_a_function ty
 244   | Just (tc,_) <- splitTyConApp_maybe (repType ty),
 245     not (isFunTyCon tc) = False
 246   | otherwise = True
 247 \end{code}
 248
 249 @mkConLFInfo@ is similar, for constructors.
 250
 251 \begin{code}
 252 mkConLFInfo :: DataCon -> LambdaFormInfo
 253 mkConLFInfo con = LFCon con
 254
 255 mkSelectorLFInfo id offset updatable
 256   = LFThunk NotTopLevel False updatable (SelectorThunk offset)
 257         (might_be_a_function (idType id))
 258
 259 mkApLFInfo id upd_flag arity
 260   = LFThunk NotTopLevel (arity == 0) (isUpdatable upd_flag) (ApThunk arity)
 261         (might_be_a_function (idType id))
 262 \end{code}
 263
 264 Miscellaneous LF-infos.
 265
 266 \begin{code}
 267 mkLFArgument id = LFUnknown (might_be_a_function (idType id))
 268
 269 mkLFLetNoEscape = LFLetNoEscape
 270
 271 mkLFImported :: Id -> LambdaFormInfo
 272 mkLFImported id
 273   = case idArity id of
 274       n | n > 0 -> LFReEntrant TopLevel n True (panic "arg_descr")  -- n > 0
 275       other -> mkLFArgument id -- Not sure of exact arity
 276 \end{code}
 277
 278 %************************************************************************
 279 %*                                                                      *
 280 \subsection[ClosureInfo-sizes]{Functions about closure {\em sizes}}
 281 %*                                                                      *
 282 %************************************************************************
 283
 284 \begin{code}
 285 closureSize :: ClosureInfo -> HeapOffset
 286 closureSize cl_info = fixedHdrSize + closureNonHdrSize cl_info
 287
 288 closureNonHdrSize :: ClosureInfo -> Int
 289 closureNonHdrSize cl_info
 290   = tot_wds + computeSlopSize tot_wds
 291                               (closureSMRep cl_info)
 292                               (closureNeedsUpdSpace cl_info)
 293   where
 294     tot_wds = closureGoodStuffSize cl_info
 295
 296 -- we leave space for an update if either (a) the closure is updatable
 297 -- or (b) it is a static thunk.  This is because a static thunk needs
 298 -- a static link field in a predictable place (after the slop), regardless
 299 -- of whether it is updatable or not.
 300 closureNeedsUpdSpace (ClosureInfo { closureLFInfo =
 301                                         LFThunk TopLevel _ _ _ _ }) = True
 302 closureNeedsUpdSpace cl_info = closureUpdReqd cl_info
 303
 304 slopSize :: ClosureInfo -> Int
 305 slopSize cl_info
 306   = computeSlopSize (closureGoodStuffSize cl_info)
 307                     (closureSMRep cl_info)
 308                     (closureNeedsUpdSpace cl_info)
 309
 310 closureGoodStuffSize :: ClosureInfo -> Int
 311 closureGoodStuffSize cl_info
 312   = let (ptrs, nonptrs) = sizes_from_SMRep (closureSMRep cl_info)
 313     in  ptrs + nonptrs
 314
 315 closurePtrsSize :: ClosureInfo -> Int
 316 closurePtrsSize cl_info
 317   = let (ptrs, _) = sizes_from_SMRep (closureSMRep cl_info)
 318     in  ptrs
 319
 320 -- not exported:
 321 sizes_from_SMRep :: SMRep -> (Int,Int)
 322 sizes_from_SMRep (GenericRep _ ptrs nonptrs _)   = (ptrs, nonptrs)
 323 sizes_from_SMRep BlackHoleRep                    = (0, 0)
 324 \end{code}
 325
 326 Computing slop size.  WARNING: this looks dodgy --- it has deep
 327 knowledge of what the storage manager does with the various
 328 representations...
 329
 330 Slop Requirements:
 331 \begin{itemize}
 332 \item
 333 Updateable closures must be @mIN_UPD_SIZE@.
 334         \begin{itemize}
 335         \item
 336         Indirections require 1 word
 337         \item
 338         Appels collector indirections 2 words
 339         \end{itemize}
 340 THEREFORE: @mIN_UPD_SIZE = 2@.
 341
 342 \item
 343 Collectable closures which are allocated in the heap
 344 must be @mIN_SIZE_NonUpdHeapObject@.
 345
 346 Copying collector forward pointer requires 1 word
 347
 348 THEREFORE: @mIN_SIZE_NonUpdHeapObject = 1@
 349 \end{itemize}
 350
 351 Static closures have an extra ``static link field'' at the end, but we
 352 don't bother taking that into account here.
 353
 354 \begin{code}
 355 computeSlopSize :: Int -> SMRep -> Bool -> Int
 356
 357 computeSlopSize tot_wds (GenericRep _ _ _ _) True               -- Updatable
 358   = max 0 (mIN_UPD_SIZE - tot_wds)
 359
 360 computeSlopSize tot_wds (GenericRep True _ _ _) False   -- Non updatable
 361   = 0                                                   -- Static
 362
 363 computeSlopSize tot_wds (GenericRep False _ _ _) False  -- Non updatable
 364   = max 0 (mIN_SIZE_NonUpdHeapObject - tot_wds)         -- Dynamic
 365
 366 computeSlopSize tot_wds BlackHoleRep _                  -- Updatable
 367   = max 0 (mIN_UPD_SIZE - tot_wds)
 368 \end{code}
 369
 370 %************************************************************************
 371 %*                                                                      *
 372 \subsection[layOutDynClosure]{Lay out a closure}
 373 %*                                                                      *
 374 %************************************************************************
 375
 376 \begin{code}
 377 layOutDynClosure, layOutStaticClosure
 378         :: Id                       -- STG identifier of this closure
 379         -> (a -> PrimRep)           -- how to get a PrimRep for the fields
 380         -> [a]                      -- the "things" being layed out
 381         -> LambdaFormInfo           -- what sort of closure it is
 382         -> C_SRT                    -- its SRT
 383         -> String                   -- closure description
 384         -> (ClosureInfo,            -- info about the closure
 385             [(a, VirtualHeapOffset)])   -- things w/ offsets pinned on them
 386
 387 layOutDynClosure    = layOutClosure False
 388 layOutStaticClosure = layOutClosure True
 389
 390 layOutStaticNoFVClosure id lf_info srt_info descr
 391   = fst (layOutClosure True id (panic "kind_fn") [] lf_info srt_info descr)
 392
 393 layOutClosure
 394         :: Bool                     -- True <=> static closure
 395         -> Id                       -- STG identifier of this closure
 396         -> (a -> PrimRep)           -- how to get a PrimRep for the fields
 397         -> [a]                      -- the "things" being layed out
 398         -> LambdaFormInfo           -- what sort of closure it is
 399         -> C_SRT                    -- its SRT
 400         -> String                   -- closure description
 401         -> (ClosureInfo,            -- info about the closure
 402             [(a, VirtualHeapOffset)])   -- things w/ offsets pinned on them
 403
 404 layOutClosure is_static id kind_fn things lf_info srt_info descr
 405   = (ClosureInfo { closureName = name,
 406                    closureLFInfo = lf_info,
 407                    closureSMRep = sm_rep,
 408                    closureSRT = srt_info,
 409                    closureType = idType id,
 410                    closureDescr = descr },
 411      things_w_offsets)
 412   where
 413     name = idName id
 414     (tot_wds,            -- #ptr_wds + #nonptr_wds
 415      ptr_wds,            -- #ptr_wds
 416      things_w_offsets) = mkVirtHeapOffsets kind_fn things
 417     sm_rep = chooseSMRep is_static lf_info tot_wds ptr_wds
 418
 419
 420 layOutDynConstr, layOutStaticConstr
 421         :: DataCon
 422         -> (a -> PrimRep)
 423         -> [a]
 424         -> (ClosureInfo,
 425             [(a,VirtualHeapOffset)])
 426
 427 layOutDynConstr    = layOutConstr False
 428 layOutStaticConstr = layOutConstr True
 429
 430 layOutConstr is_static data_con kind_fn args
 431    = (ConInfo { closureSMRep = sm_rep,
 432                 closureCon = data_con },
 433       things_w_offsets)
 434   where
 435     (tot_wds,            -- #ptr_wds + #nonptr_wds
 436      ptr_wds,            -- #ptr_wds
 437      things_w_offsets) = mkVirtHeapOffsets kind_fn args
 438     sm_rep = chooseSMRep is_static (mkConLFInfo data_con) tot_wds ptr_wds
 439 \end{code}
 440
 441 %************************************************************************
 442 %*                                                                      *
 443 \subsection[mkStaticClosure]{Make a static closure}
 444 %*                                                                      *
 445 %************************************************************************
 446
 447 Make a static closure, adding on any extra padding needed for CAFs,
 448 and adding a static link field if necessary.
 449
 450 \begin{code}
 451 mkStaticClosure lbl cl_info ccs fields cafrefs
 452   | opt_SccProfilingOn =
 453              CStaticClosure
 454                 lbl
 455                 cl_info
 456                 (mkCCostCentreStack ccs)
 457                 all_fields
 458   | otherwise =
 459              CStaticClosure
 460                 lbl
 461                 cl_info
 462                 (panic "absent cc")
 463                 all_fields
 464
 465    where
 466     all_fields = fields ++ padding_wds ++ static_link_field
 467
 468     upd_reqd = closureUpdReqd cl_info
 469
 470     -- for the purposes of laying out the static closure, we consider all
 471     -- thunks to be "updatable", so that the static link field is always
 472     -- in the same place.
 473     padding_wds
 474         | not upd_reqd = []
 475         | otherwise    = replicate n (mkIntCLit 0) -- a bunch of 0s
 476         where n = max 0 (mIN_UPD_SIZE - length fields)
 477
 478         -- We always have a static link field for a thunk, it's used to
 479         -- save the closure's info pointer when we're reverting CAFs
 480         -- (see comment in Storage.c)
 481     static_link_field
 482         | upd_reqd || staticClosureNeedsLink cl_info = [static_link_value]
 483         | otherwise                                  = []
 484
 485         -- for a static constructor which has NoCafRefs, we set the
 486         -- static link field to a non-zero value so the garbage
 487         -- collector will ignore it.
 488     static_link_value
 489         | cafrefs       = mkIntCLit 0
 490         | otherwise     = mkIntCLit 1
 491 \end{code}
 492
 493 %************************************************************************
 494 %*                                                                      *
 495 \subsection[SMreps]{Choosing SM reps}
 496 %*                                                                      *
 497 %************************************************************************
 498
 499 \begin{code}
 500 chooseSMRep
 501         :: Bool                 -- True <=> static closure
 502         -> LambdaFormInfo
 503         -> Int -> Int           -- Tot wds, ptr wds
 504         -> SMRep
 505
 506 chooseSMRep is_static lf_info tot_wds ptr_wds
 507   = let
 508          nonptr_wds   = tot_wds - ptr_wds
 509          closure_type = getClosureType is_static tot_wds ptr_wds lf_info
 510     in
 511     GenericRep is_static ptr_wds nonptr_wds closure_type
 512
 513 -- we *do* get non-updatable top-level thunks sometimes.  eg. f = g
 514 -- gets compiled to a jump to g (if g has non-zero arity), instead of
 515 -- messing around with update frames and PAPs.  We set the closure type
 516 -- to FUN_STATIC in this case.
 517
 518 getClosureType :: Bool -> Int -> Int -> LambdaFormInfo -> ClosureType
 519 getClosureType is_static tot_wds ptr_wds lf_info
 520   = case lf_info of
 521         LFCon con | is_static && ptr_wds == 0   -> CONSTR_NOCAF
 522                   | otherwise                   -> CONSTR
 523         LFReEntrant _ _ _ _                     -> FUN
 524         LFThunk _ _ _ (SelectorThunk _) _       -> THUNK_SELECTOR
 525         LFThunk _ _ _ _ _                       -> THUNK
 526         _ -> panic "getClosureType"
 527 \end{code}
 528
 529 %************************************************************************
 530 %*                                                                      *
 531 \subsection[mkVirtHeapOffsets]{Assigning heap offsets in a closure}
 532 %*                                                                      *
 533 %************************************************************************
 534
 535 @mkVirtHeapOffsets@ (the heap version) always returns boxed things with
 536 smaller offsets than the unboxed things, and furthermore, the offsets in
 537 the result list
 538
 539 \begin{code}
 540 mkVirtHeapOffsets ::
 541           (a -> PrimRep)        -- To be able to grab kinds;
 542                                 --      w/ a kind, we can find boxedness
 543           -> [a]                -- Things to make offsets for
 544           -> (Int,              -- *Total* number of words allocated
 545               Int,              -- Number of words allocated for *pointers*
 546               [(a, VirtualHeapOffset)])
 547                                 -- Things with their offsets from start of
 548                                 --  object in order of increasing offset
 549
 550 -- First in list gets lowest offset, which is initial offset + 1.
 551
 552 mkVirtHeapOffsets kind_fun things
 553   = let (ptrs, non_ptrs)              = separateByPtrFollowness kind_fun things
 554         (wds_of_ptrs, ptrs_w_offsets) = mapAccumL computeOffset 0 ptrs
 555         (tot_wds, non_ptrs_w_offsets) = mapAccumL computeOffset wds_of_ptrs non_ptrs
 556     in
 557         (tot_wds, wds_of_ptrs, ptrs_w_offsets ++ non_ptrs_w_offsets)
 558   where
 559     computeOffset wds_so_far thing
 560       = (wds_so_far + (getPrimRepSize . kind_fun) thing,
 561          (thing, fixedHdrSize + wds_so_far)
 562         )
 563 \end{code}
 564
 565 %************************************************************************
 566 %*                                                                      *
 567 \subsection[ClosureInfo-4-questions]{Four major questions about @ClosureInfo@}
 568 %*                                                                      *
 569 %************************************************************************
 570
 571 Be sure to see the stg-details notes about these...
 572
 573 \begin{code}
 574 nodeMustPointToIt :: LambdaFormInfo -> FCode Bool
 575 nodeMustPointToIt lf_info
 576
 577   = case lf_info of
 578         LFReEntrant top _ no_fvs _ -> returnFC (
 579             not no_fvs ||   -- Certainly if it has fvs we need to point to it
 580             isNotTopLevel top
 581                     -- If it is not top level we will point to it
 582                     --   We can have a \r closure with no_fvs which
 583                     --   is not top level as special case cgRhsClosure
 584                     --   has been dissabled in favour of let floating
 585
 586                 -- For lex_profiling we also access the cost centre for a
 587                 -- non-inherited function i.e. not top level
 588                 -- the  not top  case above ensures this is ok.
 589             )
 590
 591         LFCon _ -> returnFC True
 592
 593         -- Strictly speaking, the above two don't need Node to point
 594         -- to it if the arity = 0.  But this is a *really* unlikely
 595         -- situation.  If we know it's nil (say) and we are entering
 596         -- it. Eg: let x = [] in x then we will certainly have inlined
 597         -- x, since nil is a simple atom.  So we gain little by not
 598         -- having Node point to known zero-arity things.  On the other
 599         -- hand, we do lose something; Patrick's code for figuring out
 600         -- when something has been updated but not entered relies on
 601         -- having Node point to the result of an update.  SLPJ
 602         -- 27/11/92.
 603
 604         LFThunk _ no_fvs updatable NonStandardThunk _
 605           -> returnFC (updatable || not no_fvs || opt_SccProfilingOn)
 606
 607           -- For the non-updatable (single-entry case):
 608           --
 609           -- True if has fvs (in which case we need access to them, and we
 610           --                should black-hole it)
 611           -- or profiling (in which case we need to recover the cost centre
 612           --             from inside it)
 613
 614         LFThunk _ no_fvs updatable some_standard_form_thunk _
 615           -> returnFC True
 616           -- Node must point to any standard-form thunk.
 617
 618         LFUnknown _   -> returnFC True
 619         LFBlackHole _ -> returnFC True
 620                     -- BH entry may require Node to point
 621
 622         LFLetNoEscape _ -> returnFC False
 623 \end{code}
 624
 625 The entry conventions depend on the type of closure being entered,
 626 whether or not it has free variables, and whether we're running
 627 sequentially or in parallel.
 628
 629 \begin{tabular}{lllll}
 630 Closure Characteristics & Parallel & Node Req'd & Argument Passing & Enter Via \\
 631 Unknown                         & no & yes & stack      & node \\
 632 Known fun ($\ge$ 1 arg), no fvs         & no & no  & registers  & fast entry (enough args) \\
 633 \ & \ & \ & \                                           & slow entry (otherwise) \\
 634 Known fun ($\ge$ 1 arg), fvs    & no & yes & registers  & fast entry (enough args) \\
 635 0 arg, no fvs @\r,\s@           & no & no  & n/a        & direct entry \\
 636 0 arg, no fvs @\u@              & no & yes & n/a        & node \\
 637 0 arg, fvs @\r,\s@              & no & yes & n/a        & direct entry \\
 638 0 arg, fvs @\u@                 & no & yes & n/a        & node \\
 639
 640 Unknown                         & yes & yes & stack     & node \\
 641 Known fun ($\ge$ 1 arg), no fvs         & yes & no  & registers & fast entry (enough args) \\
 642 \ & \ & \ & \                                           & slow entry (otherwise) \\
 643 Known fun ($\ge$ 1 arg), fvs    & yes & yes & registers & node \\
 644 0 arg, no fvs @\r,\s@           & yes & no  & n/a       & direct entry \\
 645 0 arg, no fvs @\u@              & yes & yes & n/a       & node \\
 646 0 arg, fvs @\r,\s@              & yes & yes & n/a       & node \\
 647 0 arg, fvs @\u@                 & yes & yes & n/a       & node\\
 648 \end{tabular}
 649
 650 When black-holing, single-entry closures could also be entered via node
 651 (rather than directly) to catch double-entry.
 652
 653 \begin{code}
 654 data CallingConvention
 655   = EnterIt                             -- no args, not a function
 656
 657   | JumpToIt CLabel                     -- no args, not a function, but we
 658                                         -- know what its entry code is
 659
 660   | ReturnIt                            -- it's a function, but we have
 661                                         -- zero args to apply to it, so just
 662                                         -- return it.
 663
 664   | SlowCall                            -- Unknown fun, or known fun with
 665                                         -- too few args.
 666
 667   | DirectEntry                         -- Jump directly, with args in regs
 668         CLabel                          --   The code label
 669         Int                             --   Its arity
 670         [MagicId]                       --   Its register assignments
 671                                         --      (possibly empty)
 672
 673 getEntryConvention :: Name              -- Function being applied
 674                    -> LambdaFormInfo    -- Its info
 675                    -> [PrimRep]         -- Available arguments
 676                    -> FCode CallingConvention
 677
 678 getEntryConvention name lf_info arg_kinds
 679  =  nodeMustPointToIt lf_info   `thenFC` \ node_points ->
 680     returnFC (
 681
 682     -- if we're parallel, then we must always enter via node.  The reason
 683     -- is that the closure may have been fetched since we allocated it.
 684
 685     if (node_points && opt_Parallel) then EnterIt else
 686
 687     -- Commented out by SDM after futher thoughts:
 688     --   - the only closure type that can be blackholed is a thunk
 689     --   - we already enter thunks via node (unless the closure is
 690     --     non-updatable, in which case why is it being re-entered...)
 691
 692     case lf_info of
 693
 694         LFReEntrant _ arity _ _ ->
 695             if null arg_kinds then
 696                 if arity == 0 then
 697                    EnterIt              -- a non-updatable thunk
 698                 else
 699                    ReturnIt             -- no args at all
 700             else if listLengthCmp arg_kinds arity == LT then
 701                 SlowCall                -- not enough args
 702             else
 703                 DirectEntry (mkEntryLabel name) arity arg_regs
 704           where
 705             (arg_regs, _) = assignRegs [node] (take arity arg_kinds)
 706                 -- we don't use node to pass args now (SDM)
 707
 708         LFCon con
 709             | isNullaryDataCon con
 710               -- a real constructor.  Don't bother entering it, just jump
 711               -- to the constructor entry code directly.
 712                           -> --false:ASSERT (null arg_kinds)
 713                              -- Should have no args (meaning what?)
 714                              JumpToIt (mkStaticConEntryLabel (dataConName con))
 715
 716              | otherwise {- not nullary -}
 717                           -> --false:ASSERT (null arg_kinds)
 718                              -- Should have no args (meaning what?)
 719                              JumpToIt (mkConEntryLabel (dataConName con))
 720
 721         LFThunk _ _ updatable std_form_info is_fun
 722           -- must always "call" a function-typed thing, cannot just enter it
 723           | is_fun -> SlowCall
 724           | updatable || opt_DoTickyProfiling  -- to catch double entry
 725                 || opt_SMP  -- always enter via node on SMP, since the
 726                             -- thunk might have been blackholed in the
 727                             -- meantime.
 728              -> ASSERT(null arg_kinds) EnterIt
 729           | otherwise
 730              -> ASSERT(null arg_kinds)
 731                 JumpToIt (thunkEntryLabel name std_form_info updatable)
 732
 733         LFUnknown True  -> SlowCall -- might be a function
 734         LFUnknown False -> ASSERT2 (null arg_kinds, ppr name <+> ppr arg_kinds) EnterIt -- not a function
 735
 736         LFBlackHole _ -> SlowCall -- Presumably the black hole has by now
 737                                   -- been updated, but we don't know with
 738                                   -- what, so we slow call it
 739
 740         LFLetNoEscape 0
 741           -> JumpToIt (mkReturnPtLabel (nameUnique name))
 742
 743         LFLetNoEscape arity
 744           -> if (not (arg_kinds `lengthIs` arity)) then pprPanic "let-no-escape: " (ppr name <+> ppr arity) else
 745              DirectEntry (mkReturnPtLabel (nameUnique name)) arity arg_regs
 746          where
 747             (arg_regs, _) = assignRegs [] arg_kinds
 748             -- node never points to a LetNoEscape, see above --SDM
 749             --live_regs     = if node_points then [node] else []
 750     )
 751
 752 blackHoleOnEntry :: ClosureInfo -> Bool
 753
 754 -- Static closures are never themselves black-holed.
 755 -- Updatable ones will be overwritten with a CAFList cell, which points to a
 756 -- black hole;
 757 -- Single-entry ones have no fvs to plug, and we trust they don't form part
 758 -- of a loop.
 759
 760 blackHoleOnEntry ConInfo{} = False
 761 blackHoleOnEntry (ClosureInfo { closureLFInfo = lf_info, closureSMRep = rep })
 762   | isStaticRep rep
 763   = False       -- Never black-hole a static closure
 764
 765   | otherwise
 766   = case lf_info of
 767         LFReEntrant _ _ _ _       -> False
 768         LFLetNoEscape _           -> False
 769         LFThunk _ no_fvs updatable _ _
 770           -> if updatable
 771              then not opt_OmitBlackHoling
 772              else opt_DoTickyProfiling || not no_fvs
 773                   -- the former to catch double entry,
 774                   -- and the latter to plug space-leaks.  KSW/SDM 1999-04.
 775
 776         other -> panic "blackHoleOnEntry"       -- Should never happen
 777
 778 isStandardFormThunk :: LambdaFormInfo -> Bool
 779
 780 isStandardFormThunk (LFThunk _ _ _ (SelectorThunk _) _) = True
 781 isStandardFormThunk (LFThunk _ _ _ (ApThunk _) _)       = True
 782 isStandardFormThunk other_lf_info                       = False
 783
 784 \end{code}
 785
 786 -----------------------------------------------------------------------------
 787 SRT-related stuff
 788
 789 \begin{code}
 790 staticClosureNeedsLink :: ClosureInfo -> Bool
 791 -- A static closure needs a link field to aid the GC when traversing
 792 -- the static closure graph.  But it only needs such a field if either
 793 --      a) it has an SRT
 794 --      b) it's a constructor with one or more pointer fields
 795 -- In case (b), the constructor's fields themselves play the role
 796 -- of the SRT.
 797 staticClosureNeedsLink (ClosureInfo { closureSRT = srt })
 798   = needsSRT srt
 799 staticClosureNeedsLink (ConInfo { closureSMRep = sm_rep, closureCon = con })
 800   = not (isNullaryDataCon con) && not_nocaf_constr
 801   where
 802     not_nocaf_constr =
 803         case sm_rep of
 804            GenericRep _ _ _ CONSTR_NOCAF -> False
 805            _other                        -> True
 806 \end{code}
 807
 808 Avoiding generating entries and info tables
 809 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 810 At present, for every function we generate all of the following,
 811 just in case.  But they aren't always all needed, as noted below:
 812
 813 [NB1: all of this applies only to *functions*.  Thunks always
 814 have closure, info table, and entry code.]
 815
 816 [NB2: All are needed if the function is *exported*, just to play safe.]
 817
 818
 819 * Fast-entry code  ALWAYS NEEDED
 820
 821 * Slow-entry code
 822         Needed iff (a) we have any un-saturated calls to the function
 823         OR         (b) the function is passed as an arg
 824         OR         (c) we're in the parallel world and the function has free vars
 825                         [Reason: in parallel world, we always enter functions
 826                         with free vars via the closure.]
 827
 828 * The function closure
 829         Needed iff (a) we have any un-saturated calls to the function
 830         OR         (b) the function is passed as an arg
 831         OR         (c) if the function has free vars (ie not top level)
 832
 833   Why case (a) here?  Because if the arg-satis check fails,
 834   UpdatePAP stuffs a pointer to the function closure in the PAP.
 835   [Could be changed; UpdatePAP could stuff in a code ptr instead,
 836    but doesn't seem worth it.]
 837
 838   [NB: these conditions imply that we might need the closure
 839   without the slow-entry code.  Here's how.
 840
 841         f x y = let g w = ...x..y..w...
 842                 in
 843                 ...(g t)...
 844
 845   Here we need a closure for g which contains x and y,
 846   but since the calls are all saturated we just jump to the
 847   fast entry point for g, with R1 pointing to the closure for g.]
 848
 849
 850 * Standard info table
 851         Needed iff (a) we have any un-saturated calls to the function
 852         OR         (b) the function is passed as an arg
 853         OR         (c) the function has free vars (ie not top level)
 854
 855         NB.  In the sequential world, (c) is only required so that the function closure has
 856         an info table to point to, to keep the storage manager happy.
 857         If (c) alone is true we could fake up an info table by choosing
 858         one of a standard family of info tables, whose entry code just
 859         bombs out.
 860
 861         [NB In the parallel world (c) is needed regardless because
 862         we enter functions with free vars via the closure.]
 863
 864         If (c) is retained, then we'll sometimes generate an info table
 865         (for storage mgr purposes) without slow-entry code.  Then we need
 866         to use an error label in the info table to substitute for the absent
 867         slow entry code.
 868
 869 \begin{code}
 870 staticClosureRequired
 871         :: Name
 872         -> StgBinderInfo
 873         -> LambdaFormInfo
 874         -> Bool
 875 staticClosureRequired binder bndr_info
 876                       (LFReEntrant top_level _ _ _)     -- It's a function
 877   = ASSERT( isTopLevel top_level )
 878         -- Assumption: it's a top-level, no-free-var binding
 879         not (satCallsOnly bndr_info)
 880
 881 staticClosureRequired binder other_binder_info other_lf_info = True
 882 \end{code}
 883
 884 %************************************************************************
 885 %*                                                                      *
 886 \subsection[ClosureInfo-misc-funs]{Misc functions about @ClosureInfo@, etc.}
 887 %*                                                                      *
 888 %************************************************************************
 889
 890 \begin{code}
 891
 892 isStaticClosure :: ClosureInfo -> Bool
 893 isStaticClosure cl_info = isStaticRep (closureSMRep cl_info)
 894
 895 closureUpdReqd :: ClosureInfo -> Bool
 896 closureUpdReqd (ClosureInfo { closureLFInfo = LFThunk _ _ upd _ _ }) = upd
 897 closureUpdReqd (ClosureInfo { closureLFInfo = LFBlackHole _ })     = True
 898         -- Black-hole closures are allocated to receive the results of an
 899         -- alg case with a named default... so they need to be updated.
 900 closureUpdReqd other_closure = False
 901
 902 closureSingleEntry :: ClosureInfo -> Bool
 903 closureSingleEntry (ClosureInfo { closureLFInfo = LFThunk _ _ upd _ _}) = not upd
 904 closureSingleEntry other_closure = False
 905
 906 closureReEntrant :: ClosureInfo -> Bool
 907 closureReEntrant (ClosureInfo { closureLFInfo = LFReEntrant _ _ _ _ }) = True
 908 closureReEntrant other_closure = False
 909
 910 closureSemiTag :: ClosureInfo -> Maybe Int
 911 closureSemiTag (ConInfo { closureCon = data_con })
 912       = Just (dataConTag data_con - fIRST_TAG)
 913 closureSemiTag _ = Nothing
 914
 915 closureFunInfo :: ClosureInfo -> Maybe (Int, ArgDescr)
 916 closureFunInfo (ClosureInfo { closureLFInfo = LFReEntrant _ arity _ arg_desc})
 917   = Just (arity, arg_desc)
 918 closureFunInfo _
 919   = Nothing
 920 \end{code}
 921
 922 \begin{code}
 923 isToplevClosure :: ClosureInfo -> Bool
 924 isToplevClosure (ClosureInfo { closureLFInfo = lf_info })
 925   = case lf_info of
 926       LFReEntrant TopLevel _ _ _ -> True
 927       LFThunk TopLevel _ _ _ _   -> True
 928       other -> False
 929 isToplevClosure _ = False
 930 \end{code}
 931
 932 Label generation.
 933
 934 \begin{code}
 935 infoTableLabelFromCI :: ClosureInfo -> CLabel
 936 infoTableLabelFromCI (ClosureInfo { closureName = name,
 937                                     closureLFInfo = lf_info,
 938                                     closureSMRep = rep })
 939   = case lf_info of
 940         LFBlackHole info -> info
 941
 942         LFThunk _ _ upd_flag (SelectorThunk offset) _ ->
 943                 mkSelectorInfoLabel upd_flag offset
 944
 945         LFThunk _ _ upd_flag (ApThunk arity) _ ->
 946                 mkApInfoTableLabel upd_flag arity
 947
 948         LFThunk{}      -> mkInfoTableLabel name
 949
 950         LFReEntrant _ _ _ (ArgGen _ _) -> mkInfoTableLabel name
 951         LFReEntrant _ _ _ _             -> mkInfoTableLabel name
 952
 953         other -> panic "infoTableLabelFromCI"
 954
 955 infoTableLabelFromCI (ConInfo { closureCon = con, closureSMRep = rep })
 956   =  mkConInfoPtr con rep
 957
 958
 959 mkConInfoPtr :: DataCon -> SMRep -> CLabel
 960 mkConInfoPtr con rep
 961   | isStaticRep rep = mkStaticInfoTableLabel  name
 962   | otherwise       = mkConInfoTableLabel     name
 963   where
 964     name = dataConName con
 965
 966 mkConEntryPtr :: DataCon -> SMRep -> CLabel
 967 mkConEntryPtr con rep
 968   | isStaticRep rep = mkStaticConEntryLabel (dataConName con)
 969   | otherwise       = mkConEntryLabel       (dataConName con)
 970
 971 closureLabelFromCI (ClosureInfo { closureName = nm }) = mkClosureLabel nm
 972 closureLabelFromCI _ = panic "closureLabelFromCI"
 973
 974 entryLabelFromCI :: ClosureInfo -> CLabel
 975 entryLabelFromCI (ClosureInfo { closureName = id,
 976                                 closureLFInfo = lf_info,
 977                                 closureSMRep = rep })
 978   = case lf_info of
 979         LFThunk _ _ upd_flag std_form_info _ ->
 980                 thunkEntryLabel id std_form_info upd_flag
 981         other -> mkEntryLabel id
 982
 983 entryLabelFromCI (ConInfo { closureCon = con, closureSMRep = rep })
 984   = mkConEntryPtr con rep
 985
 986
 987 -- thunkEntryLabel is a local help function, not exported.  It's used from both
 988 -- entryLabelFromCI and getEntryConvention.
 989
 990 thunkEntryLabel thunk_id (ApThunk arity) is_updatable
 991   = mkApEntryLabel is_updatable arity
 992 thunkEntryLabel thunk_id (SelectorThunk offset) upd_flag
 993   = mkSelectorEntryLabel upd_flag offset
 994 thunkEntryLabel thunk_id _ is_updatable
 995   = mkEntryLabel thunk_id
 996 \end{code}
 997
 998 \begin{code}
 999 allocProfilingMsg :: ClosureInfo -> FastString
1000 allocProfilingMsg ConInfo{} = FSLIT("TICK_ALLOC_CON")
1001 allocProfilingMsg ClosureInfo{ closureLFInfo = lf_info }
1002   = case lf_info of
1003       LFReEntrant _ _ _ _   -> FSLIT("TICK_ALLOC_FUN")
1004       LFThunk _ _ True _ _  -> FSLIT("TICK_ALLOC_UP_THK")  -- updatable
1005       LFThunk _ _ False _ _ -> FSLIT("TICK_ALLOC_SE_THK")  -- nonupdatable
1006       LFBlackHole _         -> FSLIT("TICK_ALLOC_BH")
1007       _                     -> panic "allocProfilingMsg"
1008 \end{code}
1009
1010 We need a black-hole closure info to pass to @allocDynClosure@ when we
1011 want to allocate the black hole on entry to a CAF.  These are the only
1012 ways to build an LFBlackHole, maintaining the invariant that it really
1013 is a black hole and not something else.
1014
1015 \begin{code}
1016 cafBlackHoleClosureInfo (ClosureInfo { closureName = nm,
1017                                        closureType = ty })
1018   = ClosureInfo { closureName   = nm,
1019                   closureLFInfo = LFBlackHole mkCAFBlackHoleInfoTableLabel,
1020                   closureSMRep  = BlackHoleRep,
1021                   closureSRT    = NoC_SRT,
1022                   closureType   = ty,
1023                   closureDescr  = "" }
1024 cafBlackHoleClosureInfo _ = panic "cafBlackHoleClosureInfo"
1025
1026 seCafBlackHoleClosureInfo (ClosureInfo { closureName = nm,
1027                                          closureType = ty })
1028   = ClosureInfo { closureName   = nm,
1029                   closureLFInfo = LFBlackHole mkSECAFBlackHoleInfoTableLabel,
1030                   closureSMRep  = BlackHoleRep,
1031                   closureSRT    = NoC_SRT,
1032                   closureType   = ty,
1033                   closureDescr  = ""  }
1034 seCafBlackHoleClosureInfo _ = panic "seCafBlackHoleClosureInfo"
1035 \end{code}
1036
1037 %************************************************************************
1038 %*                                                                      *
1039 \subsection[ClosureInfo-Profiling-funs]{Misc functions about for profiling info.}
1040 %*                                                                      *
1041 %************************************************************************
1042
1043 Profiling requires two pieces of information to be determined for
1044 each closure's info table --- description and type.
1045
1046 The description is stored directly in the @CClosureInfoTable@ when the
1047 info table is built.
1048
1049 The type is determined from the type information stored with the @Id@
1050 in the closure info using @closureTypeDescr@.
1051
1052 \begin{code}
1053 closureTypeDescr :: ClosureInfo -> String
1054 closureTypeDescr (ClosureInfo { closureType = ty })
1055   = getTyDescription ty
1056 closureTypeDescr (ConInfo { closureCon = data_con })
1057   = occNameUserString (getOccName (dataConTyCon data_con))
1058 \end{code}
1059
1060 %************************************************************************
1061 %*                                                                      *
1062 \subsection{Making argument bitmaps}
1063 %*                                                                      *
1064 %************************************************************************
1065
1066 \begin{code}
1067 -- bring in ARG_P, ARG_N, etc.
1068 #include "../includes/StgFun.h"
1069
1070 data ArgDescr
1071   = ArgSpec
1072         !Int            -- ARG_P, ARG_N, ...
1073   | ArgGen
1074         CLabel          -- label for a slow-entry point
1075         Liveness        -- the arg bitmap: describes pointedness of arguments
1076
1077 mkArgDescr :: Name -> [Id] -> ArgDescr
1078 mkArgDescr nm args = argDescr nm (filter nonVoidRep (map idPrimRep args))
1079   where nonVoidRep VoidRep = False
1080         nonVoidRep _ = True
1081
1082 argDescr nm [PtrRep]    = ArgSpec ARG_P
1083 argDescr nm [FloatRep]  = ArgSpec ARG_F
1084 argDescr nm [DoubleRep] = ArgSpec ARG_D
1085 argDescr nm [r] | is64BitRep r  = ArgSpec ARG_L
1086 argDescr nm [r] | isNonPtrRep r = ArgSpec ARG_N
1087
1088 argDescr nm [r1,r2] | isNonPtrRep r1 && isNonPtrRep r2 = ArgSpec ARG_NN
1089 argDescr nm [r1,PtrRep] | isNonPtrRep r1 = ArgSpec ARG_NP
1090 argDescr nm [PtrRep,r1] | isNonPtrRep r1 = ArgSpec ARG_PN
1091 argDescr nm [PtrRep,PtrRep] = ArgSpec ARG_PP
1092
1093 argDescr nm [r1,r2,r3] | isNonPtrRep r1 && isNonPtrRep r2 && isNonPtrRep r3 = ArgSpec ARG_NNN
1094 argDescr nm [r1,r2,PtrRep] | isNonPtrRep r1 && isNonPtrRep r2 = ArgSpec ARG_NNP
1095 argDescr nm [r1,PtrRep,r2] | isNonPtrRep r1 && isNonPtrRep r2 = ArgSpec ARG_NPN
1096 argDescr nm [r1,PtrRep,PtrRep] | isNonPtrRep r1 = ArgSpec ARG_NPP
1097 argDescr nm [PtrRep,r1,r2] | isNonPtrRep r1 && isNonPtrRep r2 = ArgSpec ARG_PNN
1098 argDescr nm [PtrRep,r1,PtrRep] | isNonPtrRep r1 = ArgSpec ARG_PNP
1099 argDescr nm [PtrRep,PtrRep,r1] | isNonPtrRep r1 = ArgSpec ARG_PPN
1100 argDescr nm [PtrRep,PtrRep,PtrRep] = ArgSpec ARG_PPP
1101
1102 argDescr nm [PtrRep,PtrRep,PtrRep,PtrRep] = ArgSpec ARG_PPPP
1103 argDescr nm [PtrRep,PtrRep,PtrRep,PtrRep,PtrRep] = ArgSpec ARG_PPPPP
1104 argDescr nm [PtrRep,PtrRep,PtrRep,PtrRep,PtrRep,PtrRep] = ArgSpec ARG_PPPPPP
1105
1106 argDescr name reps = ArgGen (mkSlowEntryLabel name) liveness
1107  where bitmap = argBits reps
1108        lbl = mkBitmapLabel name
1109        liveness = Liveness lbl (length bitmap)
1110                         (map chunkToLiveness (mkChunks bitmap))
1111
1112 argBits [] = []
1113 argBits (rep : args)
1114   | isFollowableRep rep = False : argBits args
1115   | otherwise = take (getPrimRepSize rep) (repeat True) ++ argBits args
1116
1117 mkChunks [] = []
1118 mkChunks stuff = chunk : mkChunks rest
1119   where (chunk, rest) = splitAt 32 stuff
1120
1121 chunkToLiveness chunk = mkBS [ n | (True,n) <- zip chunk [0..] ]
1122 \end{code}
1123
1124
1125 %************************************************************************
1126 %*                                                                      *
1127 \subsection{Generating info tables}
1128 %*                                                                      *
1129 %************************************************************************
1130
1131 Here we make a concrete info table, represented as a list of CAddrMode
1132 (it can't be simply a list of Word, because the SRT field is
1133 represented by a label+offset expression).
1134
1135 \begin{code}
1136 #if SIZEOF_HSWORD == 4
1137 type StgWord = Word32
1138 #define HALF_WORD 16
1139 #elif SIZEOF_HSWORD == 8
1140 type StgWord = Word64
1141 #define HALF_WORD 32
1142 #endif
1143
1144 mkInfoTable :: ClosureInfo -> [CAddrMode]
1145 mkInfoTable cl_info
1146  | opt_Unregisterised = std_info ++ extra_bits
1147  | otherwise          = extra_bits ++ std_info
1148  where
1149     std_info = mkStdInfoTable entry_amode
1150                   ty_descr_amode cl_descr_amode cl_type srt_len layout_amode
1151
1152     entry_amode = CLbl (entryLabelFromCI cl_info) CodePtrRep
1153
1154     closure_descr =
1155         case cl_info of
1156           ClosureInfo { closureDescr = descr } -> descr
1157           ConInfo { closureCon = con } -> occNameUserString (getOccName con)
1158
1159     ty_descr_amode = CLit (MachStr (mkFastString (closureTypeDescr cl_info)))
1160     cl_descr_amode = CLit (MachStr (mkFastString closure_descr))
1161
1162     cl_type = getSMRepClosureTypeInt (closureSMRep cl_info)
1163
1164     srt = closureSRT cl_info
1165     needs_srt = needsSRT srt
1166
1167     semi_tag = closureSemiTag cl_info
1168     is_con = isJust semi_tag
1169
1170     (srt_label,srt_len)
1171         | Just tag <- semi_tag = (mkIntCLit 0, tag) -- constructor
1172         | otherwise =
1173           case srt of
1174             NoC_SRT -> (mkIntCLit 0, 0)
1175             C_SRT lbl off len ->
1176               (CAddr (CIndex (CLbl lbl DataPtrRep) (mkIntCLit off) WordRep),
1177                len)
1178
1179     ptrs  = closurePtrsSize cl_info
1180     nptrs = size - ptrs
1181     size  = closureNonHdrSize cl_info
1182
1183     layout_info :: StgWord
1184 #ifdef WORDS_BIGENDIAN
1185     layout_info = (fromIntegral ptrs `shiftL` HALF_WORD) .|. fromIntegral nptrs
1186 #else
1187     layout_info = (fromIntegral ptrs) .|. (fromIntegral nptrs `shiftL` HALF_WORD)
1188 #endif
1189
1190     layout_amode = CLit (MachWord (fromIntegral layout_info))
1191
1192     extra_bits
1193         | is_fun    = fun_extra_bits
1194         | is_con    = []
1195         | needs_srt = [srt_label]
1196         | otherwise = []
1197
1198     maybe_fun_stuff = closureFunInfo cl_info
1199     is_fun = isJust maybe_fun_stuff
1200     (Just (arity, arg_descr)) = maybe_fun_stuff
1201
1202     fun_extra_bits
1203         | opt_Unregisterised = reverse reg_fun_extra_bits
1204         | otherwise          = reg_fun_extra_bits
1205
1206     reg_fun_extra_bits
1207         | ArgGen slow_lbl liveness <- arg_descr
1208                 = [
1209                    CLbl slow_lbl CodePtrRep,
1210                    livenessToAddrMode liveness,
1211                    srt_label,
1212                    mkIntCLit fun_desc
1213                   ]
1214         | needs_srt = [srt_label, mkIntCLit fun_desc]
1215         | otherwise = [mkIntCLit fun_desc]
1216
1217 #ifdef WORDS_BIGENDIAN
1218     fun_desc = (fromIntegral fun_type `shiftL` HALF_WORD) .|. fromIntegral arity
1219 #else
1220     fun_desc = (fromIntegral fun_type) .|. (fromIntegral arity `shiftL` HALF_WORD)
1221 #endif
1222
1223     fun_type = case arg_descr of
1224                 ArgSpec n -> n
1225                 ArgGen _ (Liveness _ size _)
1226                         | size <= mAX_SMALL_BITMAP_SIZE -> ARG_GEN
1227                         | otherwise                     -> ARG_GEN_BIG
1228
1229 -- Return info tables come in two flavours: direct returns and
1230 -- vectored returns.
1231
1232 mkRetInfoTable :: CLabel -> C_SRT -> Liveness -> [CAddrMode]
1233 mkRetInfoTable entry_lbl srt liveness
1234  = mkBitmapInfoTable (CLbl entry_lbl CodePtrRep) srt liveness []
1235
1236 mkVecInfoTable :: [CAddrMode] -> C_SRT -> Liveness -> [CAddrMode]
1237 mkVecInfoTable vector srt liveness
1238  = mkBitmapInfoTable zero_amode srt liveness vector
1239
1240 mkBitmapInfoTable
1241    :: CAddrMode
1242    -> C_SRT -> Liveness
1243    -> [CAddrMode]
1244    -> [CAddrMode]
1245 mkBitmapInfoTable entry_amode srt liveness vector
1246  | opt_Unregisterised = std_info ++ extra_bits
1247  | otherwise          = extra_bits ++ std_info
1248  where
1249    std_info = mkStdInfoTable entry_amode zero_amode zero_amode
1250                 cl_type srt_len liveness_amode
1251
1252    liveness_amode = livenessToAddrMode liveness
1253
1254    (srt_label,srt_len) =
1255           case srt of
1256             NoC_SRT -> (mkIntCLit 0, 0)
1257             C_SRT lbl off len ->
1258               (CAddr (CIndex (CLbl lbl DataPtrRep) (mkIntCLit off) WordRep),
1259                len)
1260
1261    cl_type = case (null vector, isBigLiveness liveness) of
1262                 (True, True)   -> rET_BIG
1263                 (True, False)  -> rET_SMALL
1264                 (False, True)  -> rET_VEC_BIG
1265                 (False, False) -> rET_VEC_SMALL
1266
1267    srt_bit | needsSRT srt || not (null vector) = [srt_label]
1268            | otherwise = []
1269
1270    extra_bits | opt_Unregisterised = srt_bit ++ vector
1271               | otherwise          = reverse vector ++ srt_bit
1272
1273 -- The standard bits of an info table.  This part of the info table
1274 -- corresponds to the StgInfoTable type defined in InfoTables.h.
1275
1276 mkStdInfoTable
1277    :: CAddrMode                         -- entry label
1278    -> CAddrMode                         -- closure type descr (profiling)
1279    -> CAddrMode                         -- closure descr (profiling)
1280    -> Int                               -- closure type
1281    -> Int                               -- SRT length
1282    -> CAddrMode                         -- layout field
1283    -> [CAddrMode]
1284 mkStdInfoTable entry_lbl type_descr closure_descr cl_type srt_len layout_amode
1285  = std_info
1286  where
1287     std_info
1288         | opt_Unregisterised  = entry_lbl : std_info'
1289         | otherwise           = std_info'
1290
1291     std_info' =
1292           -- par info
1293           prof_info ++
1294           -- ticky info
1295           -- debug info
1296           [layout_amode] ++
1297           CLit (MachWord (fromIntegral type_info)) :
1298           []
1299
1300     prof_info
1301         | opt_SccProfilingOn = [ type_descr, closure_descr ]
1302         | otherwise = []
1303
1304     -- sigh: building up the info table is endian-dependent.
1305     -- ToDo: do this using .byte and .word directives.
1306     type_info :: StgWord
1307 #ifdef WORDS_BIGENDIAN
1308     type_info = (fromIntegral cl_type `shiftL` HALF_WORD) .|.
1309                 (fromIntegral srt_len)
1310 #else
1311     type_info = (fromIntegral cl_type) .|.
1312                 (fromIntegral srt_len `shiftL` HALF_WORD)
1313 #endif
1314
1315 isBigLiveness (Liveness _ size _) = size > mAX_SMALL_BITMAP_SIZE
1316
1317 livenessToAddrMode :: Liveness -> CAddrMode
1318 livenessToAddrMode (Liveness lbl size bits)
1319         | size <= mAX_SMALL_BITMAP_SIZE = small
1320         | otherwise = CLbl lbl DataPtrRep
1321         where
1322           small = mkIntCLit (fromIntegral size .|. (small_bits `shiftL` bITMAP_BITS_SHIFT))
1323           small_bits = case bits of
1324                         []  -> 0
1325                         [b] -> intBS b
1326                         _   -> panic "livenessToAddrMode"
1327
1328 mAX_SMALL_BITMAP_SIZE = (wORD_SIZE * 8) - bITMAP_BITS_SHIFT
1329
1330 zero_amode = mkIntCLit 0
1331 \end{code}