%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgClosure.lhs,v 1.32 1999/06/08 15:56:46 simonmar Exp $
+% $Id: CgClosure.lhs,v 1.72 2005/05/18 12:06:51 simonmar Exp $
%
\section[CgClosure]{Code generation for closures}
\begin{code}
module CgClosure ( cgTopRhsClosure,
cgStdRhsClosure,
- cgRhsClosure,
- closureCodeBody ) where
+ cgRhsClosure,
+ emitBlackHoleCode,
+ ) where
#include "HsVersions.h"
import {-# SOURCE #-} CgExpr ( cgExpr )
import CgMonad
-import AbsCSyn
-import StgSyn
-
-import AbsCUtils ( mkAbstractCs, getAmodeRep )
-import CgBindery ( getCAddrMode, getArgAmodes,
- getCAddrModeAndInfo, bindNewToNode,
- bindNewToStack,
- bindNewToReg, bindArgsToRegs,
- stableAmodeIdInfo, heapIdInfo, CgIdInfo
- )
-import CgUpdate ( pushUpdateFrame )
-import CgHeapery ( allocDynClosure,
- fetchAndReschedule, yield, -- HWL
- fastEntryChecks, thunkChecks
- )
-import CgStackery ( mkTaggedVirtStkOffsets, freeStackSlots )
-import CgUsages ( adjustSpAndHp, setRealAndVirtualSp, getVirtSp,
- getSpRelOffset, getHpRelOffset
- )
-import CLabel ( CLabel, mkClosureLabel, mkFastEntryLabel,
- mkRednCountsLabel, mkInfoTableLabel
- )
+import CgBindery
+import CgHeapery
+import CgStackery ( mkVirtStkOffsets, pushUpdateFrame, getVirtSp,
+ setRealAndVirtualSp )
+import CgProf ( chooseDynCostCentres, ldvEnter, enterCostCentre,
+ costCentreFrom )
+import CgTicky
+import CgParallel ( granYield, granFetchAndReschedule )
+import CgInfoTbls ( emitClosureCodeAndInfoTable, getSRTInfo )
+import CgCallConv ( assignCallRegs, mkArgDescr )
+import CgUtils ( emitDataLits, addIdReps, cmmRegOffW,
+ emitRtsCallWithVols )
import ClosureInfo -- lots and lots of stuff
-import CmdLineOpts ( opt_GranMacros, opt_SccProfilingOn, opt_DoTickyProfiling )
+import SMRep ( CgRep, cgRepSizeW, argMachRep, fixedHdrSize, WordOff,
+ idCgRep )
+import MachOp ( MachHint(..) )
+import Cmm
+import CmmUtils ( CmmStmts, mkStmts, oneStmt, plusStmts, noStmts,
+ mkLblExpr )
+import CLabel
+import StgSyn
+import StaticFlags ( opt_DoTickyProfiling )
import CostCentre
-import Id ( Id, idName, idType, idPrimRep )
-import Name ( Name )
+import Id ( Id, idName, idType )
+import Name ( Name, isExternalName )
import Module ( Module, pprModule )
import ListSetOps ( minusList )
-import PrimRep ( PrimRep(..) )
-import PprType ( showTypeCategory )
-import Util ( isIn )
-import CmdLineOpts ( opt_SccProfilingOn )
+import Util ( isIn, mapAccumL, zipWithEqual )
+import BasicTypes ( TopLevelFlag(..) )
+import Constants ( oFFSET_StgInd_indirectee, wORD_SIZE )
import Outputable
-
-import Name ( nameOccName )
-import OccName ( occNameFS )
-
-getWrapperArgTypeCategories = panic "CgClosure.getWrapperArgTypeCategories (ToDo)"
+import FastString
\end{code}
%********************************************************
cgTopRhsClosure :: Id
-> CostCentreStack -- Optional cost centre annotation
-> StgBinderInfo
+ -> SRT
+ -> UpdateFlag
-> [Id] -- Args
-> StgExpr
- -> LambdaFormInfo
-> FCode (Id, CgIdInfo)
-cgTopRhsClosure id ccs binder_info args body lf_info
- = -- LAY OUT THE OBJECT
- let
- closure_info = layOutStaticNoFVClosure name lf_info
- in
-
- -- BUILD THE OBJECT (IF NECESSARY)
- ({- if staticClosureRequired name binder_info lf_info
- then -}
- (if opt_SccProfilingOn
- then
- absC (CStaticClosure
- closure_label -- Labelled with the name on lhs of defn
- closure_info
- (mkCCostCentreStack ccs)
- []) -- No fields
- else
- absC (CStaticClosure
- closure_label -- Labelled with the name on lhs of defn
- closure_info
- (panic "absent cc")
- []) -- No fields
- )
-
- {- else
- nopC -}
- `thenC`
-
- -- GENERATE THE INFO TABLE (IF NECESSARY)
- forkClosureBody (closureCodeBody binder_info closure_info
- ccs args body)
-
- ) `thenC`
-
- returnFC (id, cg_id_info)
- where
- name = idName id
- closure_label = mkClosureLabel name
- cg_id_info = stableAmodeIdInfo id (CLbl closure_label PtrRep) lf_info
+cgTopRhsClosure id ccs binder_info srt upd_flag args body = do
+ { -- LAY OUT THE OBJECT
+ let name = idName id
+ ; lf_info <- mkClosureLFInfo id TopLevel [] upd_flag args
+ ; srt_info <- getSRTInfo name srt
+ ; mod_name <- moduleName
+ ; let descr = closureDescription mod_name name
+ closure_info = mkClosureInfo True id lf_info 0 0 srt_info descr
+ closure_label = mkLocalClosureLabel name
+ cg_id_info = stableIdInfo id (mkLblExpr closure_label) lf_info
+ closure_rep = mkStaticClosureFields closure_info ccs True []
+
+ -- BUILD THE OBJECT, AND GENERATE INFO TABLE (IF NECESSARY)
+ ; emitDataLits closure_label closure_rep
+ ; forkClosureBody (closureCodeBody binder_info closure_info
+ ccs args body)
+
+ ; returnFC (id, cg_id_info) }
\end{code}
%********************************************************
-> [StgArg] -- payload
-> FCode (Id, CgIdInfo)
-cgStdRhsClosure binder cc binder_info fvs args body lf_info payload
- -- AHA! A STANDARD-FORM THUNK
- = (
- -- LAY OUT THE OBJECT
- getArgAmodes payload `thenFC` \ amodes ->
- let
- (closure_info, amodes_w_offsets)
- = layOutDynClosure (idName binder) getAmodeRep amodes lf_info
+cgStdRhsClosure bndr cc bndr_info fvs args body lf_info payload
+ = do -- AHA! A STANDARD-FORM THUNK
+ { -- LAY OUT THE OBJECT
+ amodes <- getArgAmodes payload
+ ; mod_name <- moduleName
+ ; let (tot_wds, ptr_wds, amodes_w_offsets)
+ = mkVirtHeapOffsets (isLFThunk lf_info) amodes
+
+ descr = closureDescription mod_name (idName bndr)
+ closure_info = mkClosureInfo False -- Not static
+ bndr lf_info tot_wds ptr_wds
+ NoC_SRT -- No SRT for a std-form closure
+ descr
+
+ ; (use_cc, blame_cc) <- chooseDynCostCentres cc args body
- (use_cc, blame_cc) = chooseDynCostCentres cc args fvs body
- in
-- BUILD THE OBJECT
- allocDynClosure closure_info use_cc blame_cc amodes_w_offsets
- )
- `thenFC` \ heap_offset ->
+ ; heap_offset <- allocDynClosure closure_info use_cc blame_cc amodes_w_offsets
-- RETURN
- returnFC (binder, heapIdInfo binder heap_offset lf_info)
-
- where
- is_std_thunk = isStandardFormThunk lf_info
+ ; returnFC (bndr, heapIdInfo bndr heap_offset lf_info) }
\end{code}
Here's the general case.
cgRhsClosure :: Id
-> CostCentreStack -- Optional cost centre annotation
-> StgBinderInfo
+ -> SRT
-> [Id] -- Free vars
+ -> UpdateFlag
-> [Id] -- Args
-> StgExpr
- -> LambdaFormInfo
-> FCode (Id, CgIdInfo)
-cgRhsClosure binder cc binder_info fvs args body lf_info
- = (
- -- LAY OUT THE OBJECT
- --
+cgRhsClosure bndr cc bndr_info srt fvs upd_flag args body = do
+ { -- LAY OUT THE OBJECT
-- If the binder is itself a free variable, then don't store
-- it in the closure. Instead, just bind it to Node on entry.
-- NB we can be sure that Node will point to it, because we
-- havn't told mkClosureLFInfo about this; so if the binder
- -- *was* a free var of its RHS, mkClosureLFInfo thinks it *is*
+ -- _was_ a free var of its RHS, mkClosureLFInfo thinks it *is*
-- stored in the closure itself, so it will make sure that
-- Node points to it...
let
- is_elem = isIn "cgRhsClosure"
-
- binder_is_a_fv = binder `is_elem` fvs
- reduced_fvs = if binder_is_a_fv
- then fvs `minusList` [binder]
- else fvs
- in
- mapFCs getCAddrModeAndInfo reduced_fvs `thenFC` \ amodes_and_info ->
- let
- fvs_w_amodes_and_info = reduced_fvs `zip` amodes_and_info
-
- closure_info :: ClosureInfo
- bind_details :: [((Id, (CAddrMode, LambdaFormInfo)), VirtualHeapOffset)]
-
- (closure_info, bind_details)
- = layOutDynClosure (idName binder) get_kind fvs_w_amodes_and_info lf_info
+ name = idName bndr
+ is_elem = isIn "cgRhsClosure"
+ bndr_is_a_fv = bndr `is_elem` fvs
+ reduced_fvs | bndr_is_a_fv = fvs `minusList` [bndr]
+ | otherwise = fvs
+
+ ; lf_info <- mkClosureLFInfo bndr NotTopLevel fvs upd_flag args
+ ; fv_infos <- mapFCs getCgIdInfo reduced_fvs
+ ; srt_info <- getSRTInfo name srt
+ ; mod_name <- moduleName
+ ; let bind_details :: [(CgIdInfo, VirtualHpOffset)]
+ (tot_wds, ptr_wds, bind_details)
+ = mkVirtHeapOffsets (isLFThunk lf_info) (map add_rep fv_infos)
+
+ add_rep info = (cgIdInfoArgRep info, info)
+
+ descr = closureDescription mod_name name
+ closure_info = mkClosureInfo False -- Not static
+ bndr lf_info tot_wds ptr_wds
+ srt_info descr
- bind_fv ((id, (_, lf_info)), offset) = bindNewToNode id offset lf_info
-
- amodes_w_offsets = [(amode,offset) | ((_, (amode,_)), offset) <- bind_details]
-
- get_kind (id, amode_and_info) = idPrimRep id
- in
-- BUILD ITS INFO TABLE AND CODE
- forkClosureBody (
- -- Bind the fvs
- mapCs bind_fv bind_details `thenC`
+ ; forkClosureBody (do
+ { -- Bind the fvs
+ let bind_fv (info, offset)
+ = bindNewToNode (cgIdInfoId info) offset (cgIdInfoLF info)
+ ; mapCs bind_fv bind_details
-- Bind the binder itself, if it is a free var
- (if binder_is_a_fv then
- bindNewToReg binder node lf_info
- else
- nopC) `thenC`
-
+ ; whenC bndr_is_a_fv (bindNewToReg bndr nodeReg lf_info)
+
-- Compile the body
- closureCodeBody binder_info closure_info cc args body
- ) `thenC`
+ ; closureCodeBody bndr_info closure_info cc args body })
-- BUILD THE OBJECT
- let
- (use_cc, blame_cc) = chooseDynCostCentres cc args fvs body
- in
- allocDynClosure closure_info use_cc blame_cc amodes_w_offsets
- ) `thenFC` \ heap_offset ->
+ ; let
+ to_amode (info, offset) = do { amode <- idInfoToAmode info
+ ; return (amode, offset) }
+ ; (use_cc, blame_cc) <- chooseDynCostCentres cc args body
+ ; amodes_w_offsets <- mapFCs to_amode bind_details
+ ; heap_offset <- allocDynClosure closure_info use_cc blame_cc amodes_w_offsets
-- RETURN
- returnFC (binder, heapIdInfo binder heap_offset lf_info)
+ ; returnFC (bndr, heapIdInfo bndr heap_offset lf_info) }
+
+
+mkClosureLFInfo :: Id -- The binder
+ -> TopLevelFlag -- True of top level
+ -> [Id] -- Free vars
+ -> UpdateFlag -- Update flag
+ -> [Id] -- Args
+ -> FCode LambdaFormInfo
+mkClosureLFInfo bndr top fvs upd_flag args
+ | null args = return (mkLFThunk (idType bndr) top fvs upd_flag)
+ | otherwise = do { arg_descr <- mkArgDescr (idName bndr) args
+ ; return (mkLFReEntrant top fvs args arg_descr) }
\end{code}
+
%************************************************************************
%* *
\subsection[code-for-closures]{The code for closures}
There are two main cases for the code for closures. If there are {\em
no arguments}, then the closure is a thunk, and not in normal form.
-So it should set up an update frame (if it is shared). Also, it has
-no argument satisfaction check, so fast and slow entry-point labels
-are the same.
+So it should set up an update frame (if it is shared).
+NB: Thunks cannot have a primitive type!
\begin{code}
-closureCodeBody binder_info closure_info cc [] body
- = -- thunks cannot have a primitive type!
- getAbsC body_code `thenFC` \ body_absC ->
- moduleName `thenFC` \ mod_name ->
-
- absC (CClosureInfoAndCode closure_info body_absC Nothing
- (cl_descr mod_name))
- where
- cl_descr mod_name = closureDescription mod_name (closureName closure_info)
-
- body_label = entryLabelFromCI closure_info
- is_box = case body of { StgApp fun [] -> True; _ -> False }
-
- body_code = profCtrC SLIT("TICK_ENT_THK") [] `thenC`
- thunkWrapper closure_info body_label (
- -- We only enter cc after setting up update so that cc
- -- of enclosing scope will be recorded in update frame
- -- CAF/DICT functions will be subsumed by this enclosing cc
- enterCostCentreCode closure_info cc IsThunk is_box `thenC`
- cgExpr body)
+closureCodeBody binder_info cl_info cc [{- No args i.e. thunk -}] body = do
+ { body_absC <- getCgStmts $ do
+ { tickyEnterThunk cl_info
+ ; ldvEnter (CmmReg nodeReg) -- NB: Node always points when profiling
+ ; thunkWrapper cl_info $ do
+ -- We only enter cc after setting up update so
+ -- that cc of enclosing scope will be recorded
+ -- in update frame CAF/DICT functions will be
+ -- subsumed by this enclosing cc
+ { enterCostCentre cl_info cc body
+ ; cgExpr body }
+ }
+
+ ; emitClosureCodeAndInfoTable cl_info [] body_absC }
\end{code}
-If there is {\em at least one argument}, then this closure is in
-normal form, so there is no need to set up an update frame. On the
-other hand, we do have to check that there are enough args, and
-perform an update if not!
+If there is /at least one argument/, then this closure is in
+normal form, so there is no need to set up an update frame.
The Macros for GrAnSim are produced at the beginning of the
argSatisfactionCheck (by calling fetchAndReschedule). There info if
Node points to closure is available. -- HWL
\begin{code}
-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, arg_tags)
- = 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 -> panic "closureCodeBody:arg_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") [] `thenC`
-
- -- Bind args, and record expected position of stk ptrs
- mapCs bindNewToStack arg_offsets `thenC`
- setRealAndVirtualSp sp_all_args `thenC`
-
- argSatisfactionCheck closure_info `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
- = profCtrC SLIT("TICK_ENT_FUN_DIRECT") [
- mkIntCLit stg_arity -- total # of args
-
- {- CLbl (mkRednCountsLabel name) PtrRep,
- CString (_PK_ (showSDoc (ppr name))),
- mkIntCLit stg_arity, -- total # of args
- mkIntCLit sp_stk_args, -- # passed on stk
- CString (_PK_ (map (showTypeCategory . idType) all_args)),
- CString SLIT(""), CString SLIT("")
- -}
-
--- Nuked for now; see comment at end of file
--- 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 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
- -- 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
- 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
+closureCodeBody binder_info cl_info cc args body
+ = ASSERT( length args > 0 )
+ 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 }
+ }
\end{code}
-For lexically scoped profiling we have to load the cost centre from
-the closure entered, if the costs are not supposed to be inherited.
-This is done immediately on entering the fast entry point.
+The "slow entry" code for a function. This entry point takes its
+arguments on the stack. It loads the arguments into registers
+according to the calling convention, and jumps to the function's
+normal entry point. The function's closure is assumed to be in
+R1/node.
-Load current cost centre from closure, if not inherited.
-Node is guaranteed to point to it, if profiling and not inherited.
+The slow entry point is used in two places:
-\begin{code}
-data IsThunk = IsThunk | IsFunction -- Bool-like, local
--- #ifdef DEBUG
- deriving Eq
--- #endif
-
-enterCostCentreCode
- :: ClosureInfo -> CostCentreStack
- -> IsThunk
- -> Bool -- is_box: this closure is a special box introduced by SCCfinal
- -> Code
-
-enterCostCentreCode closure_info ccs is_thunk is_box
- = if not opt_SccProfilingOn then
- nopC
- else
- ASSERT(not (noCCSAttached ccs))
-
- if isSubsumedCCS ccs then
- ASSERT(isToplevClosure closure_info)
- ASSERT(is_thunk == IsFunction)
- costCentresC SLIT("ENTER_CCS_FSUB") []
-
- else if isCurrentCCS ccs then
- if re_entrant && not is_box
- then costCentresC SLIT("ENTER_CCS_FCL") [CReg node]
- else costCentresC SLIT("ENTER_CCS_TCL") [CReg node]
-
- else if isCafCCS ccs then
- ASSERT(isToplevClosure closure_info)
- ASSERT(is_thunk == IsThunk)
- -- might be a PAP, in which case we want to subsume costs
- if re_entrant
- then costCentresC SLIT("ENTER_CCS_FSUB") []
- else costCentresC SLIT("ENTER_CCS_CAF") c_ccs
-
- else panic "enterCostCentreCode"
-
- where
- c_ccs = [mkCCostCentreStack ccs]
- re_entrant = closureReEntrant closure_info
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[pre-closure-code-stuff]{Pre-closure-code code}
-%* *
-%************************************************************************
-
-The argument-satisfaction check code is placed after binding
-the arguments to their stack locations. Hence, the virtual stack
-pointer is pointing after all the args, and virtual offset 1 means
-the base of frame and hence most distant arg. Hence
-virtual offset 0 is just beyond the most distant argument; the
-relative offset of this word tells how many words of arguments
-are expected.
+ (a) unknown calls: eg. stg_PAP_entry
+ (b) returning from a heap-check failure
\begin{code}
-argSatisfactionCheck :: ClosureInfo -> Code
-
-argSatisfactionCheck closure_info
-
- = nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points ->
-
- let
- emit_gran_macros = opt_GranMacros
- in
-
- -- HWL ngo' ngoq:
- -- absC (CMacroStmt GRAN_FETCH []) `thenC`
- -- forceHeapCheck [] node_points (absC AbsCNop) `thenC`
- (if emit_gran_macros
- then if node_points
- then fetchAndReschedule [] node_points
- else yield [] node_points
- else absC AbsCNop) `thenC`
-
- getSpRelOffset 0 `thenFC` \ (SpRel sp) ->
- let
- off = I# sp
- rel_arg = mkIntCLit off
- in
- ASSERT(off /= 0)
- if node_points then
- absC (CMacroStmt ARGS_CHK [rel_arg]) -- node already points
- else
- absC (CMacroStmt ARGS_CHK_LOAD_NODE [rel_arg, set_Node_to_this])
+mkSlowEntryCode :: ClosureInfo -> [(Id,GlobalReg)] -> FCode CmmStmts
+-- If this function doesn't have a specialised ArgDescr, we need
+-- to generate the function's arg bitmap, slow-entry code, and
+-- register-save code for the heap-check failure
+-- Here, we emit the slow-entry code, and
+-- return the register-save assignments
+mkSlowEntryCode cl_info reg_args
+ | Just (_, ArgGen _) <- closureFunInfo cl_info
+ = do { emitSimpleProc slow_lbl (emitStmts load_stmts)
+ ; return save_stmts }
+ | otherwise = return noStmts
where
- -- We must tell the arg-satis macro whether Node is pointing to
- -- the closure or not. If it isn't so pointing, then we give to
- -- the macro the (static) address of the closure.
-
- set_Node_to_this = CLbl (closureLabelFromCI closure_info) PtrRep
+ name = closureName cl_info
+ slow_lbl = mkSlowEntryLabel name
+
+ load_stmts = mkStmts load_assts `plusStmts` mkStmts [stk_adj_pop, jump_to_entry]
+ save_stmts = oneStmt stk_adj_push `plusStmts` mkStmts save_assts
+
+ reps_w_regs :: [(CgRep,GlobalReg)]
+ reps_w_regs = [(idCgRep id, reg) | (id,reg) <- reverse reg_args]
+ (final_stk_offset, stk_offsets)
+ = mapAccumL (\off (rep,_) -> (off + cgRepSizeW rep, off))
+ 0 reps_w_regs
+
+ load_assts = zipWithEqual "mk_load" mk_load reps_w_regs stk_offsets
+ mk_load (rep,reg) offset = CmmAssign (CmmGlobal reg)
+ (CmmLoad (cmmRegOffW spReg offset)
+ (argMachRep rep))
+
+ save_assts = zipWithEqual "mk_save" mk_save reps_w_regs stk_offsets
+ mk_save (rep,reg) offset = ASSERT( argMachRep rep == globalRegRep reg )
+ CmmStore (cmmRegOffW spReg offset)
+ (CmmReg (CmmGlobal reg))
+
+ stk_adj_pop = CmmAssign spReg (cmmRegOffW spReg final_stk_offset)
+ stk_adj_push = CmmAssign spReg (cmmRegOffW spReg (- final_stk_offset))
+ jump_to_entry = CmmJump (mkLblExpr (enterLocalIdLabel name)) []
\end{code}
+
%************************************************************************
%* *
\subsubsection[closure-code-wrappers]{Wrappers around closure code}
%************************************************************************
\begin{code}
-thunkWrapper:: ClosureInfo -> CLabel -> Code -> Code
-thunkWrapper closure_info label thunk_code
- = -- Stack and heap overflow checks
- nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points ->
-
- let
- emit_gran_macros = opt_GranMacros
- in
- -- HWL: insert macros for GrAnSim; 2 versions depending on liveness of node
- -- (we prefer fetchAndReschedule-style context switches to yield ones)
- (if emit_gran_macros
- then if node_points
- then fetchAndReschedule [] node_points
- else yield [] node_points
- else absC AbsCNop) `thenC`
-
- -- stack and/or heap checks
- thunkChecks label node_points (
-
- -- Overwrite with black hole if necessary
- blackHoleIt closure_info node_points `thenC`
-
- setupUpdate closure_info ( -- setupUpdate *encloses* the rest
-
- -- Finally, do the business
- thunk_code
- ))
+thunkWrapper:: ClosureInfo -> Code -> Code
+thunkWrapper closure_info thunk_code = do
+ { let node_points = nodeMustPointToIt (closureLFInfo closure_info)
+
+ -- HWL: insert macros for GrAnSim; 2 versions depending on liveness of node
+ -- (we prefer fetchAndReschedule-style context switches to yield ones)
+ ; if node_points
+ then granFetchAndReschedule [] node_points
+ else granYield [] node_points
+
+ -- Stack and/or heap checks
+ ; thunkEntryChecks closure_info $ do
+ { -- Overwrite with black hole if necessary
+ whenC (blackHoleOnEntry closure_info && node_points)
+ (blackHoleIt closure_info)
+ ; setupUpdate closure_info thunk_code }
+ -- setupUpdate *encloses* the thunk_code
+ }
funWrapper :: ClosureInfo -- Closure whose code body this is
- -> [MagicId] -- List of argument registers (if any)
- -> [(VirtualSpOffset,Int)] -- tagged stack slots
- -> CLabel -- info table for heap check ret.
+ -> [(Id,GlobalReg)] -- List of argument registers (if any)
+ -> CmmStmts -- reg saves for the heap check failure
-> Code -- Body of function being compiled
-> Code
-funWrapper closure_info arg_regs stk_tags info_label fun_body
- = -- Stack overflow check
- nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points ->
- let
- emit_gran_macros = opt_GranMacros
- in
- -- HWL chu' ngoq:
- (if emit_gran_macros
- then yield arg_regs node_points
- else absC AbsCNop) `thenC`
-
- -- heap and/or stack checks
- fastEntryChecks arg_regs stk_tags info_label node_points (
-
- -- Finally, do the business
- fun_body
- )
+funWrapper closure_info arg_regs reg_save_code fun_body = do
+ { let node_points = nodeMustPointToIt (closureLFInfo closure_info)
+
+ -- Enter for Ldv profiling
+ ; whenC node_points (ldvEnter (CmmReg nodeReg))
+
+ -- GranSim yeild poin
+ ; granYield arg_regs node_points
+
+ -- Heap and/or stack checks wrap the function body
+ ; funEntryChecks closure_info reg_save_code
+ fun_body
+ }
\end{code}
\begin{code}
-blackHoleIt :: ClosureInfo -> Bool -> Code -- Only called for closures with no args
-
-blackHoleIt closure_info node_points
- = if blackHoleOnEntry closure_info && node_points
- then
- absC (if closureSingleEntry(closure_info) then
- CMacroStmt UPD_BH_SINGLE_ENTRY [CReg node]
- else
- CMacroStmt UPD_BH_UPDATABLE [CReg node])
- else
+blackHoleIt :: ClosureInfo -> Code
+-- Only called for closures with no args
+-- Node points to the closure
+blackHoleIt closure_info = emitBlackHoleCode (closureSingleEntry closure_info)
+
+emitBlackHoleCode :: Bool -> Code
+emitBlackHoleCode is_single_entry
+ | eager_blackholing = do
+ tickyBlackHole (not is_single_entry)
+ stmtC (CmmStore (CmmReg nodeReg) (CmmLit (CmmLabel bh_lbl)))
+ | otherwise =
nopC
+ where
+ bh_lbl | is_single_entry = mkRtsDataLabel SLIT("stg_SE_BLACKHOLE_info")
+ | otherwise = mkRtsDataLabel SLIT("stg_BLACKHOLE_info")
+
+ -- If we wanted to do eager blackholing with slop filling,
+ -- we'd need to do it at the *end* of a basic block, otherwise
+ -- we overwrite the free variables in the thunk that we still
+ -- need. We have a patch for this from Andy Cheadle, but not
+ -- incorporated yet. --SDM [6/2004]
+ --
+ -- Profiling needs slop filling (to support LDV profiling), so
+ -- currently eager blackholing doesn't work with profiling.
+ --
+ -- TICKY_TICKY needs EAGER_BLACKHOLING to verify no double-entries of
+ -- single-entry thunks.
+ eager_blackholing
+ | opt_DoTickyProfiling = True
+ | otherwise = False
+
\end{code}
\begin{code}
setupUpdate :: ClosureInfo -> Code -> Code -- Only called for closures with no args
-- Nota Bene: this function does not change Node (even if it's a CAF),
-- so that the cost centre in the original closure can still be
- -- extracted by a subsequent ENTER_CC_TCL
-
--- I've tidied up the code for this function, but it should still do the same as
--- it did before (modulo ticky stuff). KSW 1999-04.
+ -- extracted by a subsequent enterCostCentre
setupUpdate closure_info code
- = if closureReEntrant closure_info
- then
- code
- else
- case (closureUpdReqd closure_info, isStaticClosure closure_info) of
- (False,False) -> profCtrC SLIT("TICK_UPDF_OMITTED") [] `thenC`
- code
- (False,True ) -> (if opt_DoTickyProfiling
- then
- -- blackhole the SE CAF
- link_caf seCafBlackHoleClosureInfo `thenFC` \ _ -> nopC
- else
- nopC) `thenC`
- profCtrC SLIT("TICK_UPD_CAF_BH_SINGLE_ENTRY") [CString cl_name] `thenC`
- profCtrC SLIT("TICK_UPDF_OMITTED") [] `thenC`
- code
- (True ,False) -> pushUpdateFrame (CReg node) code
- (True ,True ) -> -- blackhole the (updatable) CAF:
- link_caf cafBlackHoleClosureInfo `thenFC` \ update_closure ->
- profCtrC SLIT("TICK_UPD_CAF_BH_UPDATABLE") [CString cl_name] `thenC`
- pushUpdateFrame update_closure code
- where
- cl_name :: FAST_STRING
- cl_name = (occNameFS . nameOccName . closureName) closure_info
-
- link_caf :: (ClosureInfo -> ClosureInfo) -- function yielding BH closure_info
- -> FCode CAddrMode -- Returns amode for closure to be updated
- link_caf bhCI
- = -- To update a CAF we must allocate a black hole, link the CAF onto the
- -- CAF list, then update the CAF to point to the fresh black hole.
- -- This function returns the address of the black hole, so it can be
- -- updated with the new value when available.
-
- -- Alloc black hole specifying CC_HDR(Node) as the cost centre
- -- Hack Warning: Using a CLitLit to get CAddrMode !
- let
- use_cc = CLitLit SLIT("CCS_HDR(R1.p)") PtrRep
- blame_cc = use_cc
- in
- allocDynClosure (bhCI closure_info) use_cc blame_cc [] `thenFC` \ heap_offset ->
- getHpRelOffset heap_offset `thenFC` \ hp_rel ->
- let amode = CAddr hp_rel
- in
- absC (CMacroStmt UPD_CAF [CReg node, amode]) `thenC`
- returnFC amode
+ | closureReEntrant closure_info
+ = code
+
+ | not (isStaticClosure closure_info)
+ = if closureUpdReqd closure_info
+ then do { tickyPushUpdateFrame; pushUpdateFrame (CmmReg nodeReg) code }
+ else do { tickyUpdateFrameOmitted; code }
+
+ | otherwise -- A static closure
+ = do { tickyUpdateBhCaf closure_info
+
+ ; if closureUpdReqd closure_info
+ then do -- Blackhole the (updatable) CAF:
+ { upd_closure <- link_caf closure_info True
+ ; pushUpdateFrame upd_closure code }
+ else do
+ { -- No update reqd, you'd think we don't need to
+ -- black-hole it. But when ticky-ticky is on, we
+ -- black-hole it regardless, to catch errors in which
+ -- an allegedly single-entry closure is entered twice
+ --
+ -- We discard the pointer returned by link_caf, because
+ -- we don't push an update frame
+ whenC opt_DoTickyProfiling -- Blackhole even a SE CAF
+ (link_caf closure_info False >> nopC)
+ ; tickyUpdateFrameOmitted
+ ; code }
+ }
+
+
+-----------------------------------------------------------------------------
+-- Entering a CAF
+--
+-- When a CAF is first entered, it creates a black hole in the heap,
+-- and updates itself with an indirection to this new black hole.
+--
+-- We update the CAF with an indirection to a newly-allocated black
+-- hole in the heap. We also set the blocking queue on the newly
+-- allocated black hole to be empty.
+--
+-- Why do we make a black hole in the heap when we enter a CAF?
+--
+-- - for a generational garbage collector, which needs a fast
+-- test for whether an updatee is in an old generation or not
+--
+-- - for the parallel system, which can implement updates more
+-- easily if the updatee is always in the heap. (allegedly).
+--
+-- When debugging, we maintain a separate CAF list so we can tell when
+-- a CAF has been garbage collected.
+
+-- newCAF must be called before the itbl ptr is overwritten, since
+-- newCAF records the old itbl ptr in order to do CAF reverting
+-- (which Hugs needs to do in order that combined mode works right.)
+--
+
+-- ToDo [Feb 04] This entire link_caf nonsense could all be moved
+-- into the "newCAF" RTS procedure, which we call anyway, including
+-- the allocation of the black-hole indirection closure.
+-- That way, code size would fall, the CAF-handling code would
+-- be closer together, and the compiler wouldn't need to know
+-- about off_indirectee etc.
+
+link_caf :: ClosureInfo
+ -> Bool -- True <=> updatable, False <=> single-entry
+ -> FCode CmmExpr -- Returns amode for closure to be updated
+-- To update a CAF we must allocate a black hole, link the CAF onto the
+-- CAF list, then update the CAF to point to the fresh black hole.
+-- This function returns the address of the black hole, so it can be
+-- updated with the new value when available. The reason for all of this
+-- is that we only want to update dynamic heap objects, not static ones,
+-- so that generational GC is easier.
+link_caf cl_info is_upd = do
+ { -- Alloc black hole specifying CC_HDR(Node) as the cost centre
+ ; let use_cc = costCentreFrom (CmmReg nodeReg)
+ blame_cc = use_cc
+ ; hp_offset <- allocDynClosure bh_cl_info use_cc blame_cc []
+ ; hp_rel <- getHpRelOffset hp_offset
+
+ -- Call the RTS function newCAF to add the CAF to the CafList
+ -- so that the garbage collector can find them
+ -- This must be done *before* the info table pointer is overwritten,
+ -- because the old info table ptr is needed for reversion
+ ; emitRtsCallWithVols SLIT("newCAF") [(CmmReg nodeReg,PtrHint)] [node]
+ -- node is live, so save it.
+
+ -- Overwrite the closure with a (static) indirection
+ -- to the newly-allocated black hole
+ ; stmtsC [ CmmStore (cmmRegOffW nodeReg off_indirectee) hp_rel
+ , CmmStore (CmmReg nodeReg) ind_static_info ]
+
+ ; returnFC hp_rel }
+ where
+ bh_cl_info :: ClosureInfo
+ bh_cl_info | is_upd = cafBlackHoleClosureInfo cl_info
+ | otherwise = seCafBlackHoleClosureInfo cl_info
+
+ ind_static_info :: CmmExpr
+ ind_static_info = mkLblExpr mkIndStaticInfoLabel
+
+ off_indirectee :: WordOff
+ off_indirectee = fixedHdrSize + oFFSET_StgInd_indirectee*wORD_SIZE
\end{code}
+
%************************************************************************
%* *
\subsection[CgClosure-Description]{Profiling Closure Description.}
%************************************************************************
For "global" data constructors the description is simply occurrence
-name of the data constructor itself (see \ref{CgConTbls-info-tables}).
-
-Otherwise it is determind by @closureDescription@ from the let
-binding information.
+name of the data constructor itself. Otherwise it is determined by
+@closureDescription@ from the let binding information.
\begin{code}
closureDescription :: Module -- Module
-> Name -- Id of closure binding
-> String
-
-- Not called for StgRhsCon which have global info tables built in
-- CgConTbls.lhs with a description generated from the data constructor
-
closureDescription mod_name name
- = showSDoc (
- hcat [char '<',
- pprModule mod_name,
- char '.',
- ppr name,
- char '>'])
+ = showSDocDump (char '<' <>
+ (if isExternalName name
+ then ppr name -- ppr will include the module name prefix
+ else pprModule mod_name <> char '.' <> ppr name) <>
+ char '>')
+ -- showSDocDump, because we want to see the unique on the Name.
\end{code}
-
-\begin{code}
-chooseDynCostCentres ccs args fvs body
- = let
- use_cc -- cost-centre we record in the object
- = if currentOrSubsumedCCS ccs
- then CReg CurCostCentre
- else mkCCostCentreStack ccs
-
- blame_cc -- cost-centre on whom we blame the allocation
- = case (args, fvs, body) of
- ([], _, StgApp fun [{-no args-}])
- -> mkCCostCentreStack overheadCCS
- _ -> use_cc
-
- -- if it's an utterly trivial RHS, then it must be
- -- one introduced by boxHigherOrderArgs for profiling,
- -- so we charge it to "OVERHEAD".
-
- -- This looks like a HACK to me --SDM
- in
- (use_cc, blame_cc)
-\end{code}
-
-
-
-========================================================================
-OLD CODE THAT EMITTED INFORMATON FOR QUANTITATIVE ANALYSIS
-
-It's pretty wierd, so I've nuked it for now. SLPJ Nov 96
-
-\begin{pseudocode}
-getWrapperArgTypeCategories
- :: Type -- wrapper's type
- -> StrictnessInfo bdee -- strictness info about its args
- -> Maybe String
-
-getWrapperArgTypeCategories _ NoStrictnessInfo = Nothing
-getWrapperArgTypeCategories _ BottomGuaranteed
- = trace "getWrapperArgTypeCategories:BottomGuaranteed!" Nothing -- wrong
-getWrapperArgTypeCategories _ (StrictnessInfo [] _) = Nothing
-
-getWrapperArgTypeCategories ty (StrictnessInfo arg_info _)
- = Just (mkWrapperArgTypeCategories ty arg_info)
-
-mkWrapperArgTypeCategories
- :: Type -- wrapper's type
- -> [Demand] -- info about its arguments
- -> String -- a string saying lots about the args
-
-mkWrapperArgTypeCategories wrapper_ty wrap_info
- = case (splitFunTy_maybe wrapper_ty) of { Just (arg_tys,_) ->
- map do_one (wrap_info `zip` (map showTypeCategory arg_tys)) }
- where
- -- ToDo: this needs FIXING UP (it was a hack anyway...)
- do_one (WwPrim, _) = 'P'
- do_one (WwEnum, _) = 'E'
- do_one (WwStrict, arg_ty_char) = arg_ty_char
- do_one (WwUnpack _ _ _, arg_ty_char)
- = if arg_ty_char `elem` "CIJFDTS"
- then toLower arg_ty_char
- else if arg_ty_char == '+' then 't'
- else trace ("mkWrapp..:funny char:"++[arg_ty_char]) '-'
- do_one (other_wrap_info, _) = '-'
-\end{pseudocode}
-
+
projects / ghc-hetmet.git / blobdiff