never executed always true always false
    1 
    2 {-# LANGUAGE RecordWildCards #-}
    3 {-# LANGUAGE LambdaCase #-}
    4 {-# LANGUAGE MultiParamTypeClasses #-}
    5 {-# LANGUAGE FlexibleInstances #-}
    6 
    7 
    8 -----------------------------------------------------------------------------
    9 --
   10 -- Stg to C-- code generation:
   11 --
   12 -- The types   LambdaFormInfo
   13 --             ClosureInfo
   14 --
   15 -- Nothing monadic in here!
   16 --
   17 -----------------------------------------------------------------------------
   18 
   19 module GHC.StgToCmm.Closure (
   20         DynTag,  tagForCon, isSmallFamily,
   21 
   22         idPrimRep, isVoidRep, isGcPtrRep, addIdReps, addArgReps,
   23         argPrimRep,
   24 
   25         NonVoid(..), fromNonVoid, nonVoidIds, nonVoidStgArgs,
   26         assertNonVoidIds, assertNonVoidStgArgs,
   27 
   28         -- * LambdaFormInfo
   29         LambdaFormInfo,         -- Abstract
   30         StandardFormInfo,        -- ...ditto...
   31         mkLFThunk, mkLFReEntrant, mkConLFInfo, mkSelectorLFInfo,
   32         mkApLFInfo, mkLFImported, mkLFArgument, mkLFLetNoEscape,
   33         mkLFStringLit,
   34         lfDynTag,
   35         isLFThunk, isLFReEntrant, lfUpdatable,
   36 
   37         -- * Used by other modules
   38         CgLoc(..), SelfLoopInfo, CallMethod(..),
   39         nodeMustPointToIt, isKnownFun, funTag, tagForArity,
   40         CallOpts(..), getCallMethod,
   41 
   42         -- * ClosureInfo
   43         ClosureInfo,
   44         mkClosureInfo,
   45         mkCmmInfo,
   46 
   47         -- ** Inspection
   48         closureLFInfo, closureName,
   49 
   50         -- ** Labels
   51         -- These just need the info table label
   52         closureInfoLabel, staticClosureLabel,
   53         closureSlowEntryLabel, closureLocalEntryLabel,
   54 
   55         -- ** Predicates
   56         -- These are really just functions on LambdaFormInfo
   57         closureUpdReqd,
   58         closureReEntrant, closureFunInfo,
   59         isToplevClosure,
   60 
   61         blackHoleOnEntry,  -- Needs LambdaFormInfo and SMRep
   62         isStaticClosure,   -- Needs SMPre
   63 
   64         -- * InfoTables
   65         mkDataConInfoTable,
   66         cafBlackHoleInfoTable,
   67         indStaticInfoTable,
   68         staticClosureNeedsLink,
   69     ) where
   70 
   71 import GHC.Prelude
   72 import GHC.Platform
   73 import GHC.Platform.Profile
   74 
   75 import GHC.Stg.Syntax
   76 import GHC.Runtime.Heap.Layout
   77 import GHC.Cmm
   78 import GHC.Cmm.Utils
   79 import GHC.Cmm.Ppr.Expr() -- For Outputable instances
   80 import GHC.StgToCmm.Types
   81 
   82 import GHC.Types.CostCentre
   83 import GHC.Cmm.BlockId
   84 import GHC.Cmm.CLabel
   85 import GHC.Types.Id
   86 import GHC.Types.Id.Info
   87 import GHC.Core.DataCon
   88 import GHC.Types.Name
   89 import GHC.Core.Type
   90 import GHC.Core.TyCo.Rep
   91 import GHC.Tc.Utils.TcType
   92 import GHC.Core.TyCon
   93 import GHC.Types.RepType
   94 import GHC.Types.Basic
   95 import GHC.Utils.Outputable
   96 import GHC.Utils.Panic
   97 import GHC.Utils.Panic.Plain
   98 import GHC.Utils.Misc
   99 
  100 import Data.Coerce (coerce)
  101 import qualified Data.ByteString.Char8 as BS8
  102 
  103 -----------------------------------------------------------------------------
  104 --                Data types and synonyms
  105 -----------------------------------------------------------------------------
  106 
  107 -- These data types are mostly used by other modules, especially
  108 -- GHC.StgToCmm.Monad, but we define them here because some functions in this
  109 -- module need to have access to them as well
  110 
  111 data CgLoc
  112   = CmmLoc CmmExpr      -- A stable CmmExpr; that is, one not mentioning
  113                         -- Hp, so that it remains valid across calls
  114 
  115   | LneLoc BlockId [LocalReg]             -- A join point
  116         -- A join point (= let-no-escape) should only
  117         -- be tail-called, and in a saturated way.
  118         -- To tail-call it, assign to these locals,
  119         -- and branch to the block id
  120 
  121 instance OutputableP Platform CgLoc where
  122    pdoc = pprCgLoc
  123 
  124 pprCgLoc :: Platform -> CgLoc -> SDoc
  125 pprCgLoc platform = \case
  126    CmmLoc e    -> text "cmm" <+> pdoc platform e
  127    LneLoc b rs -> text "lne" <+> ppr b <+> ppr rs
  128 
  129 type SelfLoopInfo = (Id, BlockId, [LocalReg])
  130 
  131 -- used by ticky profiling
  132 isKnownFun :: LambdaFormInfo -> Bool
  133 isKnownFun LFReEntrant{} = True
  134 isKnownFun LFLetNoEscape = True
  135 isKnownFun _             = False
  136 
  137 
  138 -------------------------------------
  139 --        Non-void types
  140 -------------------------------------
  141 -- We frequently need the invariant that an Id or a an argument
  142 -- is of a non-void type. This type is a witness to the invariant.
  143 
  144 newtype NonVoid a = NonVoid a
  145   deriving (Eq, Show)
  146 
  147 fromNonVoid :: NonVoid a -> a
  148 fromNonVoid (NonVoid a) = a
  149 
  150 instance (Outputable a) => Outputable (NonVoid a) where
  151   ppr (NonVoid a) = ppr a
  152 
  153 nonVoidIds :: [Id] -> [NonVoid Id]
  154 nonVoidIds ids = [NonVoid id | id <- ids, not (isVoidTy (idType id))]
  155 
  156 -- | Used in places where some invariant ensures that all these Ids are
  157 -- non-void; e.g. constructor field binders in case expressions.
  158 -- See Note [Post-unarisation invariants] in "GHC.Stg.Unarise".
  159 assertNonVoidIds :: [Id] -> [NonVoid Id]
  160 assertNonVoidIds ids = assert (not (any (isVoidTy . idType) ids)) $
  161                        coerce ids
  162 
  163 nonVoidStgArgs :: [StgArg] -> [NonVoid StgArg]
  164 nonVoidStgArgs args = [NonVoid arg | arg <- args, not (isVoidTy (stgArgType arg))]
  165 
  166 -- | Used in places where some invariant ensures that all these arguments are
  167 -- non-void; e.g. constructor arguments.
  168 -- See Note [Post-unarisation invariants] in "GHC.Stg.Unarise".
  169 assertNonVoidStgArgs :: [StgArg] -> [NonVoid StgArg]
  170 assertNonVoidStgArgs args = assert (not (any (isVoidTy . stgArgType) args)) $
  171                             coerce args
  172 
  173 
  174 -----------------------------------------------------------------------------
  175 --                Representations
  176 -----------------------------------------------------------------------------
  177 
  178 -- Why are these here?
  179 
  180 -- | Assumes that there is precisely one 'PrimRep' of the type. This assumption
  181 -- holds after unarise.
  182 -- See Note [Post-unarisation invariants]
  183 idPrimRep :: Id -> PrimRep
  184 idPrimRep id = typePrimRep1 (idType id)
  185     -- See also Note [VoidRep] in GHC.Types.RepType
  186 
  187 -- | Assumes that Ids have one PrimRep, which holds after unarisation.
  188 -- See Note [Post-unarisation invariants]
  189 addIdReps :: [NonVoid Id] -> [NonVoid (PrimRep, Id)]
  190 addIdReps = map (\id -> let id' = fromNonVoid id
  191                          in NonVoid (idPrimRep id', id'))
  192 
  193 -- | Assumes that arguments have one PrimRep, which holds after unarisation.
  194 -- See Note [Post-unarisation invariants]
  195 addArgReps :: [NonVoid StgArg] -> [NonVoid (PrimRep, StgArg)]
  196 addArgReps = map (\arg -> let arg' = fromNonVoid arg
  197                            in NonVoid (argPrimRep arg', arg'))
  198 
  199 -- | Assumes that the argument has one PrimRep, which holds after unarisation.
  200 -- See Note [Post-unarisation invariants]
  201 argPrimRep :: StgArg -> PrimRep
  202 argPrimRep arg = typePrimRep1 (stgArgType arg)
  203 
  204 ------------------------------------------------------
  205 --                Building LambdaFormInfo
  206 ------------------------------------------------------
  207 
  208 mkLFArgument :: Id -> LambdaFormInfo
  209 mkLFArgument id
  210   | isUnliftedType ty      = LFUnlifted
  211   | might_be_a_function ty = LFUnknown True
  212   | otherwise              = LFUnknown False
  213   where
  214     ty = idType id
  215 
  216 -------------
  217 mkLFLetNoEscape :: LambdaFormInfo
  218 mkLFLetNoEscape = LFLetNoEscape
  219 
  220 -------------
  221 mkLFReEntrant :: TopLevelFlag    -- True of top level
  222               -> [Id]            -- Free vars
  223               -> [Id]            -- Args
  224               -> ArgDescr        -- Argument descriptor
  225               -> LambdaFormInfo
  226 
  227 mkLFReEntrant _ _ [] _
  228   = pprPanic "mkLFReEntrant" empty
  229 mkLFReEntrant top fvs args arg_descr
  230   = LFReEntrant top (length args) (null fvs) arg_descr
  231 
  232 -------------
  233 mkLFThunk :: Type -> TopLevelFlag -> [Id] -> UpdateFlag -> LambdaFormInfo
  234 mkLFThunk thunk_ty top fvs upd_flag
  235   = assert (not (isUpdatable upd_flag) || not (isUnliftedType thunk_ty)) $
  236     LFThunk top (null fvs)
  237             (isUpdatable upd_flag)
  238             NonStandardThunk
  239             (might_be_a_function thunk_ty)
  240 
  241 --------------
  242 might_be_a_function :: Type -> Bool
  243 -- Return False only if we are *sure* it's a data type
  244 -- Look through newtypes etc as much as poss
  245 might_be_a_function ty
  246   | [LiftedRep] <- typePrimRep ty
  247   , Just tc <- tyConAppTyCon_maybe (unwrapType ty)
  248   , isDataTyCon tc
  249   = False
  250   | otherwise
  251   = True
  252 
  253 -------------
  254 mkConLFInfo :: DataCon -> LambdaFormInfo
  255 mkConLFInfo con = LFCon con
  256 
  257 -------------
  258 mkSelectorLFInfo :: Id -> Int -> Bool -> LambdaFormInfo
  259 mkSelectorLFInfo id offset updatable
  260   = LFThunk NotTopLevel False updatable (SelectorThunk offset)
  261         (might_be_a_function (idType id))
  262 
  263 -------------
  264 mkApLFInfo :: Id -> UpdateFlag -> Arity -> LambdaFormInfo
  265 mkApLFInfo id upd_flag arity
  266   = LFThunk NotTopLevel (arity == 0) (isUpdatable upd_flag) (ApThunk arity)
  267         (might_be_a_function (idType id))
  268 
  269 -------------
  270 mkLFImported :: Id -> LambdaFormInfo
  271 mkLFImported id =
  272     -- See Note [Conveying CAF-info and LFInfo between modules] in
  273     -- GHC.StgToCmm.Types
  274     case idLFInfo_maybe id of
  275       Just lf_info ->
  276         -- Use the LambdaFormInfo from the interface
  277         lf_info
  278       Nothing
  279         -- Interface doesn't have a LambdaFormInfo, make a conservative one from
  280         -- the type.
  281         | Just con <- isDataConWorkId_maybe id
  282         , isNullaryRepDataCon con
  283         -> LFCon con   -- An imported nullary constructor
  284                        -- We assume that the constructor is evaluated so that
  285                        -- the id really does point directly to the constructor
  286 
  287         | arity > 0
  288         -> LFReEntrant TopLevel arity True ArgUnknown
  289 
  290         | otherwise
  291         -> mkLFArgument id -- Not sure of exact arity
  292   where
  293     arity = idFunRepArity id
  294 
  295 -------------
  296 mkLFStringLit :: LambdaFormInfo
  297 mkLFStringLit = LFUnlifted
  298 
  299 -----------------------------------------------------
  300 --                Dynamic pointer tagging
  301 -----------------------------------------------------
  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 --
  309 -- The family size of a data type (the number of constructors
  310 -- or the arity of a function) can be either:
  311 --    * small, if the family size < 2**tag_bits
  312 --    * big, otherwise.
  313 --
  314 -- Small families can have the constructor tag in the tag bits.
  315 -- Big families always use the tag values 1..mAX_PTR_TAG to represent
  316 -- evaluatedness, the last one lumping together all overflowing ones.
  317 -- We don't have very many tag bits: for example, we have 2 bits on
  318 -- x86-32 and 3 bits on x86-64.
  319 --
  320 -- Also see Note [Tagging big families] in GHC.StgToCmm.Expr
  321 --
  322 -- The interpreter also needs to be updated if we change the
  323 -- tagging strategy. See Note [Data constructor dynamic tags] in
  324 -- rts/Interpreter.c
  325 
  326 isSmallFamily :: Platform -> Int -> Bool
  327 isSmallFamily platform fam_size = fam_size <= mAX_PTR_TAG platform
  328 
  329 tagForCon :: Platform -> DataCon -> DynTag
  330 tagForCon platform con = min (dataConTag con) (mAX_PTR_TAG platform)
  331 -- NB: 1-indexed
  332 
  333 tagForArity :: Platform -> RepArity -> DynTag
  334 tagForArity platform arity
  335  | isSmallFamily platform arity = arity
  336  | otherwise                    = 0
  337 
  338 -- | Return the tag in the low order bits of a variable bound
  339 -- to this LambdaForm
  340 lfDynTag :: Platform -> LambdaFormInfo -> DynTag
  341 lfDynTag platform lf = case lf of
  342    LFCon con               -> tagForCon   platform con
  343    LFReEntrant _ arity _ _ -> tagForArity platform arity
  344    _other                  -> 0
  345 
  346 
  347 -----------------------------------------------------------------------------
  348 --                Observing LambdaFormInfo
  349 -----------------------------------------------------------------------------
  350 
  351 ------------
  352 isLFThunk :: LambdaFormInfo -> Bool
  353 isLFThunk (LFThunk {})  = True
  354 isLFThunk _ = False
  355 
  356 isLFReEntrant :: LambdaFormInfo -> Bool
  357 isLFReEntrant (LFReEntrant {}) = True
  358 isLFReEntrant _                = False
  359 
  360 -----------------------------------------------------------------------------
  361 --                Choosing SM reps
  362 -----------------------------------------------------------------------------
  363 
  364 lfClosureType :: LambdaFormInfo -> ClosureTypeInfo
  365 lfClosureType (LFReEntrant _ arity _ argd) = Fun arity argd
  366 lfClosureType (LFCon con)                  = Constr (dataConTagZ con)
  367                                                     (dataConIdentity con)
  368 lfClosureType (LFThunk _ _ _ is_sel _)     = thunkClosureType is_sel
  369 lfClosureType _                            = panic "lfClosureType"
  370 
  371 thunkClosureType :: StandardFormInfo -> ClosureTypeInfo
  372 thunkClosureType (SelectorThunk off) = ThunkSelector off
  373 thunkClosureType _                   = Thunk
  374 
  375 -- We *do* get non-updatable top-level thunks sometimes.  eg. f = g
  376 -- gets compiled to a jump to g (if g has non-zero arity), instead of
  377 -- messing around with update frames and PAPs.  We set the closure type
  378 -- to FUN_STATIC in this case.
  379 
  380 -----------------------------------------------------------------------------
  381 --                nodeMustPointToIt
  382 -----------------------------------------------------------------------------
  383 
  384 nodeMustPointToIt :: Profile -> LambdaFormInfo -> Bool
  385 -- If nodeMustPointToIt is true, then the entry convention for
  386 -- this closure has R1 (the "Node" register) pointing to the
  387 -- closure itself --- the "self" argument
  388 
  389 nodeMustPointToIt _ (LFReEntrant top _ no_fvs _)
  390   =  not no_fvs          -- Certainly if it has fvs we need to point to it
  391   || isNotTopLevel top   -- See Note [GC recovery]
  392         -- For lex_profiling we also access the cost centre for a
  393         -- non-inherited (i.e. non-top-level) function.
  394         -- The isNotTopLevel test above ensures this is ok.
  395 
  396 nodeMustPointToIt profile (LFThunk top no_fvs updatable NonStandardThunk _)
  397   =  not no_fvs            -- Self parameter
  398   || isNotTopLevel top     -- Note [GC recovery]
  399   || updatable             -- Need to push update frame
  400   || profileIsProfiling profile
  401           -- For the non-updatable (single-entry case):
  402           --
  403           -- True if has fvs (in which case we need access to them, and we
  404           --                    should black-hole it)
  405           -- or profiling (in which case we need to recover the cost centre
  406           --                 from inside it)  ToDo: do we need this even for
  407           --                                    top-level thunks? If not,
  408           --                                    isNotTopLevel subsumes this
  409 
  410 nodeMustPointToIt _ (LFThunk {})        -- Node must point to a standard-form thunk
  411   = True
  412 
  413 nodeMustPointToIt _ (LFCon _) = True
  414 
  415         -- Strictly speaking, the above two don't need Node to point
  416         -- to it if the arity = 0.  But this is a *really* unlikely
  417         -- situation.  If we know it's nil (say) and we are entering
  418         -- it. Eg: let x = [] in x then we will certainly have inlined
  419         -- x, since nil is a simple atom.  So we gain little by not
  420         -- having Node point to known zero-arity things.  On the other
  421         -- hand, we do lose something; Patrick's code for figuring out
  422         -- when something has been updated but not entered relies on
  423         -- having Node point to the result of an update.  SLPJ
  424         -- 27/11/92.
  425 
  426 nodeMustPointToIt _ (LFUnknown _)   = True
  427 nodeMustPointToIt _ LFUnlifted      = False
  428 nodeMustPointToIt _ LFLetNoEscape   = False
  429 
  430 {- Note [GC recovery]
  431 ~~~~~~~~~~~~~~~~~~~~~
  432 If we a have a local let-binding (function or thunk)
  433    let f = <body> in ...
  434 AND <body> allocates, then the heap-overflow check needs to know how
  435 to re-start the evaluation.  It uses the "self" pointer to do this.
  436 So even if there are no free variables in <body>, we still make
  437 nodeMustPointToIt be True for non-top-level bindings.
  438 
  439 Why do any such bindings exist?  After all, let-floating should have
  440 floated them out.  Well, a clever optimiser might leave one there to
  441 avoid a space leak, deliberately recomputing a thunk.  Also (and this
  442 really does happen occasionally) let-floating may make a function f smaller
  443 so it can be inlined, so now (f True) may generate a local no-fv closure.
  444 This actually happened during bootstrapping GHC itself, with f=mkRdrFunBind
  445 in GHC.Tc.Deriv.Generate.) -}
  446 
  447 -----------------------------------------------------------------------------
  448 --                getCallMethod
  449 -----------------------------------------------------------------------------
  450 
  451 {- The entry conventions depend on the type of closure being entered,
  452 whether or not it has free variables, and whether we're running
  453 sequentially or in parallel.
  454 
  455 Closure                           Node   Argument   Enter
  456 Characteristics              Par   Req'd  Passing    Via
  457 ---------------------------------------------------------------------------
  458 Unknown                     & no  & yes & stack     & node
  459 Known fun (>1 arg), no fvs  & no  & no  & registers & fast entry (enough args)
  460                                                     & slow entry (otherwise)
  461 Known fun (>1 arg), fvs     & no  & yes & registers & fast entry (enough args)
  462 0 arg, no fvs \r,\s         & no  & no  & n/a       & direct entry
  463 0 arg, no fvs \u            & no  & yes & n/a       & node
  464 0 arg, fvs \r,\s,selector   & no  & yes & n/a       & node
  465 0 arg, fvs \r,\s            & no  & yes & n/a       & direct entry
  466 0 arg, fvs \u               & no  & yes & n/a       & node
  467 Unknown                     & yes & yes & stack     & node
  468 Known fun (>1 arg), no fvs  & yes & no  & registers & fast entry (enough args)
  469                                                     & slow entry (otherwise)
  470 Known fun (>1 arg), fvs     & yes & yes & registers & node
  471 0 arg, fvs \r,\s,selector   & yes & yes & n/a       & node
  472 0 arg, no fvs \r,\s         & yes & no  & n/a       & direct entry
  473 0 arg, no fvs \u            & yes & yes & n/a       & node
  474 0 arg, fvs \r,\s            & yes & yes & n/a       & node
  475 0 arg, fvs \u               & yes & yes & n/a       & node
  476 
  477 When black-holing, single-entry closures could also be entered via node
  478 (rather than directly) to catch double-entry. -}
  479 
  480 data CallMethod
  481   = EnterIt             -- No args, not a function
  482 
  483   | JumpToIt BlockId [LocalReg] -- A join point or a header of a local loop
  484 
  485   | ReturnIt            -- It's a value (function, unboxed value,
  486                         -- or constructor), so just return it.
  487 
  488   | SlowCall                -- Unknown fun, or known fun with
  489                         -- too few args.
  490 
  491   | DirectEntry         -- Jump directly, with args in regs
  492         CLabel          --   The code label
  493         RepArity        --   Its arity
  494 
  495 data CallOpts = CallOpts
  496    { co_profile       :: !Profile   -- ^ Platform profile
  497    , co_loopification :: !Bool      -- ^ Loopification enabled (cf @-floopification@)
  498    , co_ticky         :: !Bool      -- ^ Ticky profiling enabled (cf @-ticky@)
  499    }
  500 
  501 getCallMethod :: CallOpts
  502               -> Name           -- Function being applied
  503               -> Id             -- Function Id used to chech if it can refer to
  504                                 -- CAF's and whether the function is tail-calling
  505                                 -- itself
  506               -> LambdaFormInfo -- Its info
  507               -> RepArity       -- Number of available arguments
  508               -> RepArity       -- Number of them being void arguments
  509               -> CgLoc          -- Passed in from cgIdApp so that we can
  510                                 -- handle let-no-escape bindings and self-recursive
  511                                 -- tail calls using the same data constructor,
  512                                 -- JumpToIt. This saves us one case branch in
  513                                 -- cgIdApp
  514               -> Maybe SelfLoopInfo -- can we perform a self-recursive tail call?
  515               -> CallMethod
  516 
  517 getCallMethod opts _ id _ n_args v_args _cg_loc
  518               (Just (self_loop_id, block_id, args))
  519   | co_loopification opts
  520   , id == self_loop_id
  521   , args `lengthIs` (n_args - v_args)
  522   -- If these patterns match then we know that:
  523   --   * loopification optimisation is turned on
  524   --   * function is performing a self-recursive call in a tail position
  525   --   * number of non-void parameters of the function matches functions arity.
  526   -- See Note [Self-recursive tail calls] and Note [Void arguments in
  527   -- self-recursive tail calls] in GHC.StgToCmm.Expr for more details
  528   = JumpToIt block_id args
  529 
  530 getCallMethod opts name id (LFReEntrant _ arity _ _) n_args _v_args _cg_loc
  531               _self_loop_info
  532   | n_args == 0 -- No args at all
  533   && not (profileIsProfiling (co_profile opts))
  534      -- See Note [Evaluating functions with profiling] in rts/Apply.cmm
  535   = assert (arity /= 0) ReturnIt
  536   | n_args < arity = SlowCall        -- Not enough args
  537   | otherwise      = DirectEntry (enterIdLabel (profilePlatform (co_profile opts)) name (idCafInfo id)) arity
  538 
  539 getCallMethod _ _name _ LFUnlifted n_args _v_args _cg_loc _self_loop_info
  540   = assert (n_args == 0) ReturnIt
  541 
  542 getCallMethod _ _name _ (LFCon _) n_args _v_args _cg_loc _self_loop_info
  543   = assert (n_args == 0) ReturnIt
  544     -- n_args=0 because it'd be ill-typed to apply a saturated
  545     --          constructor application to anything
  546 
  547 getCallMethod opts name id (LFThunk _ _ updatable std_form_info is_fun)
  548               n_args _v_args _cg_loc _self_loop_info
  549   | is_fun      -- it *might* be a function, so we must "call" it (which is always safe)
  550   = SlowCall    -- We cannot just enter it [in eval/apply, the entry code
  551                 -- is the fast-entry code]
  552 
  553   -- Since is_fun is False, we are *definitely* looking at a data value
  554   | updatable || co_ticky opts -- to catch double entry
  555       {- OLD: || opt_SMP
  556          I decided to remove this, because in SMP mode it doesn't matter
  557          if we enter the same thunk multiple times, so the optimisation
  558          of jumping directly to the entry code is still valid.  --SDM
  559         -}
  560   = EnterIt
  561 
  562   -- even a non-updatable selector thunk can be updated by the garbage
  563   -- collector, so we must enter it. (#8817)
  564   | SelectorThunk{} <- std_form_info
  565   = EnterIt
  566 
  567     -- We used to have assert (n_args == 0 ), but actually it is
  568     -- possible for the optimiser to generate
  569     --   let bot :: Int = error Int "urk"
  570     --   in (bot `cast` unsafeCoerce Int (Int -> Int)) 3
  571     -- This happens as a result of the case-of-error transformation
  572     -- So the right thing to do is just to enter the thing
  573 
  574   | otherwise        -- Jump direct to code for single-entry thunks
  575   = assert (n_args == 0) $
  576     DirectEntry (thunkEntryLabel (profilePlatform (co_profile opts)) name (idCafInfo id) std_form_info
  577                 updatable) 0
  578 
  579 getCallMethod _ _name _ (LFUnknown True) _n_arg _v_args _cg_locs _self_loop_info
  580   = SlowCall -- might be a function
  581 
  582 getCallMethod _ name _ (LFUnknown False) n_args _v_args _cg_loc _self_loop_info
  583   = assertPpr (n_args == 0) (ppr name <+> ppr n_args)
  584     EnterIt -- Not a function
  585 
  586 getCallMethod _ _name _ LFLetNoEscape _n_args _v_args (LneLoc blk_id lne_regs)
  587               _self_loop_info
  588   = JumpToIt blk_id lne_regs
  589 
  590 getCallMethod _ _ _ _ _ _ _ _ = panic "Unknown call method"
  591 
  592 -----------------------------------------------------------------------------
  593 --              Data types for closure information
  594 -----------------------------------------------------------------------------
  595 
  596 
  597 {- ClosureInfo: information about a binding
  598 
  599    We make a ClosureInfo for each let binding (both top level and not),
  600    but not bindings for data constructors: for those we build a CmmInfoTable
  601    directly (see mkDataConInfoTable).
  602 
  603    To a first approximation:
  604        ClosureInfo = (LambdaFormInfo, CmmInfoTable)
  605 
  606    A ClosureInfo has enough information
  607      a) to construct the info table itself, and build other things
  608         related to the binding (e.g. slow entry points for a function)
  609      b) to allocate a closure containing that info pointer (i.e.
  610            it knows the info table label)
  611 -}
  612 
  613 data ClosureInfo
  614   = ClosureInfo {
  615         closureName :: !Name,           -- The thing bound to this closure
  616            -- we don't really need this field: it's only used in generating
  617            -- code for ticky and profiling, and we could pass the information
  618            -- around separately, but it doesn't do much harm to keep it here.
  619 
  620         closureLFInfo :: !LambdaFormInfo, -- NOTE: not an LFCon
  621           -- this tells us about what the closure contains: it's right-hand-side.
  622 
  623           -- the rest is just an unpacked CmmInfoTable.
  624         closureInfoLabel :: !CLabel,
  625         closureSMRep     :: !SMRep,          -- representation used by storage mgr
  626         closureProf      :: !ProfilingInfo
  627     }
  628 
  629 -- | Convert from 'ClosureInfo' to 'CmmInfoTable'.
  630 mkCmmInfo :: ClosureInfo -> Id -> CostCentreStack -> CmmInfoTable
  631 mkCmmInfo ClosureInfo {..} id ccs
  632   = CmmInfoTable { cit_lbl  = closureInfoLabel
  633                  , cit_rep  = closureSMRep
  634                  , cit_prof = closureProf
  635                  , cit_srt  = Nothing
  636                  , cit_clo  = if isStaticRep closureSMRep
  637                                 then Just (id,ccs)
  638                                 else Nothing }
  639 
  640 --------------------------------------
  641 --        Building ClosureInfos
  642 --------------------------------------
  643 
  644 mkClosureInfo :: Profile
  645               -> Bool                -- Is static
  646               -> Id
  647               -> LambdaFormInfo
  648               -> Int -> Int        -- Total and pointer words
  649               -> String         -- String descriptor
  650               -> ClosureInfo
  651 mkClosureInfo profile is_static id lf_info tot_wds ptr_wds val_descr
  652   = ClosureInfo { closureName      = name
  653                 , closureLFInfo    = lf_info
  654                 , closureInfoLabel = info_lbl   -- These three fields are
  655                 , closureSMRep     = sm_rep     -- (almost) an info table
  656                 , closureProf      = prof }     -- (we don't have an SRT yet)
  657   where
  658     name       = idName id
  659     sm_rep     = mkHeapRep profile is_static ptr_wds nonptr_wds (lfClosureType lf_info)
  660     prof       = mkProfilingInfo profile id val_descr
  661     nonptr_wds = tot_wds - ptr_wds
  662 
  663     info_lbl = mkClosureInfoTableLabel (profilePlatform profile) id lf_info
  664 
  665 --------------------------------------
  666 --   Other functions over ClosureInfo
  667 --------------------------------------
  668 
  669 -- Eager blackholing is normally disabled, but can be turned on with
  670 -- -feager-blackholing.  When it is on, we replace the info pointer of
  671 -- the thunk with stg_EAGER_BLACKHOLE_info on entry.
  672 
  673 -- If we wanted to do eager blackholing with slop filling,
  674 -- we'd need to do it at the *end* of a basic block, otherwise
  675 -- we overwrite the free variables in the thunk that we still
  676 -- need.  We have a patch for this from Andy Cheadle, but not
  677 -- incorporated yet. --SDM [6/2004]
  678 --
  679 -- Previously, eager blackholing was enabled when ticky-ticky
  680 -- was on. But it didn't work, and it wasn't strictly necessary
  681 -- to bring back minimal ticky-ticky, so now EAGER_BLACKHOLING
  682 -- is unconditionally disabled. -- krc 1/2007
  683 --
  684 -- Static closures are never themselves black-holed.
  685 
  686 blackHoleOnEntry :: ClosureInfo -> Bool
  687 blackHoleOnEntry cl_info
  688   | isStaticRep (closureSMRep cl_info)
  689   = False        -- Never black-hole a static closure
  690 
  691   | otherwise
  692   = case closureLFInfo cl_info of
  693       LFReEntrant {}            -> False
  694       LFLetNoEscape             -> False
  695       LFThunk _ _no_fvs upd _ _ -> upd   -- See Note [Black-holing non-updatable thunks]
  696       _other -> panic "blackHoleOnEntry"
  697 
  698 {- Note [Black-holing non-updatable thunks]
  699 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  700 We must not black-hole non-updatable (single-entry) thunks otherwise
  701 we run into issues like #10414. Specifically:
  702 
  703   * There is no reason to black-hole a non-updatable thunk: it should
  704     not be competed for by multiple threads
  705 
  706   * It could, conceivably, cause a space leak if we don't black-hole
  707     it, if there was a live but never-followed pointer pointing to it.
  708     Let's hope that doesn't happen.
  709 
  710   * It is dangerous to black-hole a non-updatable thunk because
  711      - is not updated (of course)
  712      - hence, if it is black-holed and another thread tries to evaluate
  713        it, that thread will block forever
  714     This actually happened in #10414.  So we do not black-hole
  715     non-updatable thunks.
  716 
  717   * How could two threads evaluate the same non-updatable (single-entry)
  718     thunk?  See Reid Barton's example below.
  719 
  720   * Only eager blackholing could possibly black-hole a non-updatable
  721     thunk, because lazy black-holing only affects thunks with an
  722     update frame on the stack.
  723 
  724 Here is and example due to Reid Barton (#10414):
  725     x = \u []  concat [[1], []]
  726 with the following definitions,
  727 
  728     concat x = case x of
  729         []       -> []
  730         (:) x xs -> (++) x (concat xs)
  731 
  732     (++) xs ys = case xs of
  733         []         -> ys
  734         (:) x rest -> (:) x ((++) rest ys)
  735 
  736 Where we use the syntax @\u []@ to denote an updatable thunk and @\s []@ to
  737 denote a single-entry (i.e. non-updatable) thunk. After a thread evaluates @x@
  738 to WHNF and calls @(++)@ the heap will contain the following thunks,
  739 
  740     x = 1 : y
  741     y = \u []  (++) [] z
  742     z = \s []  concat []
  743 
  744 Now that the stage is set, consider the follow evaluations by two racing threads
  745 A and B,
  746 
  747   1. Both threads enter @y@ before either is able to replace it with an
  748      indirection
  749 
  750   2. Thread A does the case analysis in @(++)@ and consequently enters @z@,
  751      replacing it with a black-hole
  752 
  753   3. At some later point thread B does the same case analysis and also attempts
  754      to enter @z@. However, it finds that it has been replaced with a black-hole
  755      so it blocks.
  756 
  757   4. Thread A eventually finishes evaluating @z@ (to @[]@) and updates @y@
  758      accordingly. It does *not* update @z@, however, as it is single-entry. This
  759      leaves Thread B blocked forever on a black-hole which will never be
  760      updated.
  761 
  762 To avoid this sort of condition we never black-hole non-updatable thunks.
  763 -}
  764 
  765 isStaticClosure :: ClosureInfo -> Bool
  766 isStaticClosure cl_info = isStaticRep (closureSMRep cl_info)
  767 
  768 closureUpdReqd :: ClosureInfo -> Bool
  769 closureUpdReqd ClosureInfo{ closureLFInfo = lf_info } = lfUpdatable lf_info
  770 
  771 lfUpdatable :: LambdaFormInfo -> Bool
  772 lfUpdatable (LFThunk _ _ upd _ _)  = upd
  773 lfUpdatable _ = False
  774 
  775 closureReEntrant :: ClosureInfo -> Bool
  776 closureReEntrant (ClosureInfo { closureLFInfo = LFReEntrant {} }) = True
  777 closureReEntrant _ = False
  778 
  779 closureFunInfo :: ClosureInfo -> Maybe (RepArity, ArgDescr)
  780 closureFunInfo (ClosureInfo { closureLFInfo = lf_info }) = lfFunInfo lf_info
  781 
  782 lfFunInfo :: LambdaFormInfo ->  Maybe (RepArity, ArgDescr)
  783 lfFunInfo (LFReEntrant _ arity _ arg_desc)  = Just (arity, arg_desc)
  784 lfFunInfo _                                 = Nothing
  785 
  786 funTag :: Platform -> ClosureInfo -> DynTag
  787 funTag platform (ClosureInfo { closureLFInfo = lf_info })
  788     = lfDynTag platform lf_info
  789 
  790 isToplevClosure :: ClosureInfo -> Bool
  791 isToplevClosure (ClosureInfo { closureLFInfo = lf_info })
  792   = case lf_info of
  793       LFReEntrant TopLevel _ _ _ -> True
  794       LFThunk TopLevel _ _ _ _   -> True
  795       _other                     -> False
  796 
  797 --------------------------------------
  798 --   Label generation
  799 --------------------------------------
  800 
  801 staticClosureLabel :: Platform -> ClosureInfo -> CLabel
  802 staticClosureLabel platform = toClosureLbl platform .  closureInfoLabel
  803 
  804 closureSlowEntryLabel :: Platform -> ClosureInfo -> CLabel
  805 closureSlowEntryLabel platform = toSlowEntryLbl platform . closureInfoLabel
  806 
  807 closureLocalEntryLabel :: Platform -> ClosureInfo -> CLabel
  808 closureLocalEntryLabel platform
  809   | platformTablesNextToCode platform = toInfoLbl  platform . closureInfoLabel
  810   | otherwise                         = toEntryLbl platform . closureInfoLabel
  811 
  812 mkClosureInfoTableLabel :: Platform -> Id -> LambdaFormInfo -> CLabel
  813 mkClosureInfoTableLabel platform id lf_info
  814   = case lf_info of
  815         LFThunk _ _ upd_flag (SelectorThunk offset) _
  816                       -> mkSelectorInfoLabel platform upd_flag offset
  817 
  818         LFThunk _ _ upd_flag (ApThunk arity) _
  819                       -> mkApInfoTableLabel platform upd_flag arity
  820 
  821         LFThunk{}     -> std_mk_lbl name cafs
  822         LFReEntrant{} -> std_mk_lbl name cafs
  823         _other        -> panic "closureInfoTableLabel"
  824 
  825   where
  826     name = idName id
  827 
  828     std_mk_lbl | is_local  = mkLocalInfoTableLabel
  829                | otherwise = mkInfoTableLabel
  830 
  831     cafs     = idCafInfo id
  832     is_local = isDataConWorkId id
  833        -- Make the _info pointer for the implicit datacon worker
  834        -- binding local. The reason we can do this is that importing
  835        -- code always either uses the _closure or _con_info. By the
  836        -- invariants in "GHC.CoreToStg.Prep" anything else gets eta expanded.
  837 
  838 
  839 -- | thunkEntryLabel is a local help function, not exported.  It's used from
  840 -- getCallMethod.
  841 thunkEntryLabel :: Platform -> Name -> CafInfo -> StandardFormInfo -> Bool -> CLabel
  842 thunkEntryLabel platform thunk_id caf_info sfi upd_flag = case sfi of
  843    ApThunk arity        -> enterApLabel       platform upd_flag arity
  844    SelectorThunk offset -> enterSelectorLabel platform upd_flag offset
  845    _                    -> enterIdLabel       platform thunk_id caf_info
  846 
  847 enterApLabel :: Platform -> Bool -> Arity -> CLabel
  848 enterApLabel platform is_updatable arity
  849   | platformTablesNextToCode platform = mkApInfoTableLabel platform is_updatable arity
  850   | otherwise                         = mkApEntryLabel     platform is_updatable arity
  851 
  852 enterSelectorLabel :: Platform -> Bool -> WordOff -> CLabel
  853 enterSelectorLabel platform upd_flag offset
  854   | platformTablesNextToCode platform = mkSelectorInfoLabel  platform upd_flag offset
  855   | otherwise                         = mkSelectorEntryLabel platform upd_flag offset
  856 
  857 enterIdLabel :: Platform -> Name -> CafInfo -> CLabel
  858 enterIdLabel platform id c
  859   | platformTablesNextToCode platform = mkInfoTableLabel id c
  860   | otherwise                         = mkEntryLabel id c
  861 
  862 
  863 --------------------------------------
  864 --   Profiling
  865 --------------------------------------
  866 
  867 -- Profiling requires two pieces of information to be determined for
  868 -- each closure's info table --- description and type.
  869 
  870 -- The description is stored directly in the @CClosureInfoTable@ when the
  871 -- info table is built.
  872 
  873 -- The type is determined from the type information stored with the @Id@
  874 -- in the closure info using @closureTypeDescr@.
  875 
  876 mkProfilingInfo :: Profile -> Id -> String -> ProfilingInfo
  877 mkProfilingInfo profile id val_descr
  878   | not (profileIsProfiling profile) = NoProfilingInfo
  879   | otherwise                        = ProfilingInfo ty_descr_w8 (BS8.pack val_descr)
  880   where
  881     ty_descr_w8  = BS8.pack (getTyDescription (idType id))
  882 
  883 getTyDescription :: Type -> String
  884 getTyDescription ty
  885   = case (tcSplitSigmaTy ty) of { (_, _, tau_ty) ->
  886     case tau_ty of
  887       TyVarTy _              -> "*"
  888       AppTy fun _            -> getTyDescription fun
  889       TyConApp tycon _       -> getOccString tycon
  890       FunTy {}              -> '-' : fun_result tau_ty
  891       ForAllTy _  ty         -> getTyDescription ty
  892       LitTy n                -> getTyLitDescription n
  893       CastTy ty _            -> getTyDescription ty
  894       CoercionTy co          -> pprPanic "getTyDescription" (ppr co)
  895     }
  896   where
  897     fun_result (FunTy { ft_res = res }) = '>' : fun_result res
  898     fun_result other                    = getTyDescription other
  899 
  900 getTyLitDescription :: TyLit -> String
  901 getTyLitDescription l =
  902   case l of
  903     NumTyLit n -> show n
  904     StrTyLit n -> show n
  905     CharTyLit n -> show n
  906 
  907 --------------------------------------
  908 --   CmmInfoTable-related things
  909 --------------------------------------
  910 
  911 mkDataConInfoTable :: Profile -> DataCon -> ConInfoTableLocation -> Bool -> Int -> Int -> CmmInfoTable
  912 mkDataConInfoTable profile data_con mn is_static ptr_wds nonptr_wds
  913  = CmmInfoTable { cit_lbl  = info_lbl
  914                 , cit_rep  = sm_rep
  915                 , cit_prof = prof
  916                 , cit_srt  = Nothing
  917                 , cit_clo  = Nothing }
  918  where
  919    name = dataConName data_con
  920    info_lbl = mkConInfoTableLabel name mn -- NoCAFRefs
  921    sm_rep = mkHeapRep profile is_static ptr_wds nonptr_wds cl_type
  922    cl_type = Constr (dataConTagZ data_con) (dataConIdentity data_con)
  923                   -- We keep the *zero-indexed* tag in the srt_len field
  924                   -- of the info table of a data constructor.
  925 
  926    prof | not (profileIsProfiling profile) = NoProfilingInfo
  927         | otherwise                        = ProfilingInfo ty_descr val_descr
  928 
  929    ty_descr  = BS8.pack $ occNameString $ getOccName $ dataConTyCon data_con
  930    val_descr = BS8.pack $ occNameString $ getOccName data_con
  931 
  932 -- We need a black-hole closure info to pass to @allocDynClosure@ when we
  933 -- want to allocate the black hole on entry to a CAF.
  934 
  935 cafBlackHoleInfoTable :: CmmInfoTable
  936 cafBlackHoleInfoTable
  937   = CmmInfoTable { cit_lbl  = mkCAFBlackHoleInfoTableLabel
  938                  , cit_rep  = blackHoleRep
  939                  , cit_prof = NoProfilingInfo
  940                  , cit_srt  = Nothing
  941                  , cit_clo  = Nothing }
  942 
  943 indStaticInfoTable :: CmmInfoTable
  944 indStaticInfoTable
  945   = CmmInfoTable { cit_lbl  = mkIndStaticInfoLabel
  946                  , cit_rep  = indStaticRep
  947                  , cit_prof = NoProfilingInfo
  948                  , cit_srt  = Nothing
  949                  , cit_clo  = Nothing }
  950 
  951 staticClosureNeedsLink :: Bool -> CmmInfoTable -> Bool
  952 -- A static closure needs a link field to aid the GC when traversing
  953 -- the static closure graph.  But it only needs such a field if either
  954 --        a) it has an SRT
  955 --        b) it's a constructor with one or more pointer fields
  956 -- In case (b), the constructor's fields themselves play the role
  957 -- of the SRT.
  958 staticClosureNeedsLink has_srt CmmInfoTable{ cit_rep = smrep }
  959   | isConRep smrep         = not (isStaticNoCafCon smrep)
  960   | otherwise              = has_srt