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