@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,
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}
`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
) `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
)
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:
-- 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}
%************************************************************************
%* *
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 ->
-- 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)
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:" (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
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
- = show (
+ = showSDoc (
hcat [char '<',
ptext mod_name,
char '.',
- ppr PprDebug name,
+ ppr name,
char '>'])
\end{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...)
projects / ghc-hetmet.git / blobdiff