%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[CgClosure]{Code generation for closures}
@CgCon@, which deals with constructors.
\begin{code}
-#include "HsVersions.h"
-
-module CgClosure (
- cgTopRhsClosure, cgRhsClosure,
+module CgClosure ( cgTopRhsClosure, cgRhsClosure ) where
- -- and to make the interface self-sufficient...
- StgExpr, Id, CgState, Maybe, HeapOffset,
- CgInfoDownwards, CgIdInfo, CompilationInfo,
- UpdateFlag
- ) where
+#include "HsVersions.h"
-IMPORT_Trace -- ToDo: rm (debugging)
-import Outputable
-import Pretty -- NB: see below
+import {-# SOURCE #-} CgExpr ( cgExpr )
-import StgSyn
import CgMonad
import AbsCSyn
+import StgSyn
-import AbsPrel ( PrimOp(..), primOpNameInfo, Name
- IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
- IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
+import AbsCUtils ( mkAbstractCs, getAmodeRep )
+import CgBindery ( getCAddrMode, getArgAmodes,
+ getCAddrModeAndInfo, bindNewToNode,
+ bindNewToAStack, bindNewToBStack,
+ bindNewToReg, bindArgsToRegs,
+ stableAmodeIdInfo, heapIdInfo, CgIdInfo
)
-import AbsUniType ( isPrimType, isPrimTyCon,
- getTauType, showTypeCategory, getTyConDataCons
- IF_ATTACK_PRAGMAS(COMMA splitType)
- IF_ATTACK_PRAGMAS(COMMA splitTyArgs)
- )
-import CgBindery ( getCAddrMode, getAtomAmodes,
- getCAddrModeAndInfo,
- bindNewToNode, bindNewToAStack, bindNewToBStack,
- bindNewToReg, bindArgsToRegs
- )
-import CgCompInfo ( spARelToInt, spBRelToInt )
-import CgExpr ( cgExpr, cgSccExpr )
+import Constants ( spARelToInt, spBRelToInt )
import CgUpdate ( pushUpdateFrame )
import CgHeapery ( allocDynClosure, heapCheck
-#ifdef GRAN
- , heapCheckOnly, fetchAndReschedule -- HWL
-#endif {- GRAN -}
- )
-import CgRetConv ( ctrlReturnConvAlg, dataReturnConvAlg, mkLiveRegsBitMask,
+ , heapCheckOnly, fetchAndReschedule, yield -- HWL
+ )
+import CgRetConv ( ctrlReturnConvAlg, dataReturnConvAlg,
CtrlReturnConvention(..), DataReturnConvention(..)
)
import CgStackery ( getFinalStackHW, mkVirtStkOffsets,
getSpARelOffset, getSpBRelOffset,
getHpRelOffset
)
-import CLabelInfo
+import CLabel ( mkClosureLabel, mkConUpdCodePtrVecLabel, mkFastEntryLabel,
+ mkStdUpdCodePtrVecLabel, mkStdUpdVecTblLabel,
+ mkErrorStdEntryLabel, mkRednCountsLabel
+ )
import ClosureInfo -- lots and lots of stuff
-import CmdLineOpts ( GlobalSwitch(..) )
-import CostCentre
-import Id ( getIdUniType, getIdKind, isSysLocalId, myWrapperMaybe,
- showId, getIdInfo, getIdStrictness,
- getDataConTag
+import CmdLineOpts ( opt_ForConcurrent, opt_GranMacros )
+import CostCentre ( useCurrentCostCentre, currentOrSubsumedCosts,
+ noCostCentreAttached, costsAreSubsumed,
+ isCafCC, isDictCC, overheadCostCentre, showCostCentre,
+ CostCentre
+ )
+import HeapOffs ( VirtualHeapOffset )
+import Id ( idType, idPrimRep,
+ showId, getIdStrictness, dataConTag,
+ emptyIdSet,
+ Id
)
-import IdInfo
import ListSetOps ( minusList )
-import Maybes ( Maybe(..), maybeToBool )
-import PrimKind ( isFollowableKind )
-import UniqSet
-import Unpretty
-import Util
+import Maybes ( maybeToBool )
+import PrimRep ( isFollowableRep, PrimRep(..) )
+import TyCon ( isPrimTyCon, tyConDataCons )
+import Type ( showTypeCategory )
+import Util ( isIn )
+import Outputable
+
+getWrapperArgTypeCategories = panic "CgClosure.getWrapperArgTypeCategories (ToDo)"
\end{code}
%********************************************************
-> CostCentre -- Optional cost centre annotation
-> StgBinderInfo
-> [Id] -- Args
- -> PlainStgExpr
+ -> StgExpr
-> LambdaFormInfo
-> FCode (Id, CgIdInfo)
-\end{code}
-\begin{code}
-{- NOT USED:
-cgTopRhsClosure name cc binder_info args body lf_info
- | maybeToBool maybe_std_thunk -- AHA! A STANDARD-FORM THUNK
- = (
- -- LAY OUT THE OBJECT
- getAtomAmodes std_thunk_payload `thenFC` \ amodes ->
- let
- (closure_info, amodes_w_offsets) = layOutStaticClosure name getAmodeKind amodes lf_info
- in
-
- -- BUILD THE OBJECT
- chooseStaticCostCentre cc lf_info `thenFC` \ cost_centre ->
- absC (CStaticClosure
- closure_label -- Labelled with the name on lhs of defn
- closure_info
- cost_centre
- (map fst amodes_w_offsets)) -- They are in the correct order
- ) `thenC`
-
- returnFC (name, stableAmodeIdInfo name (CLbl closure_label PtrKind) lf_info)
- where
- maybe_std_thunk = getStandardFormThunkInfo lf_info
- Just std_thunk_payload = maybe_std_thunk
-
- closure_label = mkClosureLabel name
--}
-\end{code}
-
-The general case:
-\begin{code}
cgTopRhsClosure name cc binder_info args body lf_info
= -- LAY OUT THE OBJECT
let
closure_info = layOutStaticNoFVClosure name lf_info
in
-
+
-- GENERATE THE INFO TABLE (IF NECESSARY)
- forkClosureBody (closureCodeBody binder_info closure_info
+ forkClosureBody (closureCodeBody binder_info closure_info
cc args body)
`thenC`
-- Don't build Vap info tables etc for
-- a function whose result is an unboxed type,
-- because we can never have thunks with such a type.
- (if closureReturnsUnboxedType closure_info then
+ (if closureReturnsUnpointedType closure_info then
nopC
else
let
bind_the_fun = addBindC name cg_id_info -- It's global!
- in
+ in
cgVapInfoTables True {- Top level -} bind_the_fun binder_info name args lf_info
) `thenC`
let
cost_centre = mkCCostCentre cc
in
- absC (CStaticClosure
+ absC (CStaticClosure
closure_label -- Labelled with the name on lhs of defn
closure_info
- cost_centre
+ cost_centre
[]) -- No fields
else
nopC
returnFC (name, cg_id_info)
where
closure_label = mkClosureLabel name
- cg_id_info = stableAmodeIdInfo name (CLbl closure_label PtrKind) lf_info
+ cg_id_info = stableAmodeIdInfo name (CLbl closure_label PtrRep) lf_info
\end{code}
%********************************************************
-- Closures which (a) have no fvs and (b) have some args (i.e.
-- combinator functions), are allocated statically, just as if they
-- were top-level closures. We can't get a space leak that way
--- (because they are HNFs) and it saves allocation.
+-- (because they are HNFs) and it saves allocation.
-- Lexical Scoping: Problem
-- These top level function closures will be inherited, possibly
-> StgBinderInfo
-> [Id] -- Free vars
-> [Id] -- Args
- -> PlainStgExpr
+ -> StgExpr
-> LambdaFormInfo
-> FCode (Id, CgIdInfo)
-- ToDo: check non-primitiveness (ASSERT)
= (
-- LAY OUT THE OBJECT
- getAtomAmodes std_thunk_payload `thenFC` \ amodes ->
+ getArgAmodes std_thunk_payload `thenFC` \ amodes ->
let
(closure_info, amodes_w_offsets)
- = layOutDynClosure binder getAmodeKind amodes lf_info
+ = layOutDynClosure binder getAmodeRep amodes lf_info
(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 ->
-- RETURN
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
+ 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
amodes_w_offsets = [(amode,offset) | ((_, (amode,_)), offset) <- bind_details]
- get_kind (id, amode_and_info) = getIdKind id
+ get_kind (id, amode_and_info) = idPrimRep id
in
-- BUILD ITS INFO TABLE AND CODE
forkClosureBody (
-- Don't build Vap info tables etc for
-- a function whose result is an unboxed type,
-- because we can never have thunks with such a type.
- (if closureReturnsUnboxedType closure_info then
+ (if closureReturnsUnpointedType closure_info then
nopC
else
cgVapInfoTables False {- Not top level -} nopC binder_info binder args lf_info
--
-- 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 (StgVarAtom fun) (map StgVarAtom args) emptyUniqSet
+ --
+ 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_w_info | fun_in_payload = (fun,fun_lf_info) : arg_ids_w_info
- | otherwise = arg_ids_w_info
+ | otherwise = arg_ids_w_info
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
+ -- function, because any VAP *use* of this function will be for a
-- local thunk, thus
-- let x = f p q -- x isn't top level!
-- in ...
- get_kind (id, info) = getIdKind id
+ get_kind (id, info) = idPrimRep id
payload_bind_details :: [((Id, LambdaFormInfo), VirtualHeapOffset)]
- (closure_info, payload_bind_details) = layOutDynClosure
- fun
- get_kind payload_ids_w_info
+ (closure_info, payload_bind_details) = layOutDynClosure
+ fun
+ get_kind payload_ids_w_info
vap_lf_info
- -- The dodgy thing is that we use the "fun" as the
+ -- The dodgy thing is that we use the "fun" as the
-- Id to give to layOutDynClosure. This Id gets embedded in
-- the closure_info it returns. But of course, the function doesn't
-- have the right type to match the Vap closure. Never mind,
-> ClosureInfo -- Lots of information about this closure
-> CostCentre -- Optional cost centre attached to closure
-> [Id]
- -> PlainStgExpr
+ -> StgExpr
-> Code
\end{code}
Just (tc,_,_) -> (True, tc)
in
if has_tycon && isPrimTyCon tycon then
- pprPanic "closureCodeBody:thunk:prim type!" (ppr PprDebug tycon)
+ pprPanic "closureCodeBody:thunk:prim type!" (ppr tycon)
else
#endif
getAbsC body_code `thenFC` \ body_absC ->
moduleName `thenFC` \ mod_name ->
- getIntSwitchChkrC `thenFC` \ isw_chkr ->
absC (CClosureInfoAndCode closure_info body_absC Nothing
stdUpd (cl_descr mod_name)
- (dataConLiveness isw_chkr closure_info))
+ (dataConLiveness closure_info))
where
cl_descr mod_name = closureDescription mod_name (closureId closure_info) [] body
- body_addr = CLbl (entryLabelFromCI closure_info) CodePtrKind
+ 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)
-
- stdUpd = CLbl mkErrorStdEntryLabel CodePtrKind
+ 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}
If there is {\em at least one argument}, then this closure is in
\begin{code}
closureCodeBody binder_info closure_info cc all_args body
= getEntryConvention id lf_info
- (map getIdKind all_args) `thenFC` \ entry_conv ->
-
- isSwitchSetC EmitArityChecks `thenFC` \ do_arity_chks ->
-
- isSwitchSetC ForConcurrent `thenFC` \ is_concurrent ->
-
- isStringSwitchSetC AsmTarget `thenFC` \ native_code ->
-
+ (map idPrimRep all_args) `thenFC` \ entry_conv ->
let
- stg_arity = length all_args
+ -- Figure out what is needed and what isn't
+ slow_code_needed = slowFunEntryCodeRequired id binder_info entry_conv
+ info_table_needed = funInfoTableRequired id binder_info lf_info
-- 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
+ = mkVirtStkOffsets
0 0 -- Initial virtual SpA, SpB
- getIdKind
+ idPrimRep
all_args
- -- Arg mapping for the fast entry point; as many args as poss in
+ -- 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
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
+ = mkVirtStkOffsets
0 0 -- Initial virtual SpA, SpB
- getIdKind
+ 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 PtrKind 1
+ -- where node = UnusedReg 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`
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
+ -- 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`
- -- set the arity checker, if asked
- absC (
- if do_arity_chks
- then CMacroStmt SET_ARITY [mkIntCLit stg_arity]
- else AbsCNop
- ) `thenC`
-
-#ifndef DPH
- absC (CFallThrough (CLbl fast_label CodePtrKind))
-#else
- -- Fall through to the fast entry point
- absC (AbsCNop)
-#endif {- Data Parallel Haskell -}
+ absC (CFallThrough (CLbl fast_label CodePtrRep))
assign_to_reg reg_id amode = CAssign (CReg reg_id) amode
-- see argSatisfactionCheck for new version
-- fast_entry_code = forceHeapCheck [] True fast_entry_code'
- fast_entry_code
- = profCtrC SLIT("ENT_FUN_DIRECT") [
- CLbl (mkRednCountsLabel id) PtrKind,
- CString (_PK_ (showId PprDebug id)),
+ fast_entry_code
+ = profCtrC SLIT("ENT_FUN_DIRECT") [
+ CLbl (mkRednCountsLabel id) PtrRep,
+ CString (_PK_ (showId 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 . getIdUniType) all_args)),
- CString (_PK_ (show_wrapper_name wrapper_maybe)),
- CString (_PK_ (show_wrapper_arg_kinds wrapper_maybe))
+ 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`
- 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`
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)
+ 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 ->
- getIntSwitchChkrC `thenFC` \ isw_chkr ->
-
+
-- 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)
+ CClosureInfoAndCode closure_info slow_abs_c (Just fast_abs_c)
stdUpd (cl_descr mod_name)
- (dataConLiveness isw_chkr closure_info)
- else
+ (dataConLiveness closure_info)
+ else
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
- -- 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 CodePtrKind
+ fast_label = mkFastEntryLabel id stg_arity
+ 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
show_wrapper_name Nothing = ""
- show_wrapper_name (Just xx) = showId PprDebug xx
+ show_wrapper_name (Just xx) = showId xx
show_wrapper_arg_kinds Nothing = ""
show_wrapper_arg_kinds (Just xx)
- = case (getWrapperArgTypeCategories (getIdUniType xx) (getIdStrictness xx)) of
+ = 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:" (hsep [ppr (is_thunk == IsFunction){-, ppr closure_info-}, text (showCostCentre 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}
%************************************************************************
argSatisfactionCheck closure_info args
= -- safest way to determine which stack last arg will be on:
-- look up CAddrMode that last arg is bound to;
- -- getAmodeKind;
- -- check isFollowableKind.
+ -- getAmodeRep;
+ -- check isFollowableRep.
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 (isFollowableKind (getAmodeKind last_amode)) then
- getSpARelOffset 0 `thenFC` \ a_rel_offset ->
+ if (isFollowableRep (getAmodeRep last_amode)) then
+ getSpARelOffset 0 `thenFC` \ (SpARel spA off) ->
+ let
+ 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 [mkIntCLit (spARelToInt a_rel_offset)])
+ absC (CMacroStmt ARGS_CHK_A [a_rel_arg])
else
- absC (CMacroStmt ARGS_CHK_A_LOAD_NODE
- [mkIntCLit (spARelToInt a_rel_offset), set_Node_to_this])
+ absC (CMacroStmt ARGS_CHK_A_LOAD_NODE [a_rel_arg, set_Node_to_this])
else
- getSpBRelOffset 0 `thenFC` \ b_rel_offset ->
+ getSpBRelOffset 0 `thenFC` \ (SpBRel spB off) ->
+ let
+ 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 [mkIntCLit (spBRelToInt b_rel_offset)])
+ absC (CMacroStmt ARGS_CHK_B [b_rel_arg])
else
- absC (CMacroStmt ARGS_CHK_B_LOAD_NODE
- [mkIntCLit (spBRelToInt b_rel_offset), 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
-- the macro the (static) address of the closure.
- set_Node_to_this = CLbl (closureLabelFromCI closure_info) PtrKind
+ set_Node_to_this = CLbl (closureLabelFromCI closure_info) PtrRep
\end{code}
%************************************************************************
= -- 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`
-
- -- Push update frame if necessary
- setupUpdate closure_info ( -- setupUpdate *encloses* the rest
+ blackHoleIt closure_info `thenC`
- -- Evaluation scoping -- load current cost centre from closure
- -- Must be done after the update frame is pushed
- -- Node is guaranteed to point to it, if profiling
--- OLD:
--- (if isStaticClosure closure_info
--- then evalCostCentreC "SET_CAFCC_CL" [CReg node]
--- else evalCostCentreC "ENTER_CC_TCL" [CReg node]) `thenC`
+ setupUpdate closure_info ( -- setupUpdate *encloses* the rest
-- Finally, do the business
thunk_code
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
Assumption: virtual and real stack pointers are currently exactly aligned.
\begin{code}
-stackCheck :: ClosureInfo
+stackCheck :: ClosureInfo
-> [MagicId] -- Live registers
-> Bool -- Node required to point after check?
- -> Code
+ -> Code
-> Code
stackCheck closure_info regs node_reqd code
= getFinalStackHW (\ aHw -> \ bHw -> -- Both virtual stack offsets
-
+
getVirtSps `thenFC` \ (vSpA, vSpB) ->
let a_headroom_reqd = aHw - vSpA -- Virtual offsets are positive integers
CMacroStmt STK_CHK [mkIntCLit liveness_mask,
mkIntCLit a_headroom_reqd,
mkIntCLit b_headroom_reqd,
- mkIntCLit vSpA,
+ mkIntCLit vSpA,
mkIntCLit vSpB,
mkIntCLit (if returns_prim_type then 1 else 0),
mkIntCLit (if node_reqd then 1 else 0)]
)
where
all_regs = if node_reqd then node:regs else regs
- liveness_mask = mkLiveRegsBitMask all_regs
+ liveness_mask = mkLiveRegsMask all_regs
- returns_prim_type = closureReturnsUnboxedType closure_info
+ returns_prim_type = closureReturnsUnpointedType closure_info
\end{code}
%************************************************************************
setupUpdate closure_info code
= if (closureUpdReqd closure_info) then
link_caf_if_needed `thenFC` \ update_closure ->
- getIntSwitchChkrC `thenFC` \ isw_chkr ->
- pushUpdateFrame update_closure (vector isw_chkr) code
+ pushUpdateFrame update_closure vector code
else
- -- Non-updatable thunks still need a resume-cost-centre "update"
- -- frame to be pushed if we are doing evaluation profiling.
-
---OLD: evalPushRCCFrame False {-never primitive-} (
- profCtrC SLIT("UPDF_OMITTED") []
- `thenC`
+ profCtrC SLIT("UPDF_OMITTED") [] `thenC`
code
--- )
where
link_caf_if_needed :: FCode CAddrMode -- Returns amode for closure to be updated
link_caf_if_needed
-- Alloc black hole specifying CC_HDR(Node) as the cost centre
-- Hack Warning: Using a CLitLit to get CAddrMode !
let
- use_cc = CLitLit SLIT("CC_HDR(R1.p)") PtrKind
+ use_cc = CLitLit SLIT("CC_HDR(R1.p)") PtrRep
blame_cc = use_cc
in
allocDynClosure (blackHoleClosureInfo closure_info) use_cc blame_cc []
`thenFC` \ heap_offset ->
- getHpRelOffset heap_offset `thenFC` \ hp_rel ->
+ getHpRelOffset heap_offset `thenFC` \ hp_rel ->
let amode = CAddr hp_rel
in
absC (CMacroStmt UPD_CAF [CReg node, amode])
`thenC`
returnFC amode
- closure_label = mkClosureLabel (closureId closure_info)
-
- vector isw_chkr
+ vector
= case (closureType closure_info) of
Nothing -> CReg StdUpdRetVecReg
Just (spec_tycon, _, spec_datacons) ->
case (ctrlReturnConvAlg spec_tycon) of
- UnvectoredReturn 1 ->
+ UnvectoredReturn 1 ->
let
spec_data_con = head spec_datacons
- only_tag = getDataConTag spec_data_con
+ only_tag = dataConTag spec_data_con
- direct = case (dataReturnConvAlg isw_chkr spec_data_con) of
+ direct = case (dataReturnConvAlg spec_data_con) of
ReturnInRegs _ -> mkConUpdCodePtrVecLabel spec_tycon only_tag
ReturnInHeap -> mkStdUpdCodePtrVecLabel spec_tycon only_tag
CUnVecLbl direct vectored
UnvectoredReturn _ -> CReg StdUpdRetVecReg
- VectoredReturn _ -> CLbl (mkStdUpdVecTblLabel spec_tycon) DataPtrKind
+ VectoredReturn _ -> CLbl (mkStdUpdVecTblLabel spec_tycon) DataPtrRep
\end{code}
%************************************************************************
closureDescription :: FAST_STRING -- Module
-> Id -- Id of closure binding
-> [Id] -- Args
- -> PlainStgExpr -- Body
+ -> StgExpr -- Body
-> 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 args body =
- uppShow 0 (prettyToUn (
- ppBesides [ppChar '<',
- ppPStr mod_name,
- ppChar '.',
- ppr PprDebug name,
- ppChar '>']))
+closureDescription mod_name name args body
+ = showSDoc (
+ hcat [char '<',
+ ptext mod_name,
+ char '.',
+ ppr name,
+ char '>'])
\end{code}
\begin{code}
blame_cc -- cost-centre on whom we blame the allocation
= case (args, fvs, body) of
- ([], [just1], StgApp (StgVarAtom fun) [{-no args-}] _)
- | just1 == fun
- -> mkCCostCentre overheadCostCentre
+ ([], [just1], StgApp (StgVarArg fun) [{-no args-}] _)
+ | 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 (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