%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgClosure.lhs,v 1.38 1999/11/11 17:50:49 simonpj Exp $
+% $Id: CgClosure.lhs,v 1.62 2003/11/17 14:23:31 simonmar Exp $
%
\section[CgClosure]{Code generation for closures}
\begin{code}
module CgClosure ( cgTopRhsClosure,
cgStdRhsClosure,
- cgRhsClosure,
- closureCodeBody ) where
+ cgRhsClosure,
+ ) 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 CgBindery
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 CgHeapery
+import CgStackery
+import CgUsages
import ClosureInfo -- lots and lots of stuff
+
+import AbsCUtils ( getAmodeRep, mkAbstractCs )
+import AbsCSyn
+import CLabel
+
+import StgSyn
import CmdLineOpts ( opt_GranMacros, opt_SccProfilingOn, opt_DoTickyProfiling )
import CostCentre
import Id ( Id, idName, idType, idPrimRep )
-import Name ( Name, isLocalName )
+import Name ( Name, isInternalName )
import Module ( Module, pprModule )
import ListSetOps ( minusList )
-import PrimRep ( PrimRep(..) )
-import PprType ( showTypeCategory )
-import Util ( isIn )
+import PrimRep ( PrimRep(..), getPrimRepSize )
+import Util ( isIn, splitAtList )
import CmdLineOpts ( opt_SccProfilingOn )
import Outputable
+import FastString
import Name ( nameOccName )
import OccName ( occNameFS )
-getWrapperArgTypeCategories = panic "CgClosure.getWrapperArgTypeCategories (ToDo)"
+-- Turgid imports for showTypeCategory
+import PrelNames
+import TcType ( Type, isDictTy, tcSplitTyConApp_maybe, tcSplitFunTy_maybe )
+import TyCon ( isPrimTyCon, isTupleTyCon, isEnumerationTyCon, maybeTyConSingleCon )
+import Maybe
\end{code}
%********************************************************
cgTopRhsClosure :: Id
-> CostCentreStack -- Optional cost centre annotation
-> StgBinderInfo
+ -> SRT
-> [Id] -- Args
-> StgExpr
-> LambdaFormInfo
-> FCode (Id, CgIdInfo)
-cgTopRhsClosure id ccs binder_info args body lf_info
- = -- LAY OUT THE OBJECT
+cgTopRhsClosure id ccs binder_info srt args body lf_info
+ =
let
- closure_info = layOutStaticNoFVClosure name lf_info
+ name = idName id
+ in
+ -- LAY OUT THE OBJECT
+ getSRTInfo name srt `thenFC` \ srt_info ->
+ moduleName `thenFC` \ mod_name ->
+ let
+ name = idName id
+ descr = closureDescription mod_name name
+ closure_info = layOutStaticNoFVClosure id lf_info srt_info descr
+ closure_label = mkClosureLabel name
+ cg_id_info = stableAmodeIdInfo id (CLbl closure_label PtrRep) 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
+ (
+ ({- if staticClosureRequired name binder_info lf_info
+ then -}
+ absC (mkStaticClosure closure_label closure_info ccs [] True)
+ {- else
nopC -}
+ )
`thenC`
-- GENERATE THE INFO TABLE (IF NECESSARY)
) `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
+
\end{code}
%********************************************************
-- AHA! A STANDARD-FORM THUNK
= (
-- LAY OUT THE OBJECT
- getArgAmodes payload `thenFC` \ amodes ->
+ getArgAmodes payload `thenFC` \ amodes ->
+ moduleName `thenFC` \ mod_name ->
let
+ descr = closureDescription mod_name (idName binder)
+
(closure_info, amodes_w_offsets)
- = layOutDynClosure (idName binder) getAmodeRep amodes lf_info
+ = layOutDynClosure binder getAmodeRep amodes lf_info NoC_SRT descr
+ -- No SRT for a standard-form closure
(use_cc, blame_cc) = chooseDynCostCentres cc args fvs body
in
+
-- BUILD THE OBJECT
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
\end{code}
Here's the general case.
cgRhsClosure :: Id
-> CostCentreStack -- Optional cost centre annotation
-> StgBinderInfo
+ -> SRT
-> [Id] -- Free vars
-> [Id] -- Args
-> StgExpr
-> LambdaFormInfo
-> FCode (Id, CgIdInfo)
-cgRhsClosure binder cc binder_info fvs args body lf_info
+cgRhsClosure binder cc binder_info srt fvs args body lf_info
= (
-- LAY OUT THE OBJECT
--
reduced_fvs = if binder_is_a_fv
then fvs `minusList` [binder]
else fvs
+
+ name = idName binder
in
- mapFCs getCAddrModeAndInfo reduced_fvs `thenFC` \ amodes_and_info ->
+
+ mapFCs getCAddrModeAndInfo reduced_fvs `thenFC` \ fvs_w_amodes_and_info ->
+ getSRTInfo name srt `thenFC` \ srt_info ->
+ moduleName `thenFC` \ mod_name ->
let
- fvs_w_amodes_and_info = reduced_fvs `zip` amodes_and_info
+ descr = closureDescription mod_name (idName binder)
closure_info :: ClosureInfo
- bind_details :: [((Id, (CAddrMode, LambdaFormInfo)), VirtualHeapOffset)]
+ bind_details :: [((Id, CAddrMode, LambdaFormInfo), VirtualHeapOffset)]
(closure_info, bind_details)
- = layOutDynClosure (idName binder) get_kind fvs_w_amodes_and_info lf_info
+ = layOutDynClosure binder get_kind
+ fvs_w_amodes_and_info lf_info srt_info descr
- bind_fv ((id, (_, lf_info)), offset) = bindNewToNode id offset lf_info
+ bind_fv ((id, _, lf_info), offset) = bindNewToNode id offset lf_info
- amodes_w_offsets = [(amode,offset) | ((_, (amode,_)), offset) <- bind_details]
+ amodes_w_offsets = [(amode,offset) | ((_,amode,_), offset) <- bind_details]
- get_kind (id, amode_and_info) = idPrimRep id
+ get_kind (id, _, _) = idPrimRep id
in
+
-- BUILD ITS INFO TABLE AND CODE
forkClosureBody (
-- Bind the fvs
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).
\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))
+ absC (CClosureInfoAndCode closure_info body_absC)
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
+ ticky_ent_lit = if (isStaticClosure closure_info)
+ then FSLIT("TICK_ENT_STATIC_THK")
+ else FSLIT("TICK_ENT_DYN_THK")
+
+ body_code = profCtrC ticky_ent_lit [] `thenC`
+ -- node always points when profiling, so this is ok:
+ ldvEnter `thenC`
+ thunkWrapper closure_info (
+ -- 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)
+ cgExpr body
+ )
+
\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
\begin{code}
closureCodeBody binder_info closure_info cc all_args body
- = getEntryConvention name lf_info
- (map idPrimRep all_args) `thenFC` \ entry_conv ->
+ = let arg_reps = map idPrimRep all_args in
- -- get the current virtual Sp (it might not be zero, eg. if we're
- -- compiling a let-no-escape).
- getVirtSp `thenFC` \vSp ->
+ getEntryConvention name lf_info arg_reps `thenFC` \ entry_conv ->
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
+ -- Arg mapping for the 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.
+ -- Args passed on the stack are not tagged.
--
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") [
- 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 `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'
+ _ -> panic "closureCodeBody"
+ in
- 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`
+ -- 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
+ --
+ (case closureFunInfo closure_info of
+ Just (_, ArgGen slow_lbl liveness) ->
+ absC (maybeLargeBitmap liveness) `thenC`
+ absC (mkSlowEntryCode name slow_lbl arg_regs arg_reps) `thenC`
+ returnFC (mkRegSaveCode arg_regs arg_reps)
- profCtrC SLIT("TICK_ENT_FUN_DIRECT") [
- CLbl ticky_ctr_label DataPtrRep
- ] `thenC`
+ other -> returnFC AbsCNop
+ )
+ `thenFC` \ reg_save_code ->
--- Nuked for now; see comment at end of file
--- CString (_PK_ (show_wrapper_name wrapper_maybe)),
--- CString (_PK_ (show_wrapper_arg_kinds wrapper_maybe))
+ -- get the current virtual Sp (it might not be zero, eg. if we're
+ -- compiling a let-no-escape).
+ getVirtSp `thenFC` \vSp ->
+ let
+ (reg_args, stk_args) = splitAtList arg_regs all_args
+
+ (sp_stk_args, stk_offsets)
+ = mkVirtStkOffsets vSp idPrimRep stk_args
+
+ entry_code = do
+ mod_name <- moduleName
+ profCtrC FSLIT("TICK_CTR") [
+ CLbl ticky_ctr_label DataPtrRep,
+ mkCString (mkFastString (ppr_for_ticky_name mod_name name)),
+ mkIntCLit stg_arity, -- total # of args
+ mkIntCLit sp_stk_args, -- # passed on stk
+ mkCString (mkFastString (map (showTypeCategory . idType) all_args))
+ ]
+ let prof =
+ profCtrC ticky_ent_lit [
+ CLbl ticky_ctr_label DataPtrRep
+ ]
-- 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`
+ bindArgsToRegs reg_args arg_regs
+ mapCs bindNewToStack stk_offsets
+ setRealAndVirtualSp sp_stk_args
-- Enter the closures cc, if required
- enterCostCentreCode closure_info cc IsFunction False `thenC`
+ enterCostCentreCode closure_info cc IsFunction False
-- Do the business
- funWrapper closure_info arg_regs stk_tags info_label (cgExpr body)
+ funWrapper closure_info arg_regs reg_save_code
+ (prof >> 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
- )
+ forkAbsC entry_code `thenFC` \ entry_abs_c ->
+ moduleName `thenFC` \ mod_name ->
+
+ -- Now construct the info table
+ absC (CClosureInfoAndCode closure_info entry_abs_c)
)
where
ticky_ctr_label = mkRednCountsLabel name
+ ticky_ent_lit =
+ if (isStaticClosure closure_info)
+ then FSLIT("TICK_ENT_STATIC_FUN_DIRECT")
+ else FSLIT("TICK_ENT_DYN_FUN_DIRECT")
+
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)))
+ | isInternalName name = showSDocDebug (ppr name <+> (parens (ppr mod_name)))
| otherwise = showSDocDebug (ppr name)
\end{code}
+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.
+
+The slow entry point is used in two places:
+
+ (a) unknown calls: eg. stg_PAP_entry
+ (b) returning from a heap-check failure
+
+\begin{code}
+mkSlowEntryCode :: Name -> CLabel -> [MagicId] -> [PrimRep] -> AbstractC
+mkSlowEntryCode name lbl regs reps
+ = CCodeBlock lbl (
+ mkAbstractCs [assts, stk_adj, jump]
+ )
+ where
+ stk_offsets = scanl (\off rep -> off - getPrimRepSize rep) 0 reps
+
+ assts = mkAbstractCs (zipWith3 mk_asst reps regs stk_offsets)
+ mk_asst rep reg offset = CAssign (CReg reg) (CVal (spRel 0 offset) rep)
+
+ stk_adj = CAssign (CReg Sp) (CAddr (spRel 0 stk_final_offset))
+ stk_final_offset = head (drop (length regs) stk_offsets)
+
+ jump = CJump (CLbl (mkEntryLabel name) CodePtrRep)
+
+mkRegSaveCode :: [MagicId] -> [PrimRep] -> AbstractC
+mkRegSaveCode regs reps
+ = mkAbstractCs [stk_adj, assts]
+ where
+ stk_adj = CAssign (CReg Sp) (CAddr (spRel 0 (negate stk_final_offset)))
+
+ stk_final_offset = head (drop (length regs) stk_offsets)
+ stk_offsets = scanl (\off rep -> off - getPrimRepSize rep) 0 reps
+
+ assts = mkAbstractCs (zipWith3 mk_asst reps regs stk_offsets)
+ mk_asst rep reg offset = CAssign (CVal (spRel 0 offset) rep) (CReg reg)
+\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.
= if not opt_SccProfilingOn then
nopC
else
- ASSERT(not (noCCSAttached ccs))
+ ASSERT2(not (noCCSAttached ccs), ppr (closureName closure_info) <+> ppr ccs)
if isSubsumedCCS ccs then
ASSERT(isToplevClosure closure_info)
ASSERT(is_thunk == IsFunction)
- costCentresC SLIT("ENTER_CCS_FSUB") []
+ costCentresC FSLIT("ENTER_CCS_FSUB") []
- else if isCurrentCCS ccs then
+ else if isDerivedFromCurrentCCS ccs then
if re_entrant && not is_box
- then costCentresC SLIT("ENTER_CCS_FCL") [CReg node]
- else costCentresC SLIT("ENTER_CCS_TCL") [CReg node]
+ then costCentresC FSLIT("ENTER_CCS_FCL") [CReg node]
+ else costCentresC FSLIT("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
+ then costCentresC FSLIT("ENTER_CCS_FSUB") []
+ else costCentresC FSLIT("ENTER_CCS_CAF") c_ccs
else panic "enterCostCentreCode"
%************************************************************************
%* *
-\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.
-
-\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])
- 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
-\end{code}
-
-%************************************************************************
-%* *
\subsubsection[closure-code-wrappers]{Wrappers around closure code}
%* *
%************************************************************************
\begin{code}
-thunkWrapper:: ClosureInfo -> CLabel -> Code -> Code
-thunkWrapper closure_info lbl thunk_code
+thunkWrapper:: ClosureInfo -> Code -> Code
+thunkWrapper closure_info thunk_code
= -- Stack and heap overflow checks
nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points ->
- let
- emit_gran_macros = opt_GranMacros
+ -- HWL: insert macros for GrAnSim; 2 versions depending on liveness of node
+ -- (we prefer fetchAndReschedule-style context switches to yield ones)
+ (if opt_GranMacros
+ then if node_points
+ then fetchAndReschedule [] node_points
+ else yield [] node_points
+ else absC AbsCNop) `thenC`
+
+ let closure_lbl
+ | node_points = Nothing
+ | otherwise = Just (closureLabelFromCI closure_info)
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 lbl node_points (
+ thunkChecks closure_lbl (
-- Overwrite with black hole if necessary
blackHoleIt closure_info node_points `thenC`
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.
+ -> AbstractC -- 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
+funWrapper closure_info arg_regs reg_save_code fun_body
= -- Stack overflow check
- nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points ->
- let
- emit_gran_macros = opt_GranMacros
+ nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points ->
+
+ -- enter for Ldv profiling
+ (if node_points then ldvEnter else nopC) `thenC`
+
+ (if opt_GranMacros
+ then yield arg_regs node_points
+ else absC AbsCNop) `thenC`
+
+ let closure_lbl
+ | node_points = Nothing
+ | otherwise = Just (closureLabelFromCI closure_info)
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 (
+ funEntryChecks closure_lbl reg_save_code (
-- Finally, do the business
fun_body
code
else
case (closureUpdReqd closure_info, isStaticClosure closure_info) of
- (False,False) -> profCtrC SLIT("TICK_UPDF_OMITTED") [] `thenC`
+ (False,False) -> profCtrC FSLIT("TICK_UPDF_OMITTED") [] `thenC`
code
(False,True ) -> (if opt_DoTickyProfiling
then
link_caf seCafBlackHoleClosureInfo `thenFC` \ _ -> nopC
else
nopC) `thenC`
- profCtrC SLIT("TICK_UPD_CAF_BH_SINGLE_ENTRY") [mkCString cl_name] `thenC`
- profCtrC SLIT("TICK_UPDF_OMITTED") [] `thenC`
+ profCtrC FSLIT("TICK_UPD_CAF_BH_SINGLE_ENTRY") [mkCString cl_name] `thenC`
+ profCtrC FSLIT("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") [mkCString cl_name] `thenC`
+ profCtrC FSLIT("TICK_UPD_CAF_BH_UPDATABLE") [mkCString cl_name] `thenC`
pushUpdateFrame update_closure code
where
- cl_name :: FAST_STRING
+ cl_name :: FastString
cl_name = (occNameFS . nameOccName . closureName) closure_info
link_caf :: (ClosureInfo -> ClosureInfo) -- function yielding BH closure_info
-- 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
+ use_cc = CMacroExpr PtrRep CCS_HDR [nodeReg]
blame_cc = use_cc
in
allocDynClosure (bhCI closure_info) use_cc blame_cc [] `thenFC` \ heap_offset ->
ppr name,
char '>'])
\end{code}
-
+
\begin{code}
chooseDynCostCentres ccs args fvs body
= let
\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}
-
+\begin{code}
+showTypeCategory :: Type -> Char
+ {-
+ {C,I,F,D} char, int, float, double
+ T tuple
+ S other single-constructor type
+ {c,i,f,d} unboxed ditto
+ t *unpacked* tuple
+ s *unpacked" single-cons...
+
+ v void#
+ a primitive array
+
+ E enumeration type
+ + dictionary, unless it's a ...
+ L List
+ > function
+ M other (multi-constructor) data-con type
+ . other type
+ - reserved for others to mark as "uninteresting"
+ -}
+showTypeCategory ty
+ = if isDictTy ty
+ then '+'
+ else
+ case tcSplitTyConApp_maybe ty of
+ Nothing -> if isJust (tcSplitFunTy_maybe ty)
+ then '>'
+ else '.'
+
+ Just (tycon, _) ->
+ let utc = getUnique tycon in
+ if utc == charDataConKey then 'C'
+ else if utc == intDataConKey then 'I'
+ else if utc == floatDataConKey then 'F'
+ else if utc == doubleDataConKey then 'D'
+ else if utc == smallIntegerDataConKey ||
+ utc == largeIntegerDataConKey then 'J'
+ else if utc == charPrimTyConKey then 'c'
+ else if (utc == intPrimTyConKey || utc == wordPrimTyConKey
+ || utc == addrPrimTyConKey) then 'i'
+ else if utc == floatPrimTyConKey then 'f'
+ else if utc == doublePrimTyConKey then 'd'
+ else if isPrimTyCon tycon {- array, we hope -} then 'A' -- Bogus
+ else if isEnumerationTyCon tycon then 'E'
+ else if isTupleTyCon tycon then 'T'
+ else if isJust (maybeTyConSingleCon tycon) then 'S'
+ else if utc == listTyConKey then 'L'
+ else 'M' -- oh, well...
+\end{code}
projects / ghc-hetmet.git / blobdiff