-closureCodeBody binder_info closure_info cc all_args body
- = getEntryConvention id lf_info
- (map idPrimRep all_args) `thenFC` \ entry_conv ->
- let
- is_concurrent = opt_ForConcurrent
-
- stg_arity = length all_args
-
- -- Arg mapping for standard (slow) entry point; all args on stack
- (spA_all_args, spB_all_args, all_bxd_w_offsets, all_ubxd_w_offsets)
- = mkVirtStkOffsets
- 0 0 -- Initial virtual SpA, SpB
- idPrimRep
- all_args
-
- -- Arg mapping for the fast entry point; as many args as poss in
- -- registers; the rest on the stack
- -- arg_regs are the registers used for arg passing
- -- stk_args are the args which are passed on the stack
- --
- arg_regs = case entry_conv of
- DirectEntry lbl arity regs -> regs
- ViaNode | is_concurrent -> []
- other -> panic "closureCodeBody:arg_regs"
-
- num_arg_regs = length arg_regs
-
- (reg_args, stk_args) = splitAt num_arg_regs all_args
-
- (spA_stk_args, spB_stk_args, stk_bxd_w_offsets, stk_ubxd_w_offsets)
- = mkVirtStkOffsets
- 0 0 -- Initial virtual SpA, SpB
- idPrimRep
- stk_args
-
- -- HWL; Note: empty list of live regs in slow entry code
- -- Old version (reschedule combined with heap check);
- -- see argSatisfactionCheck for new version
- --slow_entry_code = forceHeapCheck [node] True slow_entry_code'
- -- where node = VanillaReg PtrRep 1
- --slow_entry_code = forceHeapCheck [] True slow_entry_code'
-
- slow_entry_code
- = profCtrC SLIT("ENT_FUN_STD") [] `thenC`
-
- -- Bind args, and record expected position of stk ptrs
- mapCs bindNewToAStack all_bxd_w_offsets `thenC`
- mapCs bindNewToBStack all_ubxd_w_offsets `thenC`
- setRealAndVirtualSps spA_all_args spB_all_args `thenC`
-
- argSatisfactionCheck closure_info all_args `thenC`
-
- -- OK, so there are enough args. Now we need to stuff as
- -- many of them in registers as the fast-entry code
- -- expects Note that the zipWith will give up when it hits
- -- the end of arg_regs.
-
- mapFCs getCAddrMode all_args `thenFC` \ stk_amodes ->
- absC (mkAbstractCs (zipWith assign_to_reg arg_regs stk_amodes)) `thenC`
-
- -- Now adjust real stack pointers
- adjustRealSps spA_stk_args spB_stk_args `thenC`
-
- absC (CFallThrough (CLbl fast_label CodePtrRep))
-
- assign_to_reg reg_id amode = CAssign (CReg reg_id) amode
-
- -- HWL
- -- Old version (reschedule combined with heap check);
- -- see argSatisfactionCheck for new version
- -- fast_entry_code = forceHeapCheck [] True fast_entry_code'
-
- fast_entry_code
- = profCtrC SLIT("ENT_FUN_DIRECT") [
- CLbl (mkRednCountsLabel id) PtrRep,
- CString (_PK_ (showId PprDebug id)),
- mkIntCLit stg_arity, -- total # of args
- mkIntCLit spA_stk_args, -- # passed on A stk
- mkIntCLit spB_stk_args, -- B stk (rest in regs)
- CString (_PK_ (map (showTypeCategory . idType) all_args)),
- CString (_PK_ (show_wrapper_name wrapper_maybe)),
- CString (_PK_ (show_wrapper_arg_kinds wrapper_maybe))
- ] `thenC`
-
- -- Bind args to regs/stack as appropriate, and
- -- record expected position of sps
- bindArgsToRegs reg_args arg_regs `thenC`
- mapCs bindNewToAStack stk_bxd_w_offsets `thenC`
- mapCs bindNewToBStack stk_ubxd_w_offsets `thenC`
- setRealAndVirtualSps spA_stk_args spB_stk_args `thenC`
-
- -- Enter the closures cc, if required
- enterCostCentreCode closure_info cc IsFunction `thenC`
-
- -- Do the business
- funWrapper closure_info arg_regs (cgExpr body)
- in
- -- Make a labelled code-block for the slow and fast entry code
- forkAbsC (if slow_code_needed then slow_entry_code else absC AbsCNop)
- `thenFC` \ slow_abs_c ->
- forkAbsC fast_entry_code `thenFC` \ fast_abs_c ->
- moduleName `thenFC` \ mod_name ->
-
- -- Now either construct the info table, or put the fast code in alone
- -- (We never have slow code without an info table)
- absC (
- if info_table_needed then
- CClosureInfoAndCode closure_info slow_abs_c (Just fast_abs_c)
- stdUpd (cl_descr mod_name)
- (dataConLiveness closure_info)
- else
- CCodeBlock fast_label fast_abs_c
- )
- where
- lf_info = closureLFInfo closure_info
-
- cl_descr mod_name = closureDescription mod_name id all_args body
-
- -- Figure out what is needed and what isn't
- slow_code_needed = slowFunEntryCodeRequired id binder_info
- info_table_needed = funInfoTableRequired id binder_info lf_info
-
- -- Manufacture labels
- id = closureId closure_info
-
- fast_label = fastLabelFromCI closure_info
-
- stdUpd = CLbl mkErrorStdEntryLabel CodePtrRep
-
- wrapper_maybe = get_ultimate_wrapper Nothing id
- where
- get_ultimate_wrapper deflt x -- walk all the way up a "wrapper chain"
- = case (myWrapperMaybe x) of
- Nothing -> deflt
- Just xx -> get_ultimate_wrapper (Just xx) xx
-
- show_wrapper_name Nothing = ""
- show_wrapper_name (Just xx) = showId PprDebug xx
-
- show_wrapper_arg_kinds Nothing = ""
- show_wrapper_arg_kinds (Just xx)
- = case (getWrapperArgTypeCategories (idType xx) (getIdStrictness xx)) of
- Nothing -> ""
- Just str -> str
+closureCodeBody binder_info cl_info cc args body = do
+ { -- Get the current virtual Sp (it might not be zero,
+ -- eg. if we're compiling a let-no-escape).
+ vSp <- getVirtSp
+ ; let (reg_args, other_args) = assignCallRegs (addIdReps args)
+ (sp_top, stk_args) = mkVirtStkOffsets vSp other_args
+
+ -- Allocate the global ticky counter
+ ; let ticky_ctr_lbl = mkRednCountsLabel (closureName cl_info)
+ ; emitTickyCounter cl_info args sp_top
+
+ -- ...and establish the ticky-counter
+ -- label for this block
+ ; setTickyCtrLabel ticky_ctr_lbl $ do
+
+ -- Emit the slow-entry code
+ { reg_save_code <- mkSlowEntryCode cl_info reg_args
+
+ -- Emit the main entry code
+ ; blks <- forkProc $
+ mkFunEntryCode cl_info cc reg_args stk_args
+ sp_top reg_save_code body
+ ; emitClosureCodeAndInfoTable cl_info [] blks
+ }}
+
+
+
+mkFunEntryCode :: ClosureInfo
+ -> CostCentreStack
+ -> [(Id,GlobalReg)] -- Args in regs
+ -> [(Id,VirtualSpOffset)] -- Args on stack
+ -> VirtualSpOffset -- Last allocated word on stack
+ -> CmmStmts -- Register-save code in case of GC
+ -> StgExpr
+ -> Code
+-- The main entry code for the closure
+mkFunEntryCode cl_info cc reg_args stk_args sp_top reg_save_code body = do
+ { -- Bind args to regs/stack as appropriate,
+ -- and record expected position of sps
+ ; bindArgsToRegs reg_args
+ ; bindArgsToStack stk_args
+ ; setRealAndVirtualSp sp_top
+
+ -- Enter the cost-centre, if required
+ -- ToDo: It's not clear why this is outside the funWrapper,
+ -- but the tickyEnterFun is inside. Perhaps we can put
+ -- them together?
+ ; enterCostCentre cl_info cc body
+
+ -- Do the business
+ ; funWrapper cl_info reg_args reg_save_code $ do
+ { tickyEnterFun cl_info
+ ; cgExpr body }
+ }