X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcodeGen%2FCgClosure.lhs;h=8e32a8a8bc2a7830b6cd0db511126781445f9f09;hb=83f1f583f402f0b7a30b7096612b4bd2f25f1faa;hp=673dd7ab76f0af5eae932ce890c5ac63cd7d745a;hpb=fda89b29c748c6cd2fe1fdb477d5c0e8f7d32b90;p=ghc-hetmet.git diff --git a/ghc/compiler/codeGen/CgClosure.lhs b/ghc/compiler/codeGen/CgClosure.lhs index 673dd7a..8e32a8a 100644 --- a/ghc/compiler/codeGen/CgClosure.lhs +++ b/ghc/compiler/codeGen/CgClosure.lhs @@ -8,20 +8,16 @@ with {\em closures} on the RHSs of let(rec)s. See also @CgCon@, which deals with constructors. \begin{code} -#include "HsVersions.h" - module CgClosure ( cgTopRhsClosure, cgRhsClosure ) where -IMP_Ubiq(){-uitous-} -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201 -IMPORT_DELOOPER(CgLoop2) ( cgExpr ) -#else +#include "HsVersions.h" + import {-# SOURCE #-} CgExpr ( cgExpr ) -#endif import CgMonad import AbsCSyn import StgSyn +import BasicTypes ( TopLevelFlag(..) ) import AbsCUtils ( mkAbstractCs, getAmodeRep ) import CgBindery ( getCAddrMode, getArgAmodes, @@ -56,21 +52,19 @@ import CostCentre ( useCurrentCostCentre, currentOrSubsumedCosts, isCafCC, isDictCC, overheadCostCentre, showCostCentre, CostCentre ) -import HeapOffs ( SYN_IE(VirtualHeapOffset) ) +import HeapOffs ( VirtualHeapOffset ) import Id ( idType, idPrimRep, showId, getIdStrictness, dataConTag, emptyIdSet, - GenId{-instance Outputable-}, SYN_IE(Id) + Id ) import ListSetOps ( minusList ) import Maybes ( maybeToBool ) -import Outputable ( Outputable(..){-instances-}, PprStyle(..) ) -import PprType ( GenType{-instance Outputable-}, TyCon{-ditto-} ) -import Pretty ( Doc, hcat, char, ptext, hsep, text ) import PrimRep ( isFollowableRep, PrimRep(..) ) import TyCon ( isPrimTyCon, tyConDataCons ) import Type ( showTypeCategory ) -import Util ( isIn, panic, pprPanic, assertPanic, pprTrace{-ToDo:rm-} ) +import Util ( isIn ) +import Outputable getWrapperArgTypeCategories = panic "CgClosure.getWrapperArgTypeCategories (ToDo)" \end{code} @@ -105,17 +99,11 @@ cgTopRhsClosure name cc binder_info args body lf_info `thenC` -- BUILD VAP INFO TABLES IF NECESSARY - -- 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 - nopC - else - let + let bind_the_fun = addBindC name cg_id_info -- It's global! - in - cgVapInfoTables True {- Top level -} bind_the_fun binder_info name args lf_info - ) `thenC` + in + cgVapInfoTables TopLevel bind_the_fun binder_info name args lf_info + `thenC` -- BUILD THE OBJECT (IF NECESSARY) (if staticClosureRequired name binder_info lf_info @@ -257,14 +245,8 @@ cgRhsClosure binder cc binder_info fvs args body lf_info ) `thenC` -- BUILD VAP INFO TABLES IF NECESSARY - -- 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 - nopC - else - cgVapInfoTables False {- Not top level -} nopC binder_info binder args lf_info - ) `thenC` + cgVapInfoTables NotTopLevel nopC binder_info binder args lf_info + `thenC` -- BUILD THE OBJECT let @@ -302,10 +284,34 @@ cgVapInfoTables top_level perhaps_bind_the_fun binder_info fun args lf_info ) where - fun_in_payload = not top_level + fun_in_payload = case top_level of + TopLevel -> False + NotTopLevel -> True + cgVapInfoTable perhaps_bind_the_fun upd_flag fun args fun_in_payload fun_lf_info - = let + | closureReturnsUnpointedType closure_info + -- 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. + = nopC + + | otherwise + = forkClosureBody ( + + -- Bind the fvs; if the fun is not in the payload, then bind_the_fun tells + -- how to bind it. If it is in payload it'll be bound by payload_bind_details. + perhaps_bind_the_fun `thenC` + mapCs bind_fv payload_bind_details `thenC` + + -- Generate the info table and code + closureCodeBody NoStgBinderInfo + closure_info + useCurrentCostCentre + [] -- No args; it's a thunk + vap_entry_rhs + ) + where -- The vap_entry_rhs is a manufactured STG expression which -- looks like the RHS of any binding which is going to use the vap-entry -- point of the function. Each of these bindings will look like: @@ -348,23 +354,6 @@ cgVapInfoTable perhaps_bind_the_fun upd_flag fun args fun_in_payload fun_lf_info -- Id is just used for label construction, which is OK. bind_fv ((id,lf_info), offset) = bindNewToNode id offset lf_info - in - - -- BUILD ITS INFO TABLE AND CODE - forkClosureBody ( - - -- Bind the fvs; if the fun is not in the payload, then bind_the_fun tells - -- how to bind it. If it is in payload it'll be bound by payload_bind_details. - perhaps_bind_the_fun `thenC` - mapCs bind_fv payload_bind_details `thenC` - - -- Generate the info table and code - closureCodeBody NoStgBinderInfo - closure_info - useCurrentCostCentre - [] -- No args; it's a thunk - vap_entry_rhs - ) \end{code} %************************************************************************ %* * @@ -398,7 +387,7 @@ closureCodeBody binder_info closure_info cc [] body 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 -> @@ -471,7 +460,7 @@ closureCodeBody binder_info closure_info cc all_args body -- Old version (reschedule combined with heap check); -- see argSatisfactionCheck for new version --slow_entry_code = forceHeapCheck [node] True slow_entry_code' - -- where node = VanillaReg PtrRep 1 + -- where node = UnusedReg PtrRep 1 --slow_entry_code = forceHeapCheck [] True slow_entry_code' slow_entry_code @@ -507,7 +496,7 @@ closureCodeBody binder_info closure_info cc all_args body fast_entry_code = profCtrC SLIT("ENT_FUN_DIRECT") [ CLbl (mkRednCountsLabel id) PtrRep, - CString (_PK_ (showId PprDebug id)), + 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) @@ -570,7 +559,7 @@ closureCodeBody binder_info closure_info cc all_args body 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) @@ -605,7 +594,7 @@ enterCostCentreCode closure_info cc is_thunk if costsAreSubsumed cc then --ASSERT(isToplevClosure closure_info) --ASSERT(is_thunk == IsFunction) - (if isToplevClosure closure_info && is_thunk == IsFunction then \x->x else pprTrace "enterCostCenterCode:" (hsep [ppr PprDebug (is_thunk == IsFunction){-, ppr PprDebug closure_info-}, text (showCostCentre PprDebug False cc)])) $ + (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 @@ -809,7 +798,7 @@ stackCheck closure_info regs node_reqd code all_regs = if node_reqd then node:regs else regs liveness_mask = mkLiveRegsMask all_regs - returns_prim_type = closureReturnsUnboxedType closure_info + returns_prim_type = closureReturnsUnpointedType closure_info \end{code} %************************************************************************ @@ -918,11 +907,11 @@ closureDescription :: FAST_STRING -- Module -- CgConTbls.lhs with a description generated from the data constructor closureDescription mod_name name args body - = show ( + = showSDoc ( hcat [char '<', ptext mod_name, char '.', - ppr PprDebug name, + ppr name, char '>']) \end{code} @@ -975,7 +964,7 @@ mkWrapperArgTypeCategories -> String -- a string saying lots about the args mkWrapperArgTypeCategories wrapper_ty wrap_info - = case (splitFunTyExpandingDicts wrapper_ty) of { (arg_tys,_) -> + = 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...)