-@cgVapInfoTables@ generates both Vap info tables, if they are required
-at all. It calls @cgVapInfoTable@ to generate each Vap info table,
-along with its entry code.
-
-\begin{code}
--- Don't generate Vap info tables for thunks; only for functions
-cgVapInfoTables top_level perhaps_bind_the_fun binder_info fun [{- no args; a thunk! -}] lf_info
- = nopC
-
-cgVapInfoTables top_level perhaps_bind_the_fun binder_info fun args lf_info
- = -- BUILD THE STANDARD VAP-ENTRY STUFF IF NECESSARY
- (if stdVapRequired binder_info then
- cgVapInfoTable perhaps_bind_the_fun Updatable fun args fun_in_payload lf_info
- else
- nopC
- ) `thenC`
-
- -- BUILD THE NO-UPDATE VAP-ENTRY STUFF IF NECESSARY
- (if noUpdVapRequired binder_info then
- cgVapInfoTable perhaps_bind_the_fun SingleEntry fun args fun_in_payload lf_info
- else
- nopC
- )
-
- where
- fun_in_payload = not top_level
-
-cgVapInfoTable perhaps_bind_the_fun upd_flag fun args fun_in_payload fun_lf_info
- = let
- -- The vap_entry_rhs is a manufactured STG expression which
- -- looks like the RHS of any binding which is going to use the vap-entry
- -- point of the function. Each of these bindings will look like:
- --
- -- x = [a,b,c] \upd [] -> f a b c
- --
- -- If f is not top-level, then f is one of the free variables too,
- -- hence "payload_ids" isn't the same as "arg_ids".
- --
- vap_entry_rhs = StgApp (StgVarArg fun) (map StgVarArg args) emptyUniqSet
- -- Empty live vars
-
- arg_ids_w_info = [(name,mkLFArgument) | name <- args]
- payload_ids_w_info | fun_in_payload = (fun,fun_lf_info) : arg_ids_w_info
- | otherwise = arg_ids_w_info
-
- payload_ids | fun_in_payload = fun : args -- Sigh; needed for mkClosureLFInfo
- | otherwise = args
-
- vap_lf_info = mkClosureLFInfo False {-not top level-} payload_ids
- upd_flag [] vap_entry_rhs
- -- It's not top level, even if we're currently compiling a top-level
- -- function, because any VAP *use* of this function will be for a
- -- local thunk, thus
- -- let x = f p q -- x isn't top level!
- -- in ...
-
- get_kind (id, info) = getIdPrimRep id
-
- payload_bind_details :: [((Id, LambdaFormInfo), VirtualHeapOffset)]
- (closure_info, payload_bind_details) = layOutDynClosure
- fun
- get_kind payload_ids_w_info
- vap_lf_info
- -- The dodgy thing is that we use the "fun" as the
- -- Id to give to layOutDynClosure. This Id gets embedded in
- -- the closure_info it returns. But of course, the function doesn't
- -- have the right type to match the Vap closure. Never mind,
- -- a hack in closureType spots the special case. Otherwise that
- -- Id is just used for label construction, which is OK.
-
- bind_fv ((id,lf_info), offset) = bindNewToNode id offset lf_info
- in
-
- -- BUILD ITS INFO TABLE AND CODE
- forkClosureBody (
-
- -- Bind the fvs; if the fun is not in the payload, then bind_the_fun tells
- -- how to bind it. If it is in payload it'll be bound by payload_bind_details.
- perhaps_bind_the_fun `thenC`
- mapCs bind_fv payload_bind_details `thenC`
-
- -- Generate the info table and code
- closureCodeBody NoStgBinderInfo
- closure_info
- useCurrentCostCentre
- [] -- No args; it's a thunk
- vap_entry_rhs
- )
-\end{code}