%
-% (c) The GRASP Project, Glasgow University, 1992-1995
+% (c) The GRASP Project, Glasgow University, 1992-1998
%
\section[CgCon]{Code generation for constructors}
@CgClosure@, which deals with closures.
\begin{code}
-#include "HsVersions.h"
-
module CgCon (
- -- it's all exported, actually...
cgTopRhsCon, buildDynCon,
- bindConArgs,
+ bindConArgs, bindUnboxedTupleComponents,
cgReturnDataCon,
-
- -- and to make the interface self-sufficient...
- Id, StgAtom, CgState, CAddrMode,
- PrimKind, PrimOp, MagicId
+ cgTyCon
) where
-IMPORT_Trace -- ToDo: rm (debugging)
-import Outputable
-import Pretty
+#include "HsVersions.h"
-import StgSyn
import CgMonad
-import AbsCSyn
-
-import AbsUniType ( maybeCharLikeTyCon, maybeIntLikeTyCon, TyVar,
- TyCon, Class, UniType
- )
-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 StgSyn
-import CgRetConv ( dataReturnConvAlg, mkLiveRegsBitMask,
- CtrlReturnConvention(..), DataReturnConvention(..)
- )
-import CgTailCall ( performReturn, mkStaticAlgReturnCode )
-import CgUsages ( getHpRelOffset )
-import CLabelInfo ( 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 ( getIdKind, 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 CmdLineOpts ( GlobalSwitch(..) )
-import Maybes ( maybeToBool, Maybe(..) )
-import PrimKind ( PrimKind(..), isFloatingKind, getKindSize )
-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}
\begin{code}
cgTopRhsCon :: Id -- Name of thing bound to this RHS
-> DataCon -- Id
- -> [PlainStgAtom] -- 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 (isFloatingKind . getAtomKind) args
- || any isLitLitStgAtom args
- = cgTopRhsClosure name top_cc NoStgBinderInfo [] body lf_info
- where
- body = StgConApp 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 getAmodeKind 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 PtrKind) 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
-
-
-Further discourse on these entry-code fragments (NB this isn't done
-yet [ToDo]): They're really pretty pointless, except for {\em
-exported} top-level constants (the rare case). Consider:
-\begin{verbatim}
-y = p : ps -- y is not exported
-f a b = y
-g c = (y, c)
-\end{verbatim}
-Why have a \tr{y_entry} fragment at all? The code generator should
-``know enough'' about \tr{y} not to need it. For the first case
-above, with \tr{y} in ``head position,'' it should generate code just
-as for an \tr{StgRhsCon} (possibly because the STG simplification
-actually did the unfolding to make it so). At the least, it should
-load up \tr{Node} and call \tr{Cons}'s entry code---not some special
-\tr{y_entry} code.
-
-\begin{pseudocode}
- -- WE NEED AN ENTRY PT, IN CASE SOMEONE JUMPS DIRECT TO name
- -- FROM OUTSIDE. NB: this CCodeBlock precedes the
- -- CStaticClosure for the same reason (fewer forward refs) as
- -- we did in CgClosure.
-
- -- we either have ``in-line'' returning code (special case)
- -- or we set Node and jump to the constructor's entry code
-
- (if maybeToBool (maybeCharLikeTyCon con_tycon)
- || maybeToBool (maybeIntLikeTyCon con_tycon)
- then -- special case
- getAbsC (-- OLD: No, we don't fiddle cost-centres on
- -- entry to data values any more (WDP 94/06)
- -- lexCostCentreC "ENTER_CC_D" [top_ccc]
- -- `thenC`
- cgReturnDataCon con amodes all_zero_size_args emptyUniqSet{-no live vars-})
- else -- boring case
- returnFC (
- mkAbstractCs [
- -- Node := this_closure
- CAssign (CReg node) (CLbl closure_label PtrKind),
- -- InfoPtr := info table for this_closure
- CAssign (CReg infoptr) (CLbl info_label DataPtrKind),
- -- Jump to std code for this constructor
- CJump (CLbl con_entry_label CodePtrKind)
- ])
- ) `thenFC` \ ret_absC ->
-
- absC (CCodeBlock entry_label ret_absC) `thenC`
-\end{pseudocode}
-
-=========================== END OF OLD STUFF ==============================
-
-
%************************************************************************
%* *
%* non-top-level constructors *
\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., VoidKind);
- -- 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
-will probably be unfolded, so we don't expect to see this case
-much, if at all, but it does no harm, and sets the scene for characters.
+will probably be unfolded, so we don't expect to see this case much,
+if at all, but it does no harm, and sets the scene for characters.
-In the case of zero-arity constructors, or, more accurately,
-those which have exclusively size-zero (VoidKind) args,
-we generate no code at all.
+In the case of zero-arity constructors, or, more accurately, those
+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) PtrKind)
- (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, but
-we'd have to be careful if the argument wasn't a constant --- so for simplicity
-we just always asssign to a temporary.
+generate no code, and record the addressing mode in the environment,
+but we'd have to be careful if the argument wasn't a constant --- so
+for simplicity we just always asssign to a temporary.
-Last special case: @Int@-like closures. We only special-case the situation
-in which the argument is a literal in the range @mIN_INTLIKE@..@mAX_INTLILKE@.
-NB: for @Char@-like closures we can work with any old argument, but
-for @Int@-like ones the argument has to be a literal. Reason: @Char@ like
-closures have an argument type which is guaranteed in range.
+Last special case: @Int@-like closures. We only special-case the
+situation in which the argument is a literal in the range
+@mIN_INTLIKE@..@mAX_INTLILKE@. NB: for @Char@-like closures we can
+work with any old argument, but for @Int@-like ones the argument has
+to be a literal. Reason: @Char@ like closures have an argument type
+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 getAmodeKind 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}
\begin{code}
bindConArgs :: DataCon -> [Id] -> Code
bindConArgs con args
- = ASSERT(isDataCon con)
- case (dataReturnConvAlg con) of
- ReturnInRegs rs -> bindArgsToRegs args rs
- ReturnInHeap ->
- let
- (_, args_w_offsets) = layOutDynCon con getIdKind 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
%* *
%************************************************************************
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 -> PlainStgLiveVars -> Code
-
-cgReturnDataCon con amodes all_zero_size_args live_vars
- = ASSERT(isDataCon con)
- 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 -> ...<returning here!>...
- --
- -- 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 PtrKind 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 CodePtrKind))
- -- Ignore the sequel: we've already looked at it above
-
- other_sequel -> -- The usual case
- case dataReturnConvAlg 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 PtrKind 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") [] `thenC`
-
- performReturn reg_assts (mkStaticAlgReturnCode con (Just info_lbl)) live_vars
-
- ReturnInRegs regs ->
- let reg_assts = mkAbstractCs (zipWith move_to_reg amodes regs)
- info_lbl = mkPhantomInfoTableLabel con
- in
---OLD:WDP:94/06 evalCostCentreC "SET_RetCC" [CReg CurCostCentre] `thenC`
- profCtrC SLIT("RET_NEW_IN_REGS") [] `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 -> ...<returning here!>...
+ --
+ -- 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}
projects / ghc-hetmet.git / blobdiff