-closureCodeBody binder_info closure_info cc all_args body
- = getEntryConvention name lf_info
- (map idPrimRep all_args) `thenFC` \ entry_conv ->
-
- -- get the current virtual Sp (it might not be zero, eg. if we're
- -- compiling a let-no-escape).
- getVirtSp `thenFC` \vSp ->
-
- let
- -- Figure out what is needed and what isn't
-
- -- SDM: need everything for now in case the heap/stack check refers
- -- to it. (ToDo)
- slow_code_needed = True
- --slowFunEntryCodeRequired name binder_info entry_conv
- info_table_needed = True
- --funInfoTableRequired name binder_info lf_info
-
- -- Arg mapping for standard (slow) entry point; all args on stack,
- -- with tagging.
- (sp_all_args, arg_offsets, _)
- = mkTaggedVirtStkOffsets vSp 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
- --
- -- Args passed on the stack are tagged, but the tags may not
- -- actually be present (just gaps) if the function is called
- -- by jumping directly to the fast entry point.
- --
- arg_regs = case entry_conv of
- DirectEntry lbl arity regs -> regs
- other -> [] -- "(HWL ignored; no args passed in regs)"
-
- num_arg_regs = length arg_regs
-
- (reg_args, stk_args) = splitAt num_arg_regs all_args
-
- (sp_stk_args, stk_offsets, stk_tags)
- = mkTaggedVirtStkOffsets vSp 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 = UnusedReg PtrRep 1
- --slow_entry_code = forceHeapCheck [] True slow_entry_code'
-
- slow_entry_code
- = profCtrC SLIT("TICK_ENT_FUN_STD") [
- CLbl ticky_ctr_label DataPtrRep
- ] `thenC`
-
- -- Bind args, and record expected position of stk ptrs
- mapCs bindNewToStack arg_offsets `thenC`
- setRealAndVirtualSp sp_all_args `thenC`
-
- argSatisfactionCheck closure_info arg_regs `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 (no need to adjust Hp,
- -- but call this function for convenience).
- adjustSpAndHp sp_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
- = moduleName `thenFC` \ mod_name ->
- profCtrC SLIT("TICK_CTR") [
- CLbl ticky_ctr_label DataPtrRep,
- mkCString (_PK_ (ppr_for_ticky_name mod_name name)),
- mkIntCLit stg_arity, -- total # of args
- mkIntCLit sp_stk_args, -- # passed on stk
- mkCString (_PK_ (map (showTypeCategory . idType) all_args))
- ] `thenC`
-
- profCtrC SLIT("TICK_ENT_FUN_DIRECT") [
- CLbl ticky_ctr_label DataPtrRep
- ] `thenC`
-
--- Nuked for now; see comment at end of file
--- CString (_PK_ (show_wrapper_name wrapper_maybe)),
--- CString (_PK_ (show_wrapper_arg_kinds wrapper_maybe))
-
-
- -- Bind args to regs/stack as appropriate, and
- -- record expected position of sps.
- bindArgsToRegs reg_args arg_regs `thenC`
- mapCs bindNewToStack stk_offsets `thenC`
- setRealAndVirtualSp sp_stk_args `thenC`
-
- -- free up the stack slots containing tags
- freeStackSlots (map fst stk_tags) `thenC`
-
- -- Enter the closures cc, if required
- enterCostCentreCode closure_info cc IsFunction False `thenC`
-
- -- Do the business
- funWrapper closure_info arg_regs stk_tags info_label (cgExpr body)
- in
-
- setTickyCtrLabel ticky_ctr_label (
-
- -- 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)
- -- XXX probably need the info table and slow entry code in case of
- -- a heap check failure.
- absC (
- if info_table_needed then
- CClosureInfoAndCode closure_info slow_abs_c (Just fast_abs_c)
- (cl_descr mod_name)
- else
- CCodeBlock fast_label fast_abs_c
- )
- )
- where
- ticky_ctr_label = mkRednCountsLabel name
-
- stg_arity = length all_args
- lf_info = closureLFInfo closure_info
-
- cl_descr mod_name = closureDescription mod_name name
-
- -- Manufacture labels
- name = closureName closure_info
- fast_label = mkFastEntryLabel name stg_arity
- info_label = mkInfoTableLabel name
-
-
--- When printing the name of a thing in a ticky file, we want to
--- give the module name even for *local* things. We print
--- just "x (M)" rather that "M.x" to distinguish them from the global kind.
-ppr_for_ticky_name mod_name name
- | isLocalName name = showSDocDebug (ppr name <+> (parens (ppr mod_name)))
- | otherwise = showSDocDebug (ppr name)
+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 }
+ }