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