X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Fcompiler%2FcodeGen%2FCgCon.lhs;h=bfb55bf46ee6f936c533c79c84a3bb59e85de166;hb=28a464a75e14cece5db40f2765a29348273ff2d2;hp=820133569966d52f1958fed339096b434cccfd1b;hpb=6c381e873e222417d9a67aeec77b9555eca7b7a8;p=ghc-hetmet.git diff --git a/ghc/compiler/codeGen/CgCon.lhs b/ghc/compiler/codeGen/CgCon.lhs index 8201335..bfb55bf 100644 --- a/ghc/compiler/codeGen/CgCon.lhs +++ b/ghc/compiler/codeGen/CgCon.lhs @@ -1,5 +1,5 @@ % -% (c) The GRASP Project, Glasgow University, 1992-1995 +% (c) The GRASP Project, Glasgow University, 1992-1998 % \section[CgCon]{Code generation for constructors} @@ -8,60 +8,56 @@ with {\em constructors} on the RHSs of let(rec)s. See also @CgClosure@, which deals with closures. \begin{code} -#include "HsVersions.h" - module CgCon ( - -- it's all exported, actually... cgTopRhsCon, buildDynCon, - bindConArgs, - cgReturnDataCon - - -- and to make the interface self-sufficient... + bindConArgs, bindUnboxedTupleComponents, + cgReturnDataCon, + cgTyCon ) where -import StgSyn -import CgMonad -import AbsCSyn +#include "HsVersions.h" -import Type ( maybeCharLikeTyCon, maybeIntLikeTyCon, TyVar, - TyCon, Class, Type - ) -import CgBindery ( getAtomAmode, getAtomAmodes, bindNewToNode, - bindArgsToRegs, newTempAmodeAndIdInfo, idInfoToAmode - ) -import CgClosure ( cgTopRhsClosure ) -import CgHeapery ( allocDynClosure, heapCheck -#ifdef GRAN - , fetchAndReschedule -- HWL -#endif {- GRAN -} - ) -import CgCompInfo ( mAX_INTLIKE, mIN_INTLIKE ) +import CgMonad +import StgSyn -import CgRetConv ( dataReturnConvAlg, mkLiveRegsBitMask, - CtrlReturnConvention(..), DataReturnConvention(..) - ) -import CgTailCall ( performReturn, mkStaticAlgReturnCode ) -import CgUsages ( getHpRelOffset ) -import CLabel ( CLabel, mkClosureLabel, mkInfoTableLabel, - mkPhantomInfoTableLabel, - mkConEntryLabel, mkStdEntryLabel +import CgBindery ( getArgAmodes, bindNewToNode, + bindArgsToRegs, idInfoToAmode, stableIdInfo, + heapIdInfo, CgIdInfo, bindArgsToStack ) -import ClosureInfo -- hiding ( auxInfoTableLabelFromCI ) -- I hate pragmas - {-( mkConLFInfo, mkLFArgument, closureLFInfo, - layOutDynCon, layOutDynClosure, - layOutStaticClosure, UpdateFlag(..), - mkClosureLFInfo, layOutStaticNoFVClosure - )-} -import Id ( getIdPrimRep, getDataConTag, getDataConTyCon, - isDataCon, fIRST_TAG, DataCon(..), ConTag(..) +import CgStackery ( mkVirtStkOffsets, freeStackSlots, + getRealSp, getVirtSp, setRealAndVirtualSp ) +import CgUtils ( addIdReps, cmmLabelOffW, emitRODataLits, emitDataLits ) +import CgCallConv ( assignReturnRegs ) +import Constants ( mAX_INTLIKE, mIN_INTLIKE, mAX_CHARLIKE, mIN_CHARLIKE ) +import CgHeapery ( allocDynClosure, layOutDynConstr, + layOutStaticConstr, mkStaticClosureFields ) +import CgTailCall ( performReturn, emitKnownConReturnCode, returnUnboxedTuple ) +import CgProf ( mkCCostCentreStack, ldvEnter, curCCS ) +import CgTicky +import CgInfoTbls ( emitClosureCodeAndInfoTable, dataConTagZ ) +import CLabel +import ClosureInfo ( mkConLFInfo, mkLFArgument ) +import CmmUtils ( mkLblExpr ) +import Cmm +import SMRep ( WordOff, CgRep, separateByPtrFollowness, + fixedHdrSize, typeCgRep ) +import CostCentre ( currentOrSubsumedCCS, dontCareCCS, CostCentreStack, + currentCCS ) +import Constants ( mIN_INTLIKE, mAX_INTLIKE, mIN_CHARLIKE, mAX_CHARLIKE ) +import TyCon ( TyCon, tyConDataCons, isEnumerationTyCon, tyConName ) +import DataCon ( DataCon, dataConRepArgTys, isNullaryRepDataCon, + isUnboxedTupleCon, dataConWorkId, + dataConName, dataConRepArity ) -import Maybes ( maybeToBool, Maybe(..) ) -import PrimRep ( PrimRep(..), isFloatingRep, getPrimRepSize ) -import CostCentre -import UniqSet -- ( emptyUniqSet, UniqSet(..) ) -import Util +import Id ( Id, idName, isDeadBinder ) +import Type ( Type ) +import PrelInfo ( maybeCharLikeCon, maybeIntLikeCon ) +import Outputable +import Util ( lengthIs ) +import ListSetOps ( assocMaybe ) \end{code} + %************************************************************************ %* * \subsection[toplevel-constructors]{Top-level constructors} @@ -71,183 +67,45 @@ import Util \begin{code} cgTopRhsCon :: Id -- Name of thing bound to this RHS -> DataCon -- Id - -> [StgArg] -- Args - -> Bool -- All zero-size args (see buildDynCon) + -> [StgArg] -- Args -> FCode (Id, CgIdInfo) -\end{code} - -Special Case: -Constructors some of whose arguments are of \tr{Float#} or -\tr{Double#} type, {\em or} which are ``lit lits'' (which are given -\tr{Addr#} type). - -These ones have to be compiled as re-entrant thunks rather than closures, -because we can't figure out a way to persuade C to allow us to initialise a -static closure with Floats and Doubles! -Thus, for \tr{x = 2.0} (defaults to Double), we get: - -\begin{verbatim} --- The STG syntax: - Main.x = MkDouble [2.0##] - --- C Code: - --- closure: - SET_STATIC_HDR(Main_x_closure,Main_x_static,CC_DATA,,EXTDATA_RO) - }; --- its *own* info table: - STATIC_INFO_TABLE(Main_x,Main_x_entry,,,,EXTFUN,???,":MkDouble","Double"); --- with its *own* entry code: - STGFUN(Main_x_entry) { - P_ u1701; - RetDouble1=2.0; - u1701=(P_)*SpB; - SpB=SpB-1; - JMP_(u1701[0]); - } -\end{verbatim} - -The above has the down side that each floating-point constant will end -up with its own info table (rather than sharing the MkFloat/MkDouble -ones). On the plus side, however, it does return a value (\tr{2.0}) -{\em straight away}. - -Here, then is the implementation: just pretend it's a non-updatable -thunk. That is, instead of - - x = F# 3.455# - -pretend we've seen - - x = [] \n [] -> F# 3.455# - -\begin{code} -top_cc = dontCareCostCentre -- out here to avoid a cgTopRhsCon CAF (sigh) -top_ccc = mkCCostCentre dontCareCostCentre -- because it's static data - -cgTopRhsCon name con args all_zero_size_args - | any (isFloatingRep . getArgPrimRep) args - || any isLitLitArg args - = cgTopRhsClosure name top_cc NoStgBinderInfo [] body lf_info - where - body = StgCon con args emptyUniqSet{-emptyLiveVarSet-} - lf_info = mkClosureLFInfo True {- Top level -} [] ReEntrant [] body -\end{code} - -OK, so now we have the general case. - -\begin{code} -cgTopRhsCon name con args all_zero_size_args - = ( - ASSERT(isDataCon con) +cgTopRhsCon id con args + = do { + ; hmods <- getHomeModules +#if mingw32_TARGET_OS + -- Windows DLLs have a problem with static cross-DLL refs. + ; ASSERT( not (isDllConApp hmods con args) ) return () +#endif + ; ASSERT( args `lengthIs` dataConRepArity con ) return () -- LAY IT OUT - getAtomAmodes args `thenFC` \ amodes -> - - let - (closure_info, amodes_w_offsets) - = layOutStaticClosure name getAmodeRep amodes lf_info - in - -- HWL: In 0.22 there was a heap check in here that had to be changed. - -- CHECK if having no heap check is ok for GrAnSim here!!! - - -- BUILD THE OBJECT - absC (CStaticClosure - closure_label -- Labelled with the name on lhs of defn - closure_info -- Closure is static - top_ccc - (map fst amodes_w_offsets)) -- Sorted into ptrs first, then nonptrs - - ) `thenC` - - -- RETURN - returnFC (name, stableAmodeIdInfo name (CLbl closure_label PtrRep) lf_info) - where - con_tycon = getDataConTyCon con - lf_info = mkConLFInfo con - - closure_label = mkClosureLabel name - info_label = mkInfoTableLabel con - con_entry_label = mkConEntryLabel con - entry_label = mkStdEntryLabel name + ; amodes <- getArgAmodes args + + ; let + name = idName id + lf_info = mkConLFInfo con + closure_label = mkClosureLabel hmods name + caffy = any stgArgHasCafRefs args + (closure_info, amodes_w_offsets) = layOutStaticConstr hmods con amodes + closure_rep = mkStaticClosureFields + closure_info + dontCareCCS -- Because it's static data + caffy -- Has CAF refs + payload + + payload = map get_lit amodes_w_offsets + get_lit (CmmLit lit, _offset) = lit + get_lit other = pprPanic "CgCon.get_lit" (ppr other) + -- NB1: amodes_w_offsets is sorted into ptrs first, then non-ptrs + -- NB2: all the amodes should be Lits! + + -- BUILD THE OBJECT + ; emitDataLits closure_label closure_rep + + -- RETURN + ; returnFC (id, stableIdInfo id (mkLblExpr closure_label) lf_info) } \end{code} -The general case is: -\begin{verbatim} --- code: - data Foo = MkFoo - x = MkFoo - --- STG code: -STG syntax: - Main.x = Main.MkFoo [] - --- interesting parts of the C Code: - --- closure for "x": - SET_STATIC_HDR(Main_x_closure,Main_MkFoo_static,CC_DATA,,EXTDATA_RO) - }; --- entry code for "x": - STGFUN(Main_x_entry) { - Node=(W_)(Main_x_closure); - STGJUMP(Main_MkFoo_entry); - } -\end{verbatim} - -Observe: (1)~We create a static closure for \tr{x}, {\em reusing} the -regular \tr{MkFoo} info-table and entry code. (2)~However: the -\tr{MkFoo} code expects Node to be set, but the caller of \tr{x_entry} -will not have set it. Therefore, the whole point of \tr{x_entry} is -to set node (and then call the shared \tr{MkFoo} entry code). - -Special Case: -For top-level Int/Char constants. We get entry-code fragments of the form: - -\begin{verbatim} --- code: - y = 1 - --- entry code for "y": - STGFUN(Main_y_entry) { - Node=(W_)(Main_y_closure); - STGJUMP(I#_entry); - } -\end{verbatim} - -This is pretty tiresome: we {\em know} what the constant is---we'd -rather just return it. We end up with something that's a hybrid -between the Float/Double and general cases: (a)~like Floats/Doubles, -the entry-code returns the value immediately; (b)~like the general -case, we share the data-constructor's std info table. So, what we -want is: -\begin{verbatim} --- code: - z = 1 - --- STG code: -STG syntax: - Main.z = I# [1#] - --- interesting parts of the C Code: - --- closure for "z" (shares I# info table): - SET_STATIC_HDR(Main_z_closure,I#_static,CC_DATA,,EXTDATA_RO) - }; --- entry code for "z" (do the business directly): - STGFUN(Main_z_entry) { - P_ u1702; - Ret1=1; - u1702=(P_)*SpB; - SpB=SpB-1; - JMP_(u1702[0]); - } -\end{verbatim} - -This blob used to be in cgTopRhsCon, but I don't see how we can jump -direct to the named code for a constructor; any external entries will -be via Node. Generating all this extra code is a real waste for big -static data structures. So I've nuked it. SLPJ Sept 94 - %************************************************************************ %* * %* non-top-level constructors * @@ -256,19 +114,23 @@ static data structures. So I've nuked it. SLPJ Sept 94 \subsection[code-for-constructors]{The code for constructors} \begin{code} -buildDynCon :: Id -- Name of the thing to which this constr will - -- be bound - -> CostCentre -- Where to grab cost centre from; - -- current CC if currentOrSubsumedCosts - -> DataCon -- The data constructor - -> [CAddrMode] -- Its args - -> Bool -- True <=> all args (if any) are - -- of "zero size" (i.e., VoidRep); - -- The reason we don't just look at the - -- args is that we may be in a "knot", and - -- premature looking at the args will cause - -- the compiler to black-hole! - -> FCode CgIdInfo -- Return details about how to find it +buildDynCon :: Id -- Name of the thing to which this constr will + -- be bound + -> CostCentreStack -- Where to grab cost centre from; + -- current CCS if currentOrSubsumedCCS + -> DataCon -- The data constructor + -> [(CgRep,CmmExpr)] -- Its args + -> FCode CgIdInfo -- Return details about how to find it + +-- We used to pass a boolean indicating whether all the +-- args were of size zero, so we could use a static +-- construtor; but I concluded that it just isn't worth it. +-- Now I/O uses unboxed tuples there just aren't any constructors +-- with all size-zero args. +-- +-- The reason for having a separate argument, rather than looking at +-- the addr modes of the args is that we may be in a "knot", and +-- premature looking at the args will cause the compiler to black-hole! \end{code} First we deal with the case of zero-arity constructors. Now, they @@ -280,13 +142,19 @@ which have exclusively size-zero (VoidRep) args, we generate no code at all. \begin{code} -buildDynCon binder cc con args all_zero_size_args@True - = ASSERT(isDataCon con) - returnFC (stableAmodeIdInfo binder - (CLbl (mkClosureLabel con) PtrRep) - (mkConLFInfo con)) +buildDynCon binder cc con [] + = do hmods <- getHomeModules + returnFC (stableIdInfo binder + (mkLblExpr (mkClosureLabel hmods (dataConName con))) + (mkConLFInfo con)) \end{code} +The following three paragraphs about @Char@-like and @Int@-like +closures are obsolete, but I don't understand the details well enough +to properly word them, sorry. I've changed the treatment of @Char@s to +be analogous to @Int@s: only a subset is preallocated, because @Char@ +has now 31 bits. Only literals are handled here. -- Qrczak + Now for @Char@-like closures. We generate an assignment of the address of the closure to a temporary. It would be possible simply to generate no code, and record the addressing mode in the environment, @@ -303,39 +171,46 @@ which is guaranteed in range. Because of this, we use can safely return an addressing mode. \begin{code} -buildDynCon binder cc con [arg_amode] all_zero_size_args@False - - | maybeToBool (maybeCharLikeTyCon tycon) - = ASSERT(isDataCon con) - absC (CAssign temp_amode (CCharLike arg_amode)) `thenC` - returnFC temp_id_info - - | maybeToBool (maybeIntLikeTyCon tycon) && in_range_int_lit arg_amode - = ASSERT(isDataCon con) - returnFC (stableAmodeIdInfo binder (CIntLike arg_amode) (mkConLFInfo con)) - where - tycon = getDataConTyCon con - (temp_amode, temp_id_info) = newTempAmodeAndIdInfo binder (mkConLFInfo con) - - in_range_int_lit (CLit (MachInt val _)) = (val <= mAX_INTLIKE) && (val >= mIN_INTLIKE) - in_range_int_lit other_amode = False +buildDynCon binder cc con [arg_amode] + | maybeIntLikeCon con + , (_, CmmLit (CmmInt val _)) <- arg_amode + , let val_int = (fromIntegral val) :: Int + , val_int <= mAX_INTLIKE && val_int >= mIN_INTLIKE + = do { let intlike_lbl = mkRtsDataLabel SLIT("stg_INTLIKE_closure") + offsetW = (val_int - mIN_INTLIKE) * (fixedHdrSize + 1) + -- INTLIKE closures consist of a header and one word payload + intlike_amode = CmmLit (cmmLabelOffW intlike_lbl offsetW) + ; returnFC (stableIdInfo binder intlike_amode (mkConLFInfo con)) } + +buildDynCon binder cc con [arg_amode] + | maybeCharLikeCon con + , (_, CmmLit (CmmInt val _)) <- arg_amode + , let val_int = (fromIntegral val) :: Int + , val_int <= mAX_CHARLIKE && val_int >= mIN_CHARLIKE + = do { let charlike_lbl = mkRtsDataLabel SLIT("stg_CHARLIKE_closure") + offsetW = (val_int - mIN_CHARLIKE) * (fixedHdrSize + 1) + -- CHARLIKE closures consist of a header and one word payload + charlike_amode = CmmLit (cmmLabelOffW charlike_lbl offsetW) + ; returnFC (stableIdInfo binder charlike_amode (mkConLFInfo con)) } \end{code} Now the general case. \begin{code} -buildDynCon binder cc con args all_zero_size_args@False - = ASSERT(isDataCon con) - allocDynClosure closure_info use_cc blame_cc amodes_w_offsets `thenFC` \ hp_off -> - returnFC (heapIdInfo binder hp_off (mkConLFInfo con)) +buildDynCon binder ccs con args + = do { + ; hmods <- getHomeModules + ; let + (closure_info, amodes_w_offsets) = layOutDynConstr hmods con args + + ; hp_off <- allocDynClosure closure_info use_cc blame_cc amodes_w_offsets + ; returnFC (heapIdInfo binder hp_off lf_info) } where - (closure_info, amodes_w_offsets) - = layOutDynClosure binder getAmodeRep args (mkConLFInfo con) + lf_info = mkConLFInfo con use_cc -- cost-centre to stick in the object - = if currentOrSubsumedCosts cc - then CReg CurCostCentre - else mkCCostCentre cc + | currentOrSubsumedCCS ccs = curCCS + | otherwise = CmmLit (mkCCostCentreStack ccs) blame_cc = use_cc -- cost-centre on which to blame the alloc (same) \end{code} @@ -356,24 +231,67 @@ found a $con$. \begin{code} bindConArgs :: DataCon -> [Id] -> Code bindConArgs con args - = ASSERT(isDataCon con) - getIntSwitchChkrC `thenFC` \ isw_chkr -> - - case (dataReturnConvAlg isw_chkr con) of - ReturnInRegs rs -> bindArgsToRegs args rs - ReturnInHeap -> - let - (_, args_w_offsets) = layOutDynCon con getIdPrimRep args - in - mapCs bind_arg args_w_offsets - where - bind_arg (arg, offset) = bindNewToNode arg offset mkLFArgument + = do hmods <- getHomeModules + let + bind_arg (arg, offset) = bindNewToNode arg offset (mkLFArgument arg) + (_, args_w_offsets) = layOutDynConstr hmods con (addIdReps args) + -- + ASSERT(not (isUnboxedTupleCon con)) return () + mapCs bind_arg args_w_offsets \end{code} +Unboxed tuples are handled slightly differently - the object is +returned in registers and on the stack instead of the heap. + +\begin{code} +bindUnboxedTupleComponents + :: [Id] -- Args + -> FCode ([(Id,GlobalReg)], -- Regs assigned + WordOff, -- Number of pointer stack slots + WordOff, -- Number of non-pointer stack slots + VirtualSpOffset) -- Offset of return address slot + -- (= realSP on entry) + +bindUnboxedTupleComponents args + = do { + vsp <- getVirtSp + ; rsp <- getRealSp + + -- Assign as many components as possible to registers + ; let (reg_args, stk_args) = assignReturnRegs (addIdReps args) + + -- Separate the rest of the args into pointers and non-pointers + (ptr_args, nptr_args) = separateByPtrFollowness stk_args + + -- Allocate the rest on the stack + -- The real SP points to the return address, above which any + -- leftover unboxed-tuple components will be allocated + (ptr_sp, ptr_offsets) = mkVirtStkOffsets rsp ptr_args + (nptr_sp, nptr_offsets) = mkVirtStkOffsets ptr_sp nptr_args + ptrs = ptr_sp - rsp + nptrs = nptr_sp - ptr_sp + + -- The stack pointer points to the last stack-allocated component + ; setRealAndVirtualSp nptr_sp + + -- We have just allocated slots starting at real SP + 1, and set the new + -- virtual SP to the topmost allocated slot. + -- If the virtual SP started *below* the real SP, we've just jumped over + -- some slots that won't be in the free-list, so put them there + -- This commonly happens because we've freed the return-address slot + -- (trimming back the virtual SP), but the real SP still points to that slot + ; freeStackSlots [vsp+1,vsp+2 .. rsp] + + ; bindArgsToRegs reg_args + ; bindArgsToStack ptr_offsets + ; bindArgsToStack nptr_offsets + + ; returnFC (reg_args, ptrs, nptrs, rsp) } +\end{code} %************************************************************************ %* * -\subsubsection[CgRetConv-cgReturnDataCon]{Actually generate code for a constructor return} + Actually generate code for a constructor return %* * %************************************************************************ @@ -381,78 +299,159 @@ bindConArgs con args Note: it's the responsibility of the @cgReturnDataCon@ caller to be sure the @amodes@ passed don't conflict with each other. \begin{code} -cgReturnDataCon :: DataCon -> [CAddrMode] -> Bool -> StgLiveVars -> Code - -cgReturnDataCon con amodes all_zero_size_args live_vars - = ASSERT(isDataCon con) - getIntSwitchChkrC `thenFC` \ isw_chkr -> - getEndOfBlockInfo `thenFC` \ (EndOfBlockInfo args_spa args_spb sequel) -> - - case sequel of - - CaseAlts _ (Just (alts, Just (maybe_deflt_binder, (_,deflt_lbl)))) - | not (getDataConTag con `is_elem` map fst alts) - -> - -- Special case! We're returning a constructor to the default case - -- of an enclosing case. For example: - -- - -- case (case e of (a,b) -> C a b) of - -- D x -> ... - -- y -> ...... - -- - -- In this case, - -- if the default is a non-bind-default (ie does not use y), - -- then we should simply jump to the default join point; - -- - -- if the default is a bind-default (ie does use y), we - -- should return the constructor IN THE HEAP, pointed to by Node, - -- **regardless** of the return convention of the constructor C. - - case maybe_deflt_binder of - Just binder -> - buildDynCon binder useCurrentCostCentre con amodes all_zero_size_args - `thenFC` \ idinfo -> - idInfoToAmode PtrRep idinfo `thenFC` \ amode -> - performReturn (move_to_reg amode node) jump_to_join_point live_vars - - Nothing -> - performReturn AbsCNop {- No reg assts -} jump_to_join_point live_vars - where - is_elem = isIn "cgReturnDataCon" - jump_to_join_point sequel = absC (CJump (CLbl deflt_lbl CodePtrRep)) - -- Ignore the sequel: we've already looked at it above - - other_sequel -> -- The usual case - case (dataReturnConvAlg isw_chkr con) of - - ReturnInHeap -> - -- BUILD THE OBJECT IN THE HEAP - -- The first "con" says that the name bound to this - -- closure is "con", which is a bit of a fudge, but it only - -- affects profiling (ToDo?) - buildDynCon con useCurrentCostCentre con amodes all_zero_size_args - `thenFC` \ idinfo -> - idInfoToAmode PtrRep idinfo `thenFC` \ amode -> - - -- MAKE NODE POINT TO IT - let reg_assts = move_to_reg amode node - info_lbl = mkInfoTableLabel con - in - - -- RETURN - profCtrC SLIT("RET_NEW_IN_HEAP") [mkIntCLit (length amodes)] `thenC` - - performReturn reg_assts (mkStaticAlgReturnCode con (Just info_lbl)) live_vars - - ReturnInRegs regs -> - let - reg_assts = mkAbstractCs (zipWithEqual move_to_reg amodes regs) - info_lbl = mkPhantomInfoTableLabel con - in - profCtrC SLIT("RET_NEW_IN_REGS") [mkIntCLit (length amodes)] `thenC` - - performReturn reg_assts (mkStaticAlgReturnCode con (Just info_lbl)) live_vars +cgReturnDataCon :: DataCon -> [(CgRep, CmmExpr)] -> Code + +cgReturnDataCon con amodes + = ASSERT( amodes `lengthIs` dataConRepArity con ) + do { EndOfBlockInfo _ sequel <- getEndOfBlockInfo + ; case sequel of + CaseAlts _ (Just (alts, deflt_lbl)) bndr _ + -> -- Ho! We know the constructor so we can + -- go straight to the right alternative + case assocMaybe alts (dataConTagZ con) of { + Just join_lbl -> build_it_then (jump_to join_lbl); + Nothing + -- Special case! We're returning a constructor to the default case + -- of an enclosing case. For example: + -- + -- case (case e of (a,b) -> C a b) of + -- D x -> ... + -- y -> ...... + -- + -- In this case, + -- if the default is a non-bind-default (ie does not use y), + -- then we should simply jump to the default join point; + + | isDeadBinder bndr -> performReturn (jump_to deflt_lbl) + | otherwise -> build_it_then (jump_to deflt_lbl) } + + other_sequel -- The usual case + | isUnboxedTupleCon con -> returnUnboxedTuple amodes + | otherwise -> build_it_then (emitKnownConReturnCode con) + } + where + jump_to lbl = stmtC (CmmJump (CmmLit lbl) []) + build_it_then return_code + = do { -- BUILD THE OBJECT IN THE HEAP + -- The first "con" says that the name bound to this + -- closure is "con", which is a bit of a fudge, but it only + -- affects profiling + + -- This Id is also used to get a unique for a + -- temporary variable, if the closure is a CHARLIKE. + -- funnily enough, this makes the unique always come + -- out as '54' :-) + tickyReturnNewCon (length amodes) + ; idinfo <- buildDynCon (dataConWorkId con) currentCCS con amodes + ; amode <- idInfoToAmode idinfo + ; checkedAbsC (CmmAssign nodeReg amode) + ; performReturn return_code } +\end{code} + + +%************************************************************************ +%* * + Generating static stuff for algebraic data types +%* * +%************************************************************************ + + [These comments are rather out of date] + +\begin{tabular}{lll} +Info tbls & Macro & Kind of constructor \\ +\hline +info & @CONST_INFO_TABLE@& Zero arity (no info -- compiler uses static closure)\\ +info & @CHARLIKE_INFO_TABLE@& Charlike (no info -- compiler indexes fixed array)\\ +info & @INTLIKE_INFO_TABLE@& Intlike; the one macro generates both info tbls\\ +info & @SPEC_INFO_TABLE@& SPECish, and bigger than or equal to @MIN_UPD_SIZE@\\ +info & @GEN_INFO_TABLE@& GENish (hence bigger than or equal to @MIN_UPD_SIZE@)\\ +\end{tabular} + +Possible info tables for constructor con: + +\begin{description} +\item[@_con_info@:] +Used for dynamically let(rec)-bound occurrences of +the constructor, and for updates. For constructors +which are int-like, char-like or nullary, when GC occurs, +the closure tries to get rid of itself. + +\item[@_static_info@:] +Static occurrences of the constructor +macro: @STATIC_INFO_TABLE@. +\end{description} + +For zero-arity constructors, \tr{con}, we NO LONGER generate a static closure; +it's place is taken by the top level defn of the constructor. + +For charlike and intlike closures there is a fixed array of static +closures predeclared. + +\begin{code} +cgTyCon :: TyCon -> FCode [Cmm] -- each constructor gets a separate Cmm +cgTyCon tycon + = do { constrs <- mapM (getCmm . cgDataCon) (tyConDataCons tycon) + + -- Generate a table of static closures for an enumeration type + -- Put the table after the data constructor decls, because the + -- datatype closure table (for enumeration types) + -- to (say) PrelBase_$wTrue_closure, which is defined in code_stuff + ; extra <- + if isEnumerationTyCon tycon then do + tbl <- getCmm (emitRODataLits (mkLocalClosureTableLabel + (tyConName tycon)) + [ CmmLabel (mkLocalClosureLabel (dataConName con)) + | con <- tyConDataCons tycon]) + return [tbl] + else + return [] + + ; return (extra ++ constrs) + } +\end{code} + +Generate the entry code, info tables, and (for niladic constructor) the +static closure, for a constructor. + +\begin{code} +cgDataCon :: DataCon -> Code +cgDataCon data_con + = do { -- Don't need any dynamic closure code for zero-arity constructors + hmods <- getHomeModules + + ; let + -- To allow the debuggers, interpreters, etc to cope with + -- static data structures (ie those built at compile + -- time), we take care that info-table contains the + -- information we need. + (static_cl_info, _) = + layOutStaticConstr hmods data_con arg_reps + + (dyn_cl_info, arg_things) = + layOutDynConstr hmods data_con arg_reps + + emit_info cl_info ticky_code + = do { code_blks <- getCgStmts the_code + ; emitClosureCodeAndInfoTable cl_info [] code_blks } + where + the_code = do { ticky_code + ; ldvEnter (CmmReg nodeReg) + ; body_code } + + arg_reps :: [(CgRep, Type)] + arg_reps = [(typeCgRep ty, ty) | ty <- dataConRepArgTys data_con] + + body_code = do { + -- NB: We don't set CC when entering data (WDP 94/06) + tickyReturnOldCon (length arg_things) + ; performReturn (emitKnownConReturnCode data_con) } + -- noStmts: Ptr to thing already in Node + + ; whenC (not (isNullaryRepDataCon data_con)) + (emit_info dyn_cl_info tickyEnterDynCon) + + -- Dynamic-Closure first, to reduce forward references + ; emit_info static_cl_info tickyEnterStaticCon } + where - move_to_reg :: CAddrMode -> MagicId -> AbstractC - move_to_reg src_amode dest_reg = CAssign (CReg dest_reg) src_amode \end{code}