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