X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcodeGen%2FCgClosure.lhs;h=32f442e4d5c7e0b6d1efeee29d51ec65b919e28d;hb=6e4feb0ecf12e7890f5298ca55f715eed3411095;hp=1b80beaf4090ae2e5de8cecb39e3ad7ca5acffb1;hpb=1b28d4e1f43185ad8c8e7407c66413e1b358402b;p=ghc-hetmet.git diff --git a/ghc/compiler/codeGen/CgClosure.lhs b/ghc/compiler/codeGen/CgClosure.lhs index 1b80bea..32f442e 100644 --- a/ghc/compiler/codeGen/CgClosure.lhs +++ b/ghc/compiler/codeGen/CgClosure.lhs @@ -1,7 +1,7 @@ % % (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} @@ -40,8 +40,7 @@ import CgUsages ( adjustSpAndHp, setRealAndVirtualSp, getVirtSp, 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 ) @@ -58,8 +57,7 @@ import Outputable import Name ( nameOccName ) import OccName ( occNameFS ) - -getWrapperArgTypeCategories = panic "CgClosure.getWrapperArgTypeCategories (ToDo)" +import FastTypes ( iBox ) \end{code} %******************************************************** @@ -81,9 +79,13 @@ cgTopRhsClosure :: Id -> 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) @@ -115,10 +117,7 @@ cgTopRhsClosure id ccs binder_info args body lf_info ) `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} %******************************************************** @@ -159,9 +158,6 @@ cgStdRhsClosure binder cc binder_info fvs args body lf_info payload -- RETURN returnFC (binder, heapIdInfo binder heap_offset lf_info) - - where - is_std_thunk = isStandardFormThunk lf_info \end{code} Here's the general case. @@ -195,21 +191,19 @@ cgRhsClosure binder cc binder_info fvs args body lf_info 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 ( @@ -312,7 +306,7 @@ closureCodeBody binder_info closure_info cc all_args body -- 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 @@ -326,12 +320,7 @@ closureCodeBody binder_info closure_info cc all_args body -- 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 @@ -421,7 +410,7 @@ closureCodeBody binder_info closure_info cc all_args body 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) @@ -543,7 +532,7 @@ argSatisfactionCheck closure_info arg_regs getSpRelOffset 0 `thenFC` \ (SpRel sp) -> let - off = I# sp + off = iBox sp rel_arg = mkIntCLit off in ASSERT(off /= 0) @@ -682,9 +671,8 @@ setupUpdate closure_info code -- 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 -> @@ -749,43 +737,3 @@ chooseDynCostCentres ccs args fvs body -======================================================================== -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} -