module CgClosure ( cgTopRhsClosure, cgRhsClosure ) where
IMP_Ubiq(){-uitous-}
+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
IMPORT_DELOOPER(CgLoop2) ( cgExpr )
+#else
+import {-# SOURCE #-} CgExpr ( cgExpr )
+#endif
import CgMonad
import AbsCSyn
bindNewToReg, bindArgsToRegs,
stableAmodeIdInfo, heapIdInfo, CgIdInfo
)
-import CgCompInfo ( spARelToInt, spBRelToInt )
+import Constants ( spARelToInt, spBRelToInt )
import CgUpdate ( pushUpdateFrame )
import CgHeapery ( allocDynClosure, heapCheck
, heapCheckOnly, fetchAndReschedule, yield -- HWL
getSpARelOffset, getSpBRelOffset,
getHpRelOffset
)
-import CLabel ( mkClosureLabel, mkConUpdCodePtrVecLabel,
+import CLabel ( mkClosureLabel, mkConUpdCodePtrVecLabel, mkFastEntryLabel,
mkStdUpdCodePtrVecLabel, mkStdUpdVecTblLabel,
mkErrorStdEntryLabel, mkRednCountsLabel
)
import CmdLineOpts ( opt_ForConcurrent, opt_GranMacros )
import CostCentre ( useCurrentCostCentre, currentOrSubsumedCosts,
noCostCentreAttached, costsAreSubsumed,
- isCafCC, isDictCC, overheadCostCentre, showCostCentre
+ isCafCC, isDictCC, overheadCostCentre, showCostCentre,
+ CostCentre
)
import HeapOffs ( SYN_IE(VirtualHeapOffset) )
import Id ( idType, idPrimRep,
showId, getIdStrictness, dataConTag,
emptyIdSet,
- GenId{-instance Outputable-}
+ GenId{-instance Outputable-}, SYN_IE(Id)
)
import ListSetOps ( minusList )
import Maybes ( maybeToBool )
-import Outputable ( Outputable(..){-instances-} ) -- ToDo:rm
-import PprStyle ( PprStyle(..) )
+import Outputable ( Outputable(..){-instances-}, PprStyle(..) )
import PprType ( GenType{-instance Outputable-}, TyCon{-ditto-} )
-import Pretty ( prettyToUn, ppBesides, ppChar, ppPStr, ppCat, ppStr )
+import Pretty ( Doc, hcat, char, ptext, hsep, text )
import PrimRep ( isFollowableRep, PrimRep(..) )
import TyCon ( isPrimTyCon, tyConDataCons )
-import Unpretty ( uppShow )
+import Type ( showTypeCategory )
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}
-- 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]
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
= getEntryConvention id lf_info
(map idPrimRep all_args) `thenFC` \ entry_conv ->
let
- is_concurrent = opt_ForConcurrent
-
- stg_arity = length all_args
+ -- Figure out what is needed and what isn't
+ slow_code_needed = slowFunEntryCodeRequired id binder_info entry_conv
+ info_table_needed = funInfoTableRequired id binder_info lf_info
-- 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)
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`
-- Bind args to regs/stack as appropriate, and
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
- -- Figure out what is needed and what isn't
- slow_code_needed = slowFunEntryCodeRequired id binder_info
- info_table_needed = funInfoTableRequired id binder_info lf_info
-
-- 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
= 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
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:" (ppCat [ppr PprDebug (is_thunk == IsFunction){-, ppr PprDebug closure_info-}, ppStr (showCostCentre PprDebug False cc)])) $
+ (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)])) $
costCentresC SLIT("ENTER_CC_FSUB") []
else if currentOrSubsumedCosts cc then
-- CgConTbls.lhs with a description generated from the data constructor
closureDescription mod_name name args body
- = uppShow 0 (prettyToUn (
- ppBesides [ppChar '<',
- ppPStr mod_name,
- ppChar '.',
+ = show (
+ hcat [char '<',
+ ptext mod_name,
+ char '.',
ppr PprDebug name,
- ppChar '>']))
+ char '>'])
\end{code}
\begin{code}
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}
+
projects / ghc-hetmet.git / blobdiff