X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcodeGen%2FCgClosure.lhs;h=8aca152e894eb9d455202c5cb6460e9811657273;hb=ffa647ba054966f3d8dea4032ff225097fe5b3e6;hp=26c7e51e442eab287f9e35be25f37c86957da036;hpb=4e7d56fde0f44d38bbb9a6fc72cf9c603264899d;p=ghc-hetmet.git diff --git a/ghc/compiler/codeGen/CgClosure.lhs b/ghc/compiler/codeGen/CgClosure.lhs index 26c7e51..8aca152 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.34 1999/07/14 14:40:28 simonpj Exp $ +% $Id: CgClosure.lhs,v 1.52 2001/11/06 11:02:05 simonmar Exp $ % \section[CgClosure]{Code generation for closures} @@ -46,19 +46,18 @@ import ClosureInfo -- lots and lots of stuff import CmdLineOpts ( opt_GranMacros, opt_SccProfilingOn, opt_DoTickyProfiling ) import CostCentre import Id ( Id, idName, idType, idPrimRep ) -import Name ( Name ) +import Name ( Name, isLocalName ) import Module ( Module, pprModule ) import ListSetOps ( minusList ) import PrimRep ( PrimRep(..) ) import PprType ( showTypeCategory ) -import Util ( isIn ) +import Util ( isIn, splitAtList ) import CmdLineOpts ( opt_SccProfilingOn ) import Outputable import Name ( nameOccName ) import OccName ( occNameFS ) - -getWrapperArgTypeCategories = panic "CgClosure.getWrapperArgTypeCategories (ToDo)" +import FastTypes ( iBox ) \end{code} %******************************************************** @@ -74,15 +73,21 @@ They should have no free variables. 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 + = + -- LAY OUT THE OBJECT + getSRTInfo srt `thenFC` \ srt_info -> let - closure_info = layOutStaticNoFVClosure name lf_info + name = idName id + closure_info = layOutStaticNoFVClosure name lf_info srt_info + closure_label = mkClosureLabel name + cg_id_info = stableAmodeIdInfo id (CLbl closure_label PtrRep) lf_info in -- BUILD THE OBJECT (IF NECESSARY) @@ -114,10 +119,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} %******************************************************** @@ -147,7 +149,8 @@ cgStdRhsClosure binder cc binder_info fvs args body lf_info payload getArgAmodes payload `thenFC` \ amodes -> let (closure_info, amodes_w_offsets) - = layOutDynClosure (idName binder) getAmodeRep amodes lf_info + = layOutDynClosure (idName binder) getAmodeRep amodes lf_info NoC_SRT + -- No SRT for a standard-form closure (use_cc, blame_cc) = chooseDynCostCentres cc args fvs body in @@ -158,9 +161,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. @@ -169,13 +169,14 @@ 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 -- @@ -194,21 +195,21 @@ 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 -> + getSRTInfo srt `thenFC` \ srt_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 + = layOutDynClosure (idName binder) get_kind + fvs_w_amodes_and_info lf_info srt_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 ( @@ -269,6 +270,7 @@ closureCodeBody binder_info closure_info cc [] body 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` @@ -297,6 +299,7 @@ closureCodeBody binder_info closure_info cc all_args body -- get the current virtual Sp (it might not be zero, eg. if we're -- compiling a let-no-escape). getVirtSp `thenFC` \vSp -> + let -- Figure out what is needed and what isn't @@ -309,7 +312,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 @@ -323,11 +326,9 @@ closureCodeBody binder_info closure_info cc all_args body -- arg_regs = case entry_conv of DirectEntry lbl arity regs -> regs - other -> panic "closureCodeBody:arg_regs" + other -> [] -- "(HWL ignored; no args passed in regs)" - num_arg_regs = length arg_regs - - (reg_args, stk_args) = splitAt num_arg_regs all_args + (reg_args, stk_args) = splitAtList arg_regs all_args (sp_stk_args, stk_offsets, stk_tags) = mkTaggedVirtStkOffsets vSp idPrimRep stk_args @@ -340,13 +341,15 @@ closureCodeBody binder_info closure_info cc all_args body --slow_entry_code = forceHeapCheck [] True slow_entry_code' slow_entry_code - = profCtrC SLIT("TICK_ENT_FUN_STD") [] `thenC` + = 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` + argSatisfactionCheck closure_info arg_regs `thenC` -- OK, so there are enough args. Now we need to stuff as -- many of them in registers as the fast-entry code @@ -370,14 +373,19 @@ closureCodeBody binder_info closure_info cc all_args body -- see argSatisfactionCheck for new version -- fast_entry_code = forceHeapCheck [] True fast_entry_code' - fast_entry_code - = profCtrC SLIT("TICK_ENT_FUN_DIRECT") [ - CLbl (mkRednCountsLabel name) PtrRep, - mkCString (_PK_ (showSDoc (ppr name))), - mkIntCLit stg_arity, -- total # of args - mkIntCLit sp_stk_args, -- # passed on stk - mkCString (_PK_ (map (showTypeCategory . idType) all_args)) - ] `thenC` + fast_entry_code = do + mod_name <- moduleName + 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)) + ] + let prof = + profCtrC SLIT("TICK_ENT_FUN_DIRECT") [ + CLbl ticky_ctr_label DataPtrRep + ] -- Nuked for now; see comment at end of file -- CString (_PK_ (show_wrapper_name wrapper_maybe)), @@ -386,37 +394,44 @@ closureCodeBody binder_info closure_info cc all_args body -- 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` + bindArgsToRegs reg_args arg_regs + mapCs bindNewToStack stk_offsets + setRealAndVirtualSp sp_stk_args -- free up the stack slots containing tags - freeStackSlots (map fst stk_tags) `thenC` + freeStackSlots (map fst stk_tags) -- 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 stk_tags info_label + (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) + 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 -> + 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) + absC ( + if info_table_needed then + CClosureInfoAndCode closure_info slow_abs_c (Just fast_abs_c) (cl_descr mod_name) - else + else CCodeBlock fast_label fast_abs_c + ) ) where + ticky_ctr_label = mkRednCountsLabel name + stg_arity = length all_args lf_info = closureLFInfo closure_info @@ -426,6 +441,14 @@ closureCodeBody binder_info closure_info cc all_args body 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))) + | otherwise = showSDocDebug (ppr name) \end{code} For lexically scoped profiling we have to load the cost centre from @@ -451,7 +474,7 @@ enterCostCentreCode closure_info ccs is_thunk is_box = 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) @@ -493,28 +516,28 @@ relative offset of this word tells how many words of arguments are expected. \begin{code} -argSatisfactionCheck :: ClosureInfo -> Code +argSatisfactionCheck :: ClosureInfo -> [MagicId] {-GRAN-} -> Code -argSatisfactionCheck closure_info +argSatisfactionCheck closure_info arg_regs = nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points -> - let - emit_gran_macros = opt_GranMacros - in +-- 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` + --(if opt_GranMacros + -- then if node_points + -- then fetchAndReschedule arg_regs node_points + -- else yield arg_regs node_points + -- else absC AbsCNop) `thenC` getSpRelOffset 0 `thenFC` \ (SpRel sp) -> let - off = I# sp + off = iBox sp rel_arg = mkIntCLit off in ASSERT(off /= 0) @@ -542,22 +565,19 @@ thunkWrapper closure_info lbl thunk_code = -- Stack and heap overflow checks nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points -> - 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` + -- 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` -- stack and/or heap checks thunkChecks lbl node_points ( -- Overwrite with black hole if necessary - blackHoleIt closure_info node_points `thenC` + blackHoleIt closure_info node_points `thenC` setupUpdate closure_info ( -- setupUpdate *encloses* the rest @@ -574,13 +594,10 @@ funWrapper :: ClosureInfo -- Closure whose code body this is funWrapper closure_info arg_regs stk_tags info_label fun_body = -- Stack overflow check nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points -> - let - emit_gran_macros = opt_GranMacros - in -- HWL chu' ngoq: - (if emit_gran_macros - then yield arg_regs node_points - else absC AbsCNop) `thenC` + (if opt_GranMacros + then yield arg_regs node_points + else absC AbsCNop) `thenC` -- heap and/or stack checks fastEntryChecks arg_regs stk_tags info_label node_points ( @@ -604,10 +621,14 @@ blackHoleIt :: ClosureInfo -> Bool -> Code -- Only called for closures with no a blackHoleIt closure_info node_points = if blackHoleOnEntry closure_info && node_points then + let + info_label = infoTableLabelFromCI closure_info + args = [ CLbl info_label DataPtrRep ] + in absC (if closureSingleEntry(closure_info) then - CMacroStmt UPD_BH_SINGLE_ENTRY [CReg node] + CMacroStmt UPD_BH_SINGLE_ENTRY args else - CMacroStmt UPD_BH_UPDATABLE [CReg node]) + CMacroStmt UPD_BH_UPDATABLE args) else nopC \end{code} @@ -655,9 +676,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 -> @@ -719,46 +739,3 @@ chooseDynCostCentres ccs args fvs body 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} -