%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgClosure.lhs,v 1.39 2000/01/13 14:33:58 hwloidl Exp $
+% $Id: CgClosure.lhs,v 1.47 2001/08/21 10:00:22 simonpj Exp $
%
\section[CgClosure]{Code generation for closures}
getSpRelOffset, getHpRelOffset
)
import CLabel ( CLabel, mkClosureLabel, mkFastEntryLabel,
- mkRednCountsLabel, mkInfoTableLabel,
- pprCLabel
+ mkRednCountsLabel, mkInfoTableLabel
)
import ClosureInfo -- lots and lots of stuff
import CmdLineOpts ( opt_GranMacros, opt_SccProfilingOn, opt_DoTickyProfiling )
import Name ( nameOccName )
import OccName ( occNameFS )
-
-getWrapperArgTypeCategories = panic "CgClosure.getWrapperArgTypeCategories (ToDo)"
+import FastTypes ( iBox )
\end{code}
%********************************************************
-> FCode (Id, CgIdInfo)
cgTopRhsClosure id ccs binder_info args body lf_info
- = -- LAY OUT THE OBJECT
+ =
+ -- LAY OUT THE OBJECT
let
- closure_info = layOutStaticNoFVClosure name lf_info
+ name = idName id
+ closure_info = layOutStaticNoFVClosure name lf_info
+ closure_label = mkClosureLabel name
+ cg_id_info = stableAmodeIdInfo id (CLbl closure_label PtrRep) lf_info
in
-- BUILD THE OBJECT (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}
%********************************************************
-- RETURN
returnFC (binder, heapIdInfo binder heap_offset lf_info)
-
- where
- is_std_thunk = isStandardFormThunk lf_info
\end{code}
Here's the general case.
then fvs `minusList` [binder]
else fvs
in
- mapFCs getCAddrModeAndInfo reduced_fvs `thenFC` \ amodes_and_info ->
+ mapFCs getCAddrModeAndInfo reduced_fvs `thenFC` \ fvs_w_amodes_and_info ->
let
- fvs_w_amodes_and_info = reduced_fvs `zip` amodes_and_info
-
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
- 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 (
-- Arg mapping for standard (slow) entry point; all args on stack,
-- with tagging.
- (sp_all_args, arg_offsets, arg_tags)
+ (sp_all_args, arg_offsets, _)
= mkTaggedVirtStkOffsets vSp idPrimRep all_args
-- Arg mapping for the fast entry point; as many args as poss in
--
arg_regs = case entry_conv of
DirectEntry lbl arity regs -> regs
- other -> trace ("*** closureCodeBody:arg_regs " ++ (pprHWL entry_conv) ++ "(HWL ignored; no args passed in regs)") []
-
- pprHWL :: EntryConvention -> String
- pprHWL (ViaNode) = "ViaNode"
- pprHWL (StdEntry cl) = "StdEntry"
- pprHWL (DirectEntry cl i l) = "DirectEntry"
+ other -> [] -- "(HWL ignored; no args passed in regs)"
num_arg_regs = length arg_regs
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 ->
+ 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)
getSpRelOffset 0 `thenFC` \ (SpRel sp) ->
let
- off = I# sp
+ off = iBox sp
rel_arg = mkIntCLit off
in
ASSERT(off /= 0)
-- 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 ->
-========================================================================
-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}
-