ghc/compiler/codeGen/ClosureInfo.lhs

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