ghc/compiler/codeGen/ClosureInfo.lhs

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