%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[CgClosure]{Code generation for closures}
module CgClosure ( cgTopRhsClosure, cgRhsClosure ) where
-import Ubiq{-uitous-}
-import CgLoop2 ( cgExpr, cgSccExpr )
+IMP_Ubiq(){-uitous-}
+IMPORT_DELOOPER(CgLoop2) ( cgExpr )
import CgMonad
import AbsCSyn
getCAddrModeAndInfo, bindNewToNode,
bindNewToAStack, bindNewToBStack,
bindNewToReg, bindArgsToRegs,
- stableAmodeIdInfo, heapIdInfo
+ stableAmodeIdInfo, heapIdInfo, CgIdInfo
)
-import CgCompInfo ( spARelToInt, spBRelToInt )
+import Constants ( spARelToInt, spBRelToInt )
import CgUpdate ( pushUpdateFrame )
import CgHeapery ( allocDynClosure, heapCheck
-#ifdef GRAN
- , fetchAndReschedule -- HWL
-#endif
+ , heapCheckOnly, fetchAndReschedule, yield -- HWL
)
-import CgRetConv ( mkLiveRegsMask,
- ctrlReturnConvAlg, dataReturnConvAlg,
+import CgRetConv ( ctrlReturnConvAlg, dataReturnConvAlg,
CtrlReturnConvention(..), DataReturnConvention(..)
)
import CgStackery ( getFinalStackHW, mkVirtStkOffsets,
getSpARelOffset, getSpBRelOffset,
getHpRelOffset
)
-import CLabel ( mkClosureLabel, mkConUpdCodePtrVecLabel,
+import CLabel ( mkClosureLabel, mkConUpdCodePtrVecLabel, mkFastEntryLabel,
mkStdUpdCodePtrVecLabel, mkStdUpdVecTblLabel,
mkErrorStdEntryLabel, mkRednCountsLabel
)
import ClosureInfo -- lots and lots of stuff
-import CmdLineOpts ( opt_EmitArityChecks, opt_ForConcurrent )
+import CmdLineOpts ( opt_ForConcurrent, opt_GranMacros )
import CostCentre ( useCurrentCostCentre, currentOrSubsumedCosts,
noCostCentreAttached, costsAreSubsumed,
- isCafCC, overheadCostCentre
+ isCafCC, isDictCC, overheadCostCentre, showCostCentre
)
-import HeapOffs ( VirtualHeapOffset(..) )
+import HeapOffs ( SYN_IE(VirtualHeapOffset) )
import Id ( idType, idPrimRep,
showId, getIdStrictness, dataConTag,
emptyIdSet,
)
import ListSetOps ( minusList )
import Maybes ( maybeToBool )
+import Outputable ( Outputable(..){-instances-} ) -- ToDo:rm
import PprStyle ( PprStyle(..) )
import PprType ( GenType{-instance Outputable-}, TyCon{-ditto-} )
-import Pretty ( prettyToUn, ppBesides, ppChar, ppPStr )
+import Pretty ( prettyToUn, ppBesides, ppChar, ppPStr, ppCat, ppStr )
import PrimRep ( isFollowableRep, PrimRep(..) )
import TyCon ( isPrimTyCon, tyConDataCons )
+import Type ( showTypeCategory )
import Unpretty ( uppShow )
-import Util ( isIn, panic, pprPanic, assertPanic )
+import Util ( isIn, panic, pprPanic, assertPanic, pprTrace{-ToDo:rm-} )
-myWrapperMaybe = panic "CgClosure.myWrapperMaybe (ToDo)"
-showTypeCategory = panic "CgClosure.showTypeCategory (ToDo)"
getWrapperArgTypeCategories = panic "CgClosure.getWrapperArgTypeCategories (ToDo)"
\end{code}
-- 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) emptyIdSet
+ stg_args = map StgVarArg args
+ vap_entry_rhs = StgApp (StgVarArg fun) stg_args emptyIdSet
-- Empty live vars
arg_ids_w_info = [(name,mkLFArgument) | name <- args]
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
+ vap_lf_info = mkVapLFInfo payload_ids upd_flag fun stg_args fun_in_payload
-- 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
body_addr = CLbl (entryLabelFromCI closure_info) CodePtrRep
body_code = profCtrC SLIT("ENT_THK") [] `thenC`
- enterCostCentreCode closure_info cc IsThunk `thenC`
- thunkWrapper closure_info (cgSccExpr body)
+ 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 `thenC`
+ cgExpr body)
stdUpd = CLbl mkErrorStdEntryLabel CodePtrRep
\end{code}
= getEntryConvention id lf_info
(map idPrimRep all_args) `thenFC` \ entry_conv ->
let
- do_arity_chks = opt_EmitArityChecks
- 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
ViaNode | is_concurrent -> []
other -> panic "closureCodeBody:arg_regs"
- stk_args = drop (length arg_regs) all_args
+ 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
-- Now adjust real stack pointers
adjustRealSps spA_stk_args spB_stk_args `thenC`
- -- set the arity checker, if asked
- absC (
- if do_arity_chks
- then CMacroStmt SET_ARITY [mkIntCLit stg_arity]
- else AbsCNop
- ) `thenC`
absC (CFallThrough (CLbl fast_label CodePtrRep))
assign_to_reg reg_id amode = CAssign (CReg reg_id) amode
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))
+ 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`
- absC (
- if do_arity_chks
- then CMacroStmt CHK_ARITY [mkIntCLit stg_arity]
- else AbsCNop
- ) `thenC`
-- Bind args to regs/stack as appropriate, and
-- record expected position of sps
- bindArgsToRegs all_args arg_regs `thenC`
+ 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`
CCodeBlock fast_label fast_abs_c
)
where
+ is_concurrent = opt_ForConcurrent
+ stg_arity = length all_args
lf_info = closureLFInfo closure_info
cl_descr mod_name = closureDescription mod_name id all_args body
-- Manufacture labels
id = closureId closure_info
+ fast_label = mkFastEntryLabel id stg_arity
+ stdUpd = CLbl mkErrorStdEntryLabel CodePtrRep
- fast_label = fastLabelFromCI closure_info
-
- stdUpd = CLbl mkErrorStdEntryLabel CodePtrRep
-
+{- OLD... see note at end of file
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
+ = case myWrapperMaybe x of
Nothing -> deflt
Just xx -> get_ultimate_wrapper (Just xx) xx
= case (getWrapperArgTypeCategories (idType xx) (getIdStrictness xx)) of
Nothing -> ""
Just str -> str
+-}
\end{code}
For lexically scoped profiling we have to load the cost centre from
\begin{code}
data IsThunk = IsThunk | IsFunction -- Bool-like, local
+--#ifdef DEBUG
+ deriving Eq
+--#endif
enterCostCentreCode :: ClosureInfo -> CostCentre -> IsThunk -> Code
= costCentresFlag `thenFC` \ profiling_on ->
if not profiling_on then
nopC
- else -- down to business
+ else
ASSERT(not (noCostCentreAttached cc))
if costsAreSubsumed cc then
- nopC
-
- else if is_current_CC cc then -- fish the CC out of the closure,
- -- where we put it when we alloc'd;
- -- NB: chk defn of "is_current_CC"
- -- if you go to change this! (WDP 94/12)
- costCentresC
- (case is_thunk of
- IsThunk -> SLIT("ENTER_CC_TCL")
- IsFunction -> SLIT("ENTER_CC_FCL"))
- [CReg node]
-
- else if isCafCC cc then
- costCentresC
- SLIT("ENTER_CC_CAF")
- [mkCCostCentre cc]
+ --ASSERT(isToplevClosure closure_info)
+ --ASSERT(is_thunk == IsFunction)
+ (if isToplevClosure closure_info && is_thunk == IsFunction then \x->x else pprTrace "enterCostCenterCode:" (ppCat [ppr PprDebug (is_thunk == IsFunction){-, ppr PprDebug closure_info-}, ppStr (showCostCentre PprDebug False cc)])) $
+ costCentresC SLIT("ENTER_CC_FSUB") []
+
+ else if currentOrSubsumedCosts cc then
+ -- i.e. current; subsumed dealt with above
+ -- get CCC out of the closure, where we put it when we alloc'd
+ case is_thunk of
+ IsThunk -> costCentresC SLIT("ENTER_CC_TCL") [CReg node]
+ IsFunction -> costCentresC SLIT("ENTER_CC_FCL") [CReg node]
+
+ else if isCafCC cc && isToplevClosure closure_info then
+ ASSERT(is_thunk == IsThunk)
+ costCentresC SLIT("ENTER_CC_CAF") [mkCCostCentre cc]
else -- we've got a "real" cost centre right here in our hands...
- costCentresC
- (case is_thunk of
- IsThunk -> SLIT("ENTER_CC_T")
- IsFunction -> SLIT("ENTER_CC_F"))
- [mkCCostCentre cc]
- where
- is_current_CC cc
- = currentOrSubsumedCosts cc
- -- but we've already ruled out "subsumed", so it must be "current"!
+ case is_thunk of
+ IsThunk -> costCentresC SLIT("ENTER_CC_T") [mkCCostCentre cc]
+ IsFunction -> if isCafCC cc || isDictCC cc
+ then costCentresC SLIT("ENTER_CC_FCAF") [mkCCostCentre cc]
+ else costCentresC SLIT("ENTER_CC_FLOAD") [mkCCostCentre cc]
\end{code}
%************************************************************************
nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points ->
-#ifdef GRAN
- -- HWL:
+ let
+ emit_gran_macros = opt_GranMacros
+ in
+
+ -- HWL ngo' ngoq:
-- absC (CMacroStmt GRAN_FETCH []) `thenC`
- -- forceHeapCheck [] node_points (absC AbsCNop) `thenC`
- (if node_points
- then fetchAndReschedule [] node_points
- else absC AbsCNop) `thenC`
-#endif {- GRAN -}
+ -- 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`
getCAddrMode (last args) `thenFC` \ last_amode ->
if (isFollowableRep (getAmodeRep last_amode)) then
getSpARelOffset 0 `thenFC` \ (SpARel spA off) ->
let
- lit = mkIntCLit (spARelToInt spA off)
+ a_rel_int = spARelToInt spA off
+ a_rel_arg = mkIntCLit a_rel_int
in
+ ASSERT(a_rel_int /= 0)
if node_points then
- absC (CMacroStmt ARGS_CHK_A [lit])
+ absC (CMacroStmt ARGS_CHK_A [a_rel_arg])
else
- absC (CMacroStmt ARGS_CHK_A_LOAD_NODE [lit, set_Node_to_this])
+ absC (CMacroStmt ARGS_CHK_A_LOAD_NODE [a_rel_arg, set_Node_to_this])
else
getSpBRelOffset 0 `thenFC` \ (SpBRel spB off) ->
let
- lit = mkIntCLit (spBRelToInt spB off)
+ b_rel_int = spBRelToInt spB off
+ b_rel_arg = mkIntCLit b_rel_int
in
+ ASSERT(b_rel_int /= 0)
if node_points then
- absC (CMacroStmt ARGS_CHK_B [lit])
+ absC (CMacroStmt ARGS_CHK_B [b_rel_arg])
else
- absC (CMacroStmt ARGS_CHK_B_LOAD_NODE [lit, set_Node_to_this])
+ absC (CMacroStmt ARGS_CHK_B_LOAD_NODE [b_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
= -- Stack and heap overflow checks
nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points ->
-#ifdef GRAN
- -- HWL insert macros for GrAnSim if node is live here
- (if node_points
- then fetchAndReschedule [] node_points
- else absC AbsCNop) `thenC`
-#endif {- GRAN -}
+ 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`
stackCheck closure_info [] node_points ( -- stackCheck *encloses* the rest
- -- Must be after stackCheck: if stchk fails new stack
- -- space has to be allocated from the heap
+ -- heapCheck must be after stackCheck: if stchk fails
+ -- new stack space is allocated from the heap which
+ -- would violate any previous heapCheck
- heapCheck [] node_points (
- -- heapCheck *encloses* the rest
- -- The "[]" says there are no live argument registers
+ heapCheck [] node_points ( -- heapCheck *encloses* the rest
+ -- The "[]" says there are no live argument registers
-- Overwrite with black hole if necessary
- blackHoleIt closure_info `thenC`
+ blackHoleIt closure_info `thenC`
- -- Push update frame if necessary
- setupUpdate closure_info ( -- setupUpdate *encloses* the rest
- thunk_code
+ setupUpdate closure_info ( -- setupUpdate *encloses* the rest
+
+ -- Finally, do the business
+ thunk_code
)))
funWrapper :: ClosureInfo -- Closure whose code body this is
funWrapper closure_info arg_regs fun_body
= -- Stack overflow check
nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points ->
- stackCheck closure_info arg_regs node_points ( -- stackCheck *encloses* the rest
+ let
+ emit_gran_macros = opt_GranMacros
+ in
+ -- HWL chu' ngoq:
+ (if emit_gran_macros
+ then yield arg_regs node_points
+ else absC AbsCNop) `thenC`
+
+ stackCheck closure_info arg_regs node_points (
+ -- stackCheck *encloses* the rest
- -- Heap overflow check
heapCheck arg_regs node_points (
- -- heapCheck *encloses* the rest
+ -- heapCheck *encloses* the rest
-- Finally, do the business
fun_body
`thenC`
returnFC amode
- closure_label = mkClosureLabel (closureId closure_info)
-
vector
= case (closureType closure_info) of
Nothing -> CReg StdUpdRetVecReg
| just1 == fun
-> mkCCostCentre overheadCostCentre
_ -> 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".
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 (splitFunTyExpandingDicts wrapper_ty) of { (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