X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcodeGen%2FCgClosure.lhs;h=872827fba68917ea9ef08ae2efd58e4c9d527ad7;hb=1fb1ab5d53a09607e7f6d2450806760688396387;hp=54875d7fabc7a87c96f05c04f0b1912e4ae5bb8a;hpb=c49d51f812da9b1c2ceca7e0dad8f2a3626041a9;p=ghc-hetmet.git diff --git a/ghc/compiler/codeGen/CgClosure.lhs b/ghc/compiler/codeGen/CgClosure.lhs index 54875d7..872827f 100644 --- a/ghc/compiler/codeGen/CgClosure.lhs +++ b/ghc/compiler/codeGen/CgClosure.lhs @@ -1,5 +1,5 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 % \section[CgClosure]{Code generation for closures} @@ -12,8 +12,8 @@ with {\em closures} on the RHSs of let(rec)s. See also module CgClosure ( cgTopRhsClosure, cgRhsClosure ) where -import Ubiq{-uitous-} -import CgLoop2 ( cgExpr, cgSccExpr ) +IMP_Ubiq(){-uitous-} +IMPORT_DELOOPER(CgLoop2) ( cgExpr ) import CgMonad import AbsCSyn @@ -24,17 +24,14 @@ import CgBindery ( getCAddrMode, getArgAmodes, 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, @@ -44,17 +41,17 @@ import CgUsages ( getVirtSps, setRealAndVirtualSps, 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, @@ -62,16 +59,16 @@ import Id ( idType, idPrimRep, ) 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} @@ -315,7 +312,8 @@ cgVapInfoTable perhaps_bind_the_fun upd_flag fun args fun_in_payload fun_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 (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] @@ -325,8 +323,7 @@ cgVapInfoTable perhaps_bind_the_fun upd_flag fun args fun_in_payload fun_lf_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 -- local thunk, thus @@ -412,8 +409,12 @@ closureCodeBody binder_info closure_info cc [] body 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} @@ -432,11 +433,6 @@ closureCodeBody binder_info closure_info cc all_args body = 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 @@ -454,7 +450,10 @@ closureCodeBody binder_info closure_info cc all_args body 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 @@ -489,12 +488,6 @@ closureCodeBody binder_info closure_info cc all_args body -- 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 @@ -512,18 +505,17 @@ closureCodeBody binder_info closure_info cc all_args body 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` @@ -551,6 +543,8 @@ closureCodeBody binder_info closure_info cc all_args body 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 @@ -561,15 +555,14 @@ closureCodeBody binder_info closure_info cc 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 @@ -581,6 +574,7 @@ closureCodeBody binder_info closure_info cc all_args body = 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 @@ -592,6 +586,9 @@ Node is guaranteed to point to it, if profiling and not inherited. \begin{code} data IsThunk = IsThunk | IsFunction -- Bool-like, local +--#ifdef DEBUG + deriving Eq +--#endif enterCostCentreCode :: ClosureInfo -> CostCentre -> IsThunk -> Code @@ -599,37 +596,32 @@ enterCostCentreCode closure_info cc is_thunk = 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} %************************************************************************ @@ -659,35 +651,43 @@ argSatisfactionCheck closure_info args 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 @@ -708,28 +708,33 @@ thunkWrapper closure_info thunk_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` + 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 @@ -739,11 +744,19 @@ 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 @@ -857,8 +870,6 @@ setupUpdate closure_info code `thenC` returnFC amode - closure_label = mkClosureLabel (closureId closure_info) - vector = case (closureType closure_info) of Nothing -> CReg StdUpdRetVecReg @@ -926,9 +937,53 @@ chooseDynCostCentres cc args fvs body | 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} +