@CgCon@, which deals with constructors.
\begin{code}
-#include "HsVersions.h"
-
module CgClosure ( cgTopRhsClosure, cgRhsClosure ) where
-IMP_Ubiq(){-uitous-}
-IMPORT_DELOOPER(CgLoop2) ( cgExpr )
+#include "HsVersions.h"
+
+import {-# SOURCE #-} CgExpr ( cgExpr )
import CgMonad
import AbsCSyn
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 HeapOffs ( VirtualHeapOffset )
import Id ( idType, idPrimRep,
showId, getIdStrictness, dataConTag,
emptyIdSet,
- GenId{-instance Outputable-}
+ Id
)
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, ppCat, ppStr )
import PrimRep ( isFollowableRep, PrimRep(..) )
import TyCon ( isPrimTyCon, tyConDataCons )
-import Unpretty ( uppShow )
-import Util ( isIn, panic, pprPanic, assertPanic, pprTrace{-ToDo:rm-} )
+import Type ( showTypeCategory )
+import Util ( isIn )
+import Outputable
-myWrapperMaybe = panic "CgClosure.myWrapperMaybe (ToDo)"
-showTypeCategory = panic "CgClosure.showTypeCategory (ToDo)"
getWrapperArgTypeCategories = panic "CgClosure.getWrapperArgTypeCategories (ToDo)"
\end{code}
-- 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
+ (if closureReturnsUnpointedType closure_info then
nopC
else
let
-- 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
+ (if closureReturnsUnpointedType closure_info then
nopC
else
cgVapInfoTables False {- Not top level -} nopC binder_info binder args lf_info
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 ->
= getEntryConvention id lf_info
(map idPrimRep all_args) `thenFC` \ entry_conv ->
let
+ -- 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)
= mkVirtStkOffsets
-- 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
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)
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
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
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)
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 (is_thunk == IsFunction){-, ppr closure_info-}, text (showCostCentre False cc)])) $
costCentresC SLIT("ENTER_CC_FSUB") []
else if currentOrSubsumedCosts cc then
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}
%************************************************************************
-- 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 '.',
- ppr PprDebug name,
- ppChar '>']))
+ = showSDoc (
+ hcat [char '<',
+ ptext mod_name,
+ char '.',
+ ppr name,
+ char '>'])
\end{code}
\begin{code}
-> 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...)
do_one (WwPrim, _) = 'P'
do_one (WwEnum, _) = 'E'
do_one (WwStrict, arg_ty_char) = arg_ty_char
- do_one (WwUnpack _ _, 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'
projects / ghc-hetmet.git / blobdiff