compiler/codeGen/StgCmmClosure.hs

   1 -----------------------------------------------------------------------------
   2 --
   3 -- Stg to C-- code generation:
   4 --
   5 -- The types   LambdaFormInfo
   6 --             ClosureInfo
   7 --
   8 -- Nothing monadic in here!
   9 --
  10 -- (c) The University of Glasgow 2004-2006
  11 --
  12 -----------------------------------------------------------------------------
  13
  14
  15 module StgCmmClosure (
  16         SMRep,
  17         DynTag,  tagForCon, isSmallFamily,
  18         ConTagZ, dataConTagZ,
  19
  20         ArgDescr(..), Liveness(..),
  21         C_SRT(..), needsSRT,
  22
  23         isVoidRep, isGcPtrRep, addIdReps, addArgReps,
  24         argPrimRep,
  25
  26         LambdaFormInfo,         -- Abstract
  27         StandardFormInfo,       -- ...ditto...
  28         mkLFThunk, mkLFReEntrant, mkConLFInfo, mkSelectorLFInfo,
  29         mkApLFInfo, mkLFImported, mkLFArgument, mkLFLetNoEscape,
  30         lfDynTag,
  31
  32         ClosureInfo,
  33         mkClosureInfo, mkConInfo, maybeIsLFCon,
  34
  35         closureSize, closureNonHdrSize,
  36         closureGoodStuffSize, closurePtrsSize,
  37         slopSize,
  38
  39         closureName, infoTableLabelFromCI,
  40         closureLabelFromCI,
  41         closureTypeInfo,
  42         closureLFInfo, isLFThunk,closureSMRep, closureUpdReqd,
  43         closureNeedsUpdSpace, closureIsThunk,
  44         closureSingleEntry, closureReEntrant, isConstrClosure_maybe,
  45         closureFunInfo, isStandardFormThunk, isKnownFun,
  46         funTag, tagForArity,
  47
  48         enterIdLabel, enterLocalIdLabel,
  49
  50         nodeMustPointToIt,
  51         CallMethod(..), getCallMethod,
  52
  53         blackHoleOnEntry,
  54
  55         getClosureType,
  56
  57         isToplevClosure,
  58         closureValDescr, closureTypeDescr,      -- profiling
  59
  60         isStaticClosure,
  61         cafBlackHoleClosureInfo, seCafBlackHoleClosureInfo,
  62
  63         staticClosureNeedsLink, clHasCafRefs
  64     ) where
  65
  66 #include "../includes/MachDeps.h"
  67
  68 #define FAST_STRING_NOT_NEEDED
  69 #include "HsVersions.h"
  70
  71 import ClosureInfo (ArgDescr(..), C_SRT(..), Liveness(..))
  72         -- XXX temporary becuase FunInfo needs this one
  73
  74 import StgSyn
  75 import SMRep
  76 import Cmm      ( ClosureTypeInfo(..) )
  77 import CmmExpr
  78
  79 import CLabel
  80 import StaticFlags
  81 import Id
  82 import IdInfo
  83 import DataCon
  84 import Name
  85 import OccName
  86 import Type
  87 import TypeRep
  88 import TcType
  89 import TyCon
  90 import BasicTypes
  91 import Outputable
  92 import Constants
  93
  94
  95 -----------------------------------------------------------------------------
  96 --              Representations
  97 -----------------------------------------------------------------------------
  98
  99 addIdReps :: [Id] -> [(PrimRep, Id)]
 100 addIdReps ids = [(idPrimRep id, id) | id <- ids]
 101
 102 addArgReps :: [StgArg] -> [(PrimRep, StgArg)]
 103 addArgReps args = [(argPrimRep arg, arg) | arg <- args]
 104
 105 argPrimRep :: StgArg -> PrimRep
 106 argPrimRep arg = typePrimRep (stgArgType arg)
 107
 108 isVoidRep :: PrimRep -> Bool
 109 isVoidRep VoidRep = True
 110 isVoidRep _other  = False
 111
 112 isGcPtrRep :: PrimRep -> Bool
 113 isGcPtrRep PtrRep = True
 114 isGcPtrRep _      = False
 115
 116
 117 -----------------------------------------------------------------------------
 118 --              LambdaFormInfo
 119 -----------------------------------------------------------------------------
 120
 121 -- Information about an identifier, from the code generator's point of
 122 -- view.  Every identifier is bound to a LambdaFormInfo in the
 123 -- environment, which gives the code generator enough info to be able to
 124 -- tail call or return that identifier.
 125
 126 data LambdaFormInfo
 127   = LFReEntrant         -- Reentrant closure (a function)
 128         TopLevelFlag    -- True if top level
 129         !Int            -- Arity. Invariant: always > 0
 130         !Bool           -- True <=> no fvs
 131         ArgDescr        -- Argument descriptor (should really be in ClosureInfo)
 132
 133   | LFThunk             -- Thunk (zero arity)
 134         TopLevelFlag
 135         !Bool           -- True <=> no free vars
 136         !Bool           -- True <=> updatable (i.e., *not* single-entry)
 137         StandardFormInfo
 138         !Bool           -- True <=> *might* be a function type
 139
 140   | LFCon               -- A saturated constructor application
 141         DataCon         -- The constructor
 142
 143   | LFUnknown           -- Used for function arguments and imported things.
 144                         -- We know nothing about this closure.
 145                         -- Treat like updatable "LFThunk"...
 146                         -- Imported things which we *do* know something about use
 147                         -- one of the other LF constructors (eg LFReEntrant for
 148                         -- known functions)
 149         !Bool           -- True <=> *might* be a function type
 150                         --      The False case is good when we want to enter it,
 151                         --      because then we know the entry code will do
 152                         --      For a function, the entry code is the fast entry point
 153
 154   | LFUnLifted          -- A value of unboxed type;
 155                         -- always a value, neeeds evaluation
 156
 157   | LFLetNoEscape       -- See LetNoEscape module for precise description
 158
 159   | LFBlackHole         -- Used for the closures allocated to hold the result
 160                         -- of a CAF.  We want the target of the update frame to
 161                         -- be in the heap, so we make a black hole to hold it.
 162         CLabel          -- Flavour (info label, eg CAF_BLACKHOLE_info).
 163
 164
 165 -------------------------
 166 -- An ArgDsecr describes the argument pattern of a function
 167
 168 {-      XXX  -- imported from old ClosureInfo for now
 169 data ArgDescr
 170   = ArgSpec             -- Fits one of the standard patterns
 171         !StgHalfWord    -- RTS type identifier ARG_P, ARG_N, ...
 172
 173   | ArgGen              -- General case
 174         Liveness        -- Details about the arguments
 175 -}
 176
 177 {-      XXX  -- imported from old ClosureInfo for now
 178 -------------------------
 179 -- We represent liveness bitmaps as a Bitmap (whose internal
 180 -- representation really is a bitmap).  These are pinned onto case return
 181 -- vectors to indicate the state of the stack for the garbage collector.
 182 --
 183 -- In the compiled program, liveness bitmaps that fit inside a single
 184 -- word (StgWord) are stored as a single word, while larger bitmaps are
 185 -- stored as a pointer to an array of words.
 186
 187 data Liveness
 188   = SmallLiveness       -- Liveness info that fits in one word
 189         StgWord         -- Here's the bitmap
 190
 191   | BigLiveness         -- Liveness info witha a multi-word bitmap
 192         CLabel          -- Label for the bitmap
 193 -}
 194
 195 -------------------------
 196 -- StandardFormInfo tells whether this thunk has one of
 197 -- a small number of standard forms
 198
 199 data StandardFormInfo
 200   = NonStandardThunk
 201         -- Not of of the standard forms
 202
 203   | SelectorThunk
 204         -- A SelectorThunk is of form
 205         --      case x of
 206         --             con a1,..,an -> ak
 207         -- and the constructor is from a single-constr type.
 208        WordOff          -- 0-origin offset of ak within the "goods" of
 209                         -- constructor (Recall that the a1,...,an may be laid
 210                         -- out in the heap in a non-obvious order.)
 211
 212   | ApThunk
 213         -- An ApThunk is of form
 214         --      x1 ... xn
 215         -- The code for the thunk just pushes x2..xn on the stack and enters x1.
 216         -- There are a few of these (for 1 <= n <= MAX_SPEC_AP_SIZE) pre-compiled
 217         -- in the RTS to save space.
 218         Int             -- Arity, n
 219
 220
 221 ------------------------------------------------------
 222 --              Building LambdaFormInfo
 223 ------------------------------------------------------
 224
 225 mkLFArgument :: Id -> LambdaFormInfo
 226 mkLFArgument id
 227   | isUnLiftedType ty      = LFUnLifted
 228   | might_be_a_function ty = LFUnknown True
 229   | otherwise              = LFUnknown False
 230   where
 231     ty = idType id
 232
 233 -------------
 234 mkLFLetNoEscape :: LambdaFormInfo
 235 mkLFLetNoEscape = LFLetNoEscape
 236
 237 -------------
 238 mkLFReEntrant :: TopLevelFlag   -- True of top level
 239               -> [Id]           -- Free vars
 240               -> [Id]           -- Args
 241               -> ArgDescr       -- Argument descriptor
 242               -> LambdaFormInfo
 243
 244 mkLFReEntrant top fvs args arg_descr
 245   = LFReEntrant top (length args) (null fvs) arg_descr
 246
 247 -------------
 248 mkLFThunk :: Type -> TopLevelFlag -> [Id] -> UpdateFlag -> LambdaFormInfo
 249 mkLFThunk thunk_ty top fvs upd_flag
 250   = ASSERT( not (isUpdatable upd_flag) || not (isUnLiftedType thunk_ty) )
 251     LFThunk top (null fvs)
 252             (isUpdatable upd_flag)
 253             NonStandardThunk
 254             (might_be_a_function thunk_ty)
 255
 256 --------------
 257 might_be_a_function :: Type -> Bool
 258 -- Return False only if we are *sure* it's a data type
 259 -- Look through newtypes etc as much as poss
 260 might_be_a_function ty
 261   = case splitTyConApp_maybe (repType ty) of
 262         Just (tc, _) -> not (isDataTyCon tc)
 263         Nothing      -> True
 264
 265 -------------
 266 mkConLFInfo :: DataCon -> LambdaFormInfo
 267 mkConLFInfo con = LFCon con
 268
 269 -------------
 270 mkSelectorLFInfo :: Id -> Int -> Bool -> LambdaFormInfo
 271 mkSelectorLFInfo id offset updatable
 272   = LFThunk NotTopLevel False updatable (SelectorThunk offset)
 273         (might_be_a_function (idType id))
 274
 275 -------------
 276 mkApLFInfo :: Id -> UpdateFlag -> Arity -> LambdaFormInfo
 277 mkApLFInfo id upd_flag arity
 278   = LFThunk NotTopLevel (arity == 0) (isUpdatable upd_flag) (ApThunk arity)
 279         (might_be_a_function (idType id))
 280
 281 -------------
 282 mkLFImported :: Id -> LambdaFormInfo
 283 mkLFImported id
 284   | Just con <- isDataConWorkId_maybe id
 285   , isNullaryRepDataCon con
 286   = LFCon con   -- An imported nullary constructor
 287                 -- We assume that the constructor is evaluated so that
 288                 -- the id really does point directly to the constructor
 289
 290   | arity > 0
 291   = LFReEntrant TopLevel arity True (panic "arg_descr")
 292
 293   | otherwise
 294   = mkLFArgument id -- Not sure of exact arity
 295   where
 296     arity = idArity id
 297
 298 -----------------------------------------------------
 299 --              Dynamic pointer tagging
 300 -----------------------------------------------------
 301
 302 type ConTagZ = Int      -- A *zero-indexed* contructor tag
 303
 304 type DynTag = Int       -- The tag on a *pointer*
 305                         -- (from the dynamic-tagging paper)
 306
 307 {-      Note [Data constructor dynamic tags]
 308         ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 309 The family size of a data type (the number of constructors)
 310 can be either:
 311     * small, if the family size < 2**tag_bits
 312     * big, otherwise.
 313
 314 Small families can have the constructor tag in the tag bits.
 315 Big families only use the tag value 1 to represent evaluatedness. -}
 316
 317 isSmallFamily :: Int -> Bool
 318 isSmallFamily fam_size = fam_size <= mAX_PTR_TAG
 319
 320 -- We keep the *zero-indexed* tag in the srt_len field of the info
 321 -- table of a data constructor.
 322 dataConTagZ :: DataCon -> ConTagZ
 323 dataConTagZ con = dataConTag con - fIRST_TAG
 324
 325 tagForCon :: DataCon -> DynTag
 326 tagForCon con
 327   | isSmallFamily fam_size = con_tag + 1
 328   | otherwise              = 1
 329   where
 330     con_tag  = dataConTagZ con
 331     fam_size = tyConFamilySize (dataConTyCon con)
 332
 333 tagForArity :: Int -> DynTag
 334 tagForArity arity | isSmallFamily arity = arity
 335                   | otherwise           = 0
 336
 337 lfDynTag :: LambdaFormInfo -> DynTag
 338 lfDynTag (LFCon con)               = tagForCon con
 339 lfDynTag (LFReEntrant _ arity _ _) = tagForArity arity
 340 lfDynTag _other                    = 0
 341
 342
 343 -----------------------------------------------------------------------------
 344 --              Observing LambdaFormInfo
 345 -----------------------------------------------------------------------------
 346
 347 -------------
 348 maybeIsLFCon :: LambdaFormInfo -> Maybe DataCon
 349 maybeIsLFCon (LFCon con) = Just con
 350 maybeIsLFCon _ = Nothing
 351
 352 ------------
 353 isLFThunk :: LambdaFormInfo -> Bool
 354 isLFThunk (LFThunk _ _ _ _ _)  = True
 355 isLFThunk (LFBlackHole _)      = True
 356         -- return True for a blackhole: this function is used to determine
 357         -- whether to use the thunk header in SMP mode, and a blackhole
 358         -- must have one.
 359 isLFThunk _ = False
 360
 361
 362 -----------------------------------------------------------------------------
 363 --              Choosing SM reps
 364 -----------------------------------------------------------------------------
 365
 366 chooseSMRep
 367         :: Bool                 -- True <=> static closure
 368         -> LambdaFormInfo
 369         -> WordOff -> WordOff   -- Tot wds, ptr wds
 370         -> SMRep
 371
 372 chooseSMRep is_static lf_info tot_wds ptr_wds
 373   = let
 374          nonptr_wds   = tot_wds - ptr_wds
 375          closure_type = getClosureType is_static ptr_wds lf_info
 376     in
 377     GenericRep is_static ptr_wds nonptr_wds closure_type
 378
 379 -- We *do* get non-updatable top-level thunks sometimes.  eg. f = g
 380 -- gets compiled to a jump to g (if g has non-zero arity), instead of
 381 -- messing around with update frames and PAPs.  We set the closure type
 382 -- to FUN_STATIC in this case.
 383
 384 getClosureType :: Bool -> WordOff -> LambdaFormInfo -> ClosureType
 385 getClosureType is_static ptr_wds lf_info
 386   = case lf_info of
 387         LFCon {} | is_static && ptr_wds == 0 -> ConstrNoCaf
 388                  | otherwise                 -> Constr
 389         LFReEntrant {}                       -> Fun
 390         LFThunk _ _ _ (SelectorThunk {}) _   -> ThunkSelector
 391         LFThunk {}                           -> Thunk
 392         _ -> panic "getClosureType"
 393
 394
 395 -----------------------------------------------------------------------------
 396 --              nodeMustPointToIt
 397 -----------------------------------------------------------------------------
 398
 399 -- Be sure to see the stg-details notes about these...
 400
 401 nodeMustPointToIt :: LambdaFormInfo -> Bool
 402 nodeMustPointToIt (LFReEntrant top _ no_fvs _)
 403   = not no_fvs ||   -- Certainly if it has fvs we need to point to it
 404     isNotTopLevel top
 405                     -- If it is not top level we will point to it
 406                     --   We can have a \r closure with no_fvs which
 407                     --   is not top level as special case cgRhsClosure
 408                     --   has been dissabled in favour of let floating
 409
 410                 -- For lex_profiling we also access the cost centre for a
 411                 -- non-inherited function i.e. not top level
 412                 -- the  not top  case above ensures this is ok.
 413
 414 nodeMustPointToIt (LFCon _) = True
 415
 416         -- Strictly speaking, the above two don't need Node to point
 417         -- to it if the arity = 0.  But this is a *really* unlikely
 418         -- situation.  If we know it's nil (say) and we are entering
 419         -- it. Eg: let x = [] in x then we will certainly have inlined
 420         -- x, since nil is a simple atom.  So we gain little by not
 421         -- having Node point to known zero-arity things.  On the other
 422         -- hand, we do lose something; Patrick's code for figuring out
 423         -- when something has been updated but not entered relies on
 424         -- having Node point to the result of an update.  SLPJ
 425         -- 27/11/92.
 426
 427 nodeMustPointToIt (LFThunk _ no_fvs updatable NonStandardThunk _)
 428   = updatable || not no_fvs || opt_SccProfilingOn
 429           -- For the non-updatable (single-entry case):
 430           --
 431           -- True if has fvs (in which case we need access to them, and we
 432           --                should black-hole it)
 433           -- or profiling (in which case we need to recover the cost centre
 434           --             from inside it)
 435
 436 nodeMustPointToIt (LFThunk {})  -- Node must point to a standard-form thunk
 437   = True
 438
 439 nodeMustPointToIt (LFUnknown _)   = True
 440 nodeMustPointToIt LFUnLifted      = False
 441 nodeMustPointToIt (LFBlackHole _) = True    -- BH entry may require Node to point
 442 nodeMustPointToIt LFLetNoEscape   = False
 443
 444 -----------------------------------------------------------------------------
 445 --              getCallMethod
 446 -----------------------------------------------------------------------------
 447
 448 {- The entry conventions depend on the type of closure being entered,
 449 whether or not it has free variables, and whether we're running
 450 sequentially or in parallel.
 451
 452 Closure                               Node   Argument   Enter
 453 Characteristics                 Par   Req'd  Passing    Via
 454 -------------------------------------------------------------------------------
 455 Unknown                         & no & yes & stack      & node
 456 Known fun (>1 arg), no fvs      & no & no  & registers  & fast entry (enough args)
 457                                                         & slow entry (otherwise)
 458 Known fun (>1 arg), fvs         & no & yes & registers  & fast entry (enough args)
 459 0 arg, no fvs \r,\s             & no & no  & n/a        & direct entry
 460 0 arg, no fvs \u                & no & yes & n/a        & node
 461 0 arg, fvs \r,\s                & no & yes & n/a        & direct entry
 462 0 arg, fvs \u                   & no & yes & n/a        & node
 463
 464 Unknown                         & yes & yes & stack     & node
 465 Known fun (>1 arg), no fvs      & yes & no  & registers & fast entry (enough args)
 466                                                         & slow entry (otherwise)
 467 Known fun (>1 arg), fvs         & yes & yes & registers & node
 468 0 arg, no fvs \r,\s             & yes & no  & n/a       & direct entry
 469 0 arg, no fvs \u                & yes & yes & n/a       & node
 470 0 arg, fvs \r,\s                & yes & yes & n/a       & node
 471 0 arg, fvs \u                   & yes & yes & n/a       & node
 472 \end{tabular}
 473
 474 When black-holing, single-entry closures could also be entered via node
 475 (rather than directly) to catch double-entry. -}
 476
 477 data CallMethod
 478   = EnterIt             -- No args, not a function
 479
 480   | JumpToIt            -- A join point
 481
 482   | ReturnIt            -- It's a value (function, unboxed value,
 483                         -- or constructor), so just return it.
 484
 485   | SlowCall            -- Unknown fun, or known fun with
 486                         -- too few args.
 487
 488   | DirectEntry         -- Jump directly, with args in regs
 489         CLabel          --   The code label
 490         Int             --   Its arity
 491
 492 getCallMethod :: Name           -- Function being applied
 493               -> CafInfo        -- Can it refer to CAF's?
 494               -> LambdaFormInfo -- Its info
 495               -> Int            -- Number of available arguments
 496               -> CallMethod
 497
 498 getCallMethod _name _ lf_info _n_args
 499   | nodeMustPointToIt lf_info && opt_Parallel
 500   =     -- If we're parallel, then we must always enter via node.
 501         -- The reason is that the closure may have been
 502         -- fetched since we allocated it.
 503     EnterIt
 504
 505 getCallMethod name caf (LFReEntrant _ arity _ _) n_args
 506   | n_args == 0    = ASSERT( arity /= 0 )
 507                      ReturnIt   -- No args at all
 508   | n_args < arity = SlowCall   -- Not enough args
 509   | otherwise      = DirectEntry (enterIdLabel name caf) arity
 510
 511 getCallMethod _name _ LFUnLifted n_args
 512   = ASSERT( n_args == 0 ) ReturnIt
 513
 514 getCallMethod _name _ (LFCon _) n_args
 515   = ASSERT( n_args == 0 ) ReturnIt
 516
 517 getCallMethod name caf (LFThunk _ _ updatable std_form_info is_fun) n_args
 518   | is_fun      -- it *might* be a function, so we must "call" it (which is always safe)
 519   = SlowCall    -- We cannot just enter it [in eval/apply, the entry code
 520                 -- is the fast-entry code]
 521
 522   -- Since is_fun is False, we are *definitely* looking at a data value
 523   | updatable || opt_DoTickyProfiling  -- to catch double entry
 524       {- OLD: || opt_SMP
 525          I decided to remove this, because in SMP mode it doesn't matter
 526          if we enter the same thunk multiple times, so the optimisation
 527          of jumping directly to the entry code is still valid.  --SDM
 528         -}
 529   = EnterIt
 530     -- We used to have ASSERT( n_args == 0 ), but actually it is
 531     -- possible for the optimiser to generate
 532     --   let bot :: Int = error Int "urk"
 533     --   in (bot `cast` unsafeCoerce Int (Int -> Int)) 3
 534     -- This happens as a result of the case-of-error transformation
 535     -- So the right thing to do is just to enter the thing
 536
 537   | otherwise   -- Jump direct to code for single-entry thunks
 538   = ASSERT( n_args == 0 )
 539     DirectEntry (thunkEntryLabel name caf std_form_info updatable) 0
 540
 541 getCallMethod _name _ (LFUnknown True) _n_args
 542   = SlowCall -- might be a function
 543
 544 getCallMethod name _ (LFUnknown False) n_args
 545   = ASSERT2 ( n_args == 0, ppr name <+> ppr n_args )
 546     EnterIt -- Not a function
 547
 548 getCallMethod _name _ (LFBlackHole _) _n_args
 549   = SlowCall    -- Presumably the black hole has by now
 550                 -- been updated, but we don't know with
 551                 -- what, so we slow call it
 552
 553 getCallMethod _name _ LFLetNoEscape _n_args
 554   = JumpToIt
 555
 556 isStandardFormThunk :: LambdaFormInfo -> Bool
 557 isStandardFormThunk (LFThunk _ _ _ (SelectorThunk _) _) = True
 558 isStandardFormThunk (LFThunk _ _ _ (ApThunk _) _)       = True
 559 isStandardFormThunk _other_lf_info                      = False
 560
 561 isKnownFun :: LambdaFormInfo -> Bool
 562 isKnownFun (LFReEntrant _ _ _ _) = True
 563 isKnownFun LFLetNoEscape         = True
 564 isKnownFun _ = False
 565
 566 -----------------------------------------------------------------------------
 567 --              staticClosureRequired
 568 -----------------------------------------------------------------------------
 569
 570 {-  staticClosureRequired is never called (hence commented out)
 571
 572     SimonMar writes (Sept 07) It's an optimisation we used to apply at
 573     one time, I believe, but it got lost probably in the rewrite of
 574     the RTS/code generator.  I left that code there to remind me to
 575     look into whether it was worth doing sometime
 576
 577 {- Avoiding generating entries and info tables
 578    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 579 At present, for every function we generate all of the following,
 580 just in case.  But they aren't always all needed, as noted below:
 581
 582 [NB1: all of this applies only to *functions*.  Thunks always
 583 have closure, info table, and entry code.]
 584
 585 [NB2: All are needed if the function is *exported*, just to play safe.]
 586
 587 * Fast-entry code  ALWAYS NEEDED
 588
 589 * Slow-entry code
 590         Needed iff (a) we have any un-saturated calls to the function
 591         OR         (b) the function is passed as an arg
 592         OR         (c) we're in the parallel world and the function has free vars
 593                         [Reason: in parallel world, we always enter functions
 594                         with free vars via the closure.]
 595
 596 * The function closure
 597         Needed iff (a) we have any un-saturated calls to the function
 598         OR         (b) the function is passed as an arg
 599         OR         (c) if the function has free vars (ie not top level)
 600
 601   Why case (a) here?  Because if the arg-satis check fails,
 602   UpdatePAP stuffs a pointer to the function closure in the PAP.
 603   [Could be changed; UpdatePAP could stuff in a code ptr instead,
 604    but doesn't seem worth it.]
 605
 606   [NB: these conditions imply that we might need the closure
 607   without the slow-entry code.  Here's how.
 608
 609         f x y = let g w = ...x..y..w...
 610                 in
 611                 ...(g t)...
 612
 613   Here we need a closure for g which contains x and y,
 614   but since the calls are all saturated we just jump to the
 615   fast entry point for g, with R1 pointing to the closure for g.]
 616
 617
 618 * Standard info table
 619         Needed iff (a) we have any un-saturated calls to the function
 620         OR         (b) the function is passed as an arg
 621         OR         (c) the function has free vars (ie not top level)
 622
 623         NB.  In the sequential world, (c) is only required so that the function closure has
 624         an info table to point to, to keep the storage manager happy.
 625         If (c) alone is true we could fake up an info table by choosing
 626         one of a standard family of info tables, whose entry code just
 627         bombs out.
 628
 629         [NB In the parallel world (c) is needed regardless because
 630         we enter functions with free vars via the closure.]
 631
 632         If (c) is retained, then we'll sometimes generate an info table
 633         (for storage mgr purposes) without slow-entry code.  Then we need
 634         to use an error label in the info table to substitute for the absent
 635         slow entry code.
 636 -}
 637
 638 staticClosureRequired
 639         :: Name
 640         -> StgBinderInfo
 641         -> LambdaFormInfo
 642         -> Bool
 643 staticClosureRequired binder bndr_info
 644                       (LFReEntrant top_level _ _ _)     -- It's a function
 645   = ASSERT( isTopLevel top_level )
 646         -- Assumption: it's a top-level, no-free-var binding
 647         not (satCallsOnly bndr_info)
 648
 649 staticClosureRequired binder other_binder_info other_lf_info = True
 650 -}
 651
 652 -----------------------------------------------------------------------------
 653 --              Data types for closure information}
 654 -----------------------------------------------------------------------------
 655
 656
 657 {- Information about a closure, from the code generator's point of view.
 658
 659 A ClosureInfo decribes the info pointer of a closure.  It has
 660 enough information
 661   a) to construct the info table itself
 662   b) to allocate a closure containing that info pointer (i.e.
 663         it knows the info table label)
 664
 665 We make a ClosureInfo for
 666   - each let binding (both top level and not)
 667   - each data constructor (for its shared static and
 668         dynamic info tables)
 669 -}
 670
 671 data ClosureInfo
 672   = ClosureInfo {
 673         closureName   :: !Name,           -- The thing bound to this closure
 674         closureLFInfo :: !LambdaFormInfo, -- NOTE: not an LFCon (see below)
 675         closureSMRep  :: !SMRep,          -- representation used by storage mgr
 676         closureSRT    :: !C_SRT,          -- What SRT applies to this closure
 677         closureType   :: !Type,           -- Type of closure (ToDo: remove)
 678         closureDescr  :: !String          -- closure description (for profiling)
 679     }
 680
 681   -- Constructor closures don't have a unique info table label (they use
 682   -- the constructor's info table), and they don't have an SRT.
 683   | ConInfo {
 684         closureCon       :: !DataCon,
 685         closureSMRep     :: !SMRep
 686     }
 687
 688 {-      XXX temp imported from old ClosureInfo
 689 -- C_SRT is what StgSyn.SRT gets translated to...
 690 -- we add a label for the table, and expect only the 'offset/length' form
 691
 692 data C_SRT = NoC_SRT
 693            | C_SRT !CLabel !WordOff !StgHalfWord {-bitmap or escape-}
 694            deriving (Eq)
 695
 696 instance Outputable C_SRT where
 697   ppr (NoC_SRT) = ptext SLIT("_no_srt_")
 698   ppr (C_SRT label off bitmap) = parens (ppr label <> comma <> ppr off <> comma <> text (show bitmap))
 699 -}
 700
 701 needsSRT :: C_SRT -> Bool
 702 needsSRT NoC_SRT       = False
 703 needsSRT (C_SRT _ _ _) = True
 704
 705
 706 --------------------------------------
 707 --      Building ClosureInfos
 708 --------------------------------------
 709
 710 mkClosureInfo :: Bool           -- Is static
 711               -> Id
 712               -> LambdaFormInfo
 713               -> Int -> Int     -- Total and pointer words
 714               -> C_SRT
 715               -> String         -- String descriptor
 716               -> ClosureInfo
 717 mkClosureInfo is_static id lf_info tot_wds ptr_wds srt_info descr
 718   = ClosureInfo { closureName = name,
 719                   closureLFInfo = lf_info,
 720                   closureSMRep = sm_rep,
 721                   closureSRT = srt_info,
 722                   closureType = idType id,
 723                   closureDescr = descr }
 724   where
 725     name   = idName id
 726     sm_rep = chooseSMRep is_static lf_info tot_wds ptr_wds
 727
 728 mkConInfo :: Bool       -- Is static
 729           -> DataCon
 730           -> Int -> Int -- Total and pointer words
 731           -> ClosureInfo
 732 mkConInfo is_static data_con tot_wds ptr_wds
 733    = ConInfo {  closureSMRep = sm_rep,
 734                 closureCon = data_con }
 735   where
 736     sm_rep = chooseSMRep is_static (mkConLFInfo data_con) tot_wds ptr_wds
 737
 738
 739 -- We need a black-hole closure info to pass to @allocDynClosure@ when we
 740 -- want to allocate the black hole on entry to a CAF.  These are the only
 741 -- ways to build an LFBlackHole, maintaining the invariant that it really
 742 -- is a black hole and not something else.
 743
 744 cafBlackHoleClosureInfo :: ClosureInfo -> ClosureInfo
 745 cafBlackHoleClosureInfo (ClosureInfo { closureName = nm,
 746                                        closureType = ty })
 747   = ClosureInfo { closureName   = nm,
 748                   closureLFInfo = LFBlackHole mkCAFBlackHoleInfoTableLabel,
 749                   closureSMRep  = BlackHoleRep,
 750                   closureSRT    = NoC_SRT,
 751                   closureType   = ty,
 752                   closureDescr  = "" }
 753 cafBlackHoleClosureInfo _ = panic "cafBlackHoleClosureInfo"
 754
 755 seCafBlackHoleClosureInfo :: ClosureInfo -> ClosureInfo
 756 seCafBlackHoleClosureInfo (ClosureInfo { closureName = nm,
 757                                          closureType = ty })
 758   = ClosureInfo { closureName   = nm,
 759                   closureLFInfo = LFBlackHole mkSECAFBlackHoleInfoTableLabel,
 760                   closureSMRep  = BlackHoleRep,
 761                   closureSRT    = NoC_SRT,
 762                   closureType   = ty,
 763                   closureDescr  = ""  }
 764 seCafBlackHoleClosureInfo _ = panic "seCafBlackHoleClosureInfo"
 765
 766 --------------------------------------
 767 --   Extracting ClosureTypeInfo
 768 --------------------------------------
 769
 770 closureTypeInfo :: ClosureInfo -> ClosureTypeInfo
 771 closureTypeInfo cl_info
 772    = case cl_info of
 773         ConInfo { closureCon = con }
 774                 -> ConstrInfo (ptrs, nptrs)
 775                               (fromIntegral (dataConTagZ con))
 776                               con_name
 777                 where
 778                   con_name = panic "closureTypeInfo"
 779                         -- Was:
 780                         -- cstr <- mkByteStringCLit $ dataConIdentity con
 781                         -- con_name = makeRelativeRefTo info_lbl cstr
 782
 783         ClosureInfo { closureName   = name,
 784                       closureLFInfo = LFReEntrant _ arity _ arg_descr,
 785                       closureSRT    = srt }
 786                 -> FunInfo (ptrs, nptrs)
 787                            srt
 788                            (fromIntegral arity)
 789                            arg_descr
 790                            (CmmLabel (mkSlowEntryLabel name (clHasCafRefs cl_info)))
 791
 792         ClosureInfo { closureLFInfo = LFThunk _ _ _ (SelectorThunk offset) _,
 793                       closureSRT    = srt }
 794                 -> ThunkSelectorInfo (fromIntegral offset) srt
 795
 796         ClosureInfo { closureLFInfo = LFThunk {},
 797                       closureSRT    = srt }
 798                 -> ThunkInfo (ptrs, nptrs) srt
 799
 800         _ -> panic "unexpected lambda form in mkCmmInfo"
 801   where
 802 --    info_lbl = infoTableLabelFromCI cl_info
 803     ptrs     = fromIntegral $ closurePtrsSize cl_info
 804     size     = fromIntegral $ closureNonHdrSize cl_info
 805     nptrs    = size - ptrs
 806
 807 --------------------------------------
 808 --   Functions about closure *sizes*
 809 --------------------------------------
 810
 811 closureSize :: ClosureInfo -> WordOff
 812 closureSize cl_info = hdr_size + closureNonHdrSize cl_info
 813   where hdr_size  | closureIsThunk cl_info = thunkHdrSize
 814                   | otherwise              = fixedHdrSize
 815         -- All thunks use thunkHdrSize, even if they are non-updatable.
 816         -- this is because we don't have separate closure types for
 817         -- updatable vs. non-updatable thunks, so the GC can't tell the
 818         -- difference.  If we ever have significant numbers of non-
 819         -- updatable thunks, it might be worth fixing this.
 820
 821 closureNonHdrSize :: ClosureInfo -> WordOff
 822 closureNonHdrSize cl_info
 823   = tot_wds + computeSlopSize tot_wds cl_info
 824   where
 825     tot_wds = closureGoodStuffSize cl_info
 826
 827 closureGoodStuffSize :: ClosureInfo -> WordOff
 828 closureGoodStuffSize cl_info
 829   = let (ptrs, nonptrs) = sizes_from_SMRep (closureSMRep cl_info)
 830     in  ptrs + nonptrs
 831
 832 closurePtrsSize :: ClosureInfo -> WordOff
 833 closurePtrsSize cl_info
 834   = let (ptrs, _) = sizes_from_SMRep (closureSMRep cl_info)
 835     in  ptrs
 836
 837 -- not exported:
 838 sizes_from_SMRep :: SMRep -> (WordOff,WordOff)
 839 sizes_from_SMRep (GenericRep _ ptrs nonptrs _)   = (ptrs, nonptrs)
 840 sizes_from_SMRep BlackHoleRep                    = (0, 0)
 841
 842 -- Computing slop size.  WARNING: this looks dodgy --- it has deep
 843 -- knowledge of what the storage manager does with the various
 844 -- representations...
 845 --
 846 -- Slop Requirements: every thunk gets an extra padding word in the
 847 -- header, which takes the the updated value.
 848
 849 slopSize :: ClosureInfo -> WordOff
 850 slopSize cl_info = computeSlopSize payload_size cl_info
 851   where payload_size = closureGoodStuffSize cl_info
 852
 853 computeSlopSize :: WordOff -> ClosureInfo -> WordOff
 854 computeSlopSize payload_size cl_info
 855   = max 0 (minPayloadSize smrep updatable - payload_size)
 856   where
 857         smrep        = closureSMRep cl_info
 858         updatable    = closureNeedsUpdSpace cl_info
 859
 860 closureNeedsUpdSpace :: ClosureInfo -> Bool
 861 -- We leave space for an update if either (a) the closure is updatable
 862 -- or (b) it is a static thunk.  This is because a static thunk needs
 863 -- a static link field in a predictable place (after the slop), regardless
 864 -- of whether it is updatable or not.
 865 closureNeedsUpdSpace (ClosureInfo { closureLFInfo =
 866                                         LFThunk TopLevel _ _ _ _ }) = True
 867 closureNeedsUpdSpace cl_info = closureUpdReqd cl_info
 868
 869 minPayloadSize :: SMRep -> Bool -> WordOff
 870 minPayloadSize smrep updatable
 871   = case smrep of
 872         BlackHoleRep                            -> min_upd_size
 873         GenericRep _ _ _ _      | updatable     -> min_upd_size
 874         GenericRep True _ _ _                   -> 0 -- static
 875         GenericRep False _ _ _                  -> mIN_PAYLOAD_SIZE
 876           --       ^^^^^___ dynamic
 877   where
 878    min_upd_size =
 879         ASSERT(mIN_PAYLOAD_SIZE <= sIZEOF_StgSMPThunkHeader)
 880         0       -- check that we already have enough
 881                 -- room for mIN_SIZE_NonUpdHeapObject,
 882                 -- due to the extra header word in SMP
 883
 884 --------------------------------------
 885 --   Other functions over ClosureInfo
 886 --------------------------------------
 887
 888 blackHoleOnEntry :: ClosureInfo -> Bool
 889 -- Static closures are never themselves black-holed.
 890 -- Updatable ones will be overwritten with a CAFList cell, which points to a
 891 -- black hole;
 892 -- Single-entry ones have no fvs to plug, and we trust they don't form part
 893 -- of a loop.
 894
 895 blackHoleOnEntry ConInfo{} = False
 896 blackHoleOnEntry (ClosureInfo { closureLFInfo = lf_info, closureSMRep = rep })
 897   | isStaticRep rep
 898   = False       -- Never black-hole a static closure
 899
 900   | otherwise
 901   = case lf_info of
 902         LFReEntrant _ _ _ _       -> False
 903         LFLetNoEscape             -> False
 904         LFThunk _ no_fvs updatable _ _
 905           -> if updatable
 906              then not opt_OmitBlackHoling
 907              else opt_DoTickyProfiling || not no_fvs
 908                   -- the former to catch double entry,
 909                   -- and the latter to plug space-leaks.  KSW/SDM 1999-04.
 910
 911         _other -> panic "blackHoleOnEntry"      -- Should never happen
 912
 913
 914 staticClosureNeedsLink :: ClosureInfo -> Bool
 915 -- A static closure needs a link field to aid the GC when traversing
 916 -- the static closure graph.  But it only needs such a field if either
 917 --      a) it has an SRT
 918 --      b) it's a constructor with one or more pointer fields
 919 -- In case (b), the constructor's fields themselves play the role
 920 -- of the SRT.
 921 staticClosureNeedsLink (ClosureInfo { closureSRT = srt })
 922   = needsSRT srt
 923 staticClosureNeedsLink (ConInfo { closureSMRep = sm_rep, closureCon = con })
 924   = not (isNullaryRepDataCon con) && not_nocaf_constr
 925   where
 926     not_nocaf_constr =
 927         case sm_rep of
 928            GenericRep _ _ _ ConstrNoCaf -> False
 929            _other                       -> True
 930
 931 isStaticClosure :: ClosureInfo -> Bool
 932 isStaticClosure cl_info = isStaticRep (closureSMRep cl_info)
 933
 934 closureUpdReqd :: ClosureInfo -> Bool
 935 closureUpdReqd ClosureInfo{ closureLFInfo = lf_info } = lfUpdatable lf_info
 936 closureUpdReqd ConInfo{} = False
 937
 938 lfUpdatable :: LambdaFormInfo -> Bool
 939 lfUpdatable (LFThunk _ _ upd _ _)  = upd
 940 lfUpdatable (LFBlackHole _)        = True
 941         -- Black-hole closures are allocated to receive the results of an
 942         -- alg case with a named default... so they need to be updated.
 943 lfUpdatable _ = False
 944
 945 closureIsThunk :: ClosureInfo -> Bool
 946 closureIsThunk ClosureInfo{ closureLFInfo = lf_info } = isLFThunk lf_info
 947 closureIsThunk ConInfo{} = False
 948
 949 closureSingleEntry :: ClosureInfo -> Bool
 950 closureSingleEntry (ClosureInfo { closureLFInfo = LFThunk _ _ upd _ _}) = not upd
 951 closureSingleEntry _ = False
 952
 953 closureReEntrant :: ClosureInfo -> Bool
 954 closureReEntrant (ClosureInfo { closureLFInfo = LFReEntrant _ _ _ _ }) = True
 955 closureReEntrant _ = False
 956
 957 isConstrClosure_maybe :: ClosureInfo -> Maybe DataCon
 958 isConstrClosure_maybe (ConInfo { closureCon = data_con }) = Just data_con
 959 isConstrClosure_maybe _                                   = Nothing
 960
 961 closureFunInfo :: ClosureInfo -> Maybe (Int, ArgDescr)
 962 closureFunInfo (ClosureInfo { closureLFInfo = lf_info }) = lfFunInfo lf_info
 963 closureFunInfo _ = Nothing
 964
 965 lfFunInfo :: LambdaFormInfo ->  Maybe (Int, ArgDescr)
 966 lfFunInfo (LFReEntrant _ arity _ arg_desc)  = Just (arity, arg_desc)
 967 lfFunInfo _                                 = Nothing
 968
 969 funTag :: ClosureInfo -> DynTag
 970 funTag (ClosureInfo { closureLFInfo = lf_info }) = lfDynTag lf_info
 971 funTag (ConInfo {})                              = panic "funTag"
 972
 973 isToplevClosure :: ClosureInfo -> Bool
 974 isToplevClosure (ClosureInfo { closureLFInfo = lf_info })
 975   = case lf_info of
 976       LFReEntrant TopLevel _ _ _ -> True
 977       LFThunk TopLevel _ _ _ _   -> True
 978       _other                     -> False
 979 isToplevClosure _ = False
 980
 981 --------------------------------------
 982 --   Label generation
 983 --------------------------------------
 984
 985 infoTableLabelFromCI :: ClosureInfo -> CLabel
 986 infoTableLabelFromCI cl@(ClosureInfo { closureName = name,
 987                                        closureLFInfo = lf_info })
 988   = case lf_info of
 989         LFBlackHole info -> info
 990
 991         LFThunk _ _ upd_flag (SelectorThunk offset) _ ->
 992                 mkSelectorInfoLabel upd_flag offset
 993
 994         LFThunk _ _ upd_flag (ApThunk arity) _ ->
 995                 mkApInfoTableLabel upd_flag arity
 996
 997         LFThunk{}      -> mkLocalInfoTableLabel name $ clHasCafRefs cl
 998
 999         LFReEntrant _ _ _ _ -> mkLocalInfoTableLabel name $ clHasCafRefs cl
1000
1001         _other -> panic "infoTableLabelFromCI"
1002
1003 infoTableLabelFromCI cl@(ConInfo { closureCon = con, closureSMRep = rep })
1004   | isStaticRep rep = mkStaticInfoTableLabel  name $ clHasCafRefs cl
1005   | otherwise       = mkConInfoTableLabel     name $ clHasCafRefs cl
1006   where
1007     name = dataConName con
1008
1009 -- ClosureInfo for a closure (as opposed to a constructor) is always local
1010 closureLabelFromCI :: ClosureInfo -> CLabel
1011 closureLabelFromCI cl@(ClosureInfo { closureName = nm }) =
1012   mkLocalClosureLabel nm $ clHasCafRefs cl
1013 closureLabelFromCI _ = panic "closureLabelFromCI"
1014
1015 thunkEntryLabel :: Name -> CafInfo -> StandardFormInfo -> Bool -> CLabel
1016 -- thunkEntryLabel is a local help function, not exported.  It's used from both
1017 -- entryLabelFromCI and getCallMethod.
1018 thunkEntryLabel _thunk_id _ (ApThunk arity) upd_flag
1019   = enterApLabel upd_flag arity
1020 thunkEntryLabel _thunk_id _ (SelectorThunk offset) upd_flag
1021   = enterSelectorLabel upd_flag offset
1022 thunkEntryLabel thunk_id c _ _
1023   = enterIdLabel thunk_id c
1024
1025 enterApLabel :: Bool -> Arity -> CLabel
1026 enterApLabel is_updatable arity
1027   | tablesNextToCode = mkApInfoTableLabel is_updatable arity
1028   | otherwise        = mkApEntryLabel is_updatable arity
1029
1030 enterSelectorLabel :: Bool -> WordOff -> CLabel
1031 enterSelectorLabel upd_flag offset
1032   | tablesNextToCode = mkSelectorInfoLabel upd_flag offset
1033   | otherwise        = mkSelectorEntryLabel upd_flag offset
1034
1035 enterIdLabel :: Name -> CafInfo -> CLabel
1036 enterIdLabel id c
1037   | tablesNextToCode = mkInfoTableLabel id c
1038   | otherwise        = mkEntryLabel id c
1039
1040 enterLocalIdLabel :: Name -> CafInfo -> CLabel
1041 enterLocalIdLabel id c
1042   | tablesNextToCode = mkLocalInfoTableLabel id c
1043   | otherwise        = mkLocalEntryLabel id c
1044
1045
1046 --------------------------------------
1047 --   Profiling
1048 --------------------------------------
1049
1050 -- Profiling requires two pieces of information to be determined for
1051 -- each closure's info table --- description and type.
1052
1053 -- The description is stored directly in the @CClosureInfoTable@ when the
1054 -- info table is built.
1055
1056 -- The type is determined from the type information stored with the @Id@
1057 -- in the closure info using @closureTypeDescr@.
1058
1059 closureValDescr, closureTypeDescr :: ClosureInfo -> String
1060 closureValDescr (ClosureInfo {closureDescr = descr})
1061   = descr
1062 closureValDescr (ConInfo {closureCon = con})
1063   = occNameString (getOccName con)
1064
1065 closureTypeDescr (ClosureInfo { closureType = ty })
1066   = getTyDescription ty
1067 closureTypeDescr (ConInfo { closureCon = data_con })
1068   = occNameString (getOccName (dataConTyCon data_con))
1069
1070 getTyDescription :: Type -> String
1071 getTyDescription ty
1072   = case (tcSplitSigmaTy ty) of { (_, _, tau_ty) ->
1073     case tau_ty of
1074       TyVarTy _              -> "*"
1075       AppTy fun _            -> getTyDescription fun
1076       FunTy _ res            -> '-' : '>' : fun_result res
1077       TyConApp tycon _       -> getOccString tycon
1078       PredTy sty             -> getPredTyDescription sty
1079       ForAllTy _ ty          -> getTyDescription ty
1080     }
1081   where
1082     fun_result (FunTy _ res) = '>' : fun_result res
1083     fun_result other         = getTyDescription other
1084
1085 getPredTyDescription :: PredType -> String
1086 getPredTyDescription (ClassP cl _)     = getOccString cl
1087 getPredTyDescription (IParam ip _)     = getOccString (ipNameName ip)
1088 getPredTyDescription (EqPred ty1 _ty2) = getTyDescription ty1   -- Urk?
1089
1090
1091 --------------------------------------
1092 --   SRTs/CAFs
1093 --------------------------------------
1094
1095 -- This is horrible, but we need to know whether a closure may have CAFs.
1096 clHasCafRefs :: ClosureInfo -> CafInfo
1097 clHasCafRefs (ClosureInfo {closureSRT = srt}) =
1098   case srt of NoC_SRT -> NoCafRefs
1099               _       -> MayHaveCafRefs
1100 clHasCafRefs (ConInfo {}) = NoCafRefs