[project @ 2003-07-28 16:05:30 by simonmar]
[ghc-hetmet.git] / ghc / compiler / codeGen / CgCon.lhs
index 05ef0e8..c83a035 100644 (file)
@@ -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,65 +8,52 @@ 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...
-       Id, StgAtom, CgState, CAddrMode,
-       PrimKind, PrimOp, MagicId
+       bindConArgs, bindUnboxedTupleComponents,
+       cgReturnDataCon
     ) where
 
-IMPORT_Trace           -- ToDo: rm (debugging)
-import Outputable
-import Pretty
+#include "HsVersions.h"
 
-import StgSyn
 import CgMonad
 import AbsCSyn
+import StgSyn
 
-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 CgRetConv       ( dataReturnConvAlg, mkLiveRegsBitMask,
-                         CtrlReturnConvention(..), DataReturnConvention(..)
+import AbsCUtils       ( getAmodeRep )
+import CgBindery       ( getArgAmodes, bindNewToNode,
+                         bindArgsToRegs, 
+                         idInfoToAmode, stableAmodeIdInfo,
+                         heapIdInfo, CgIdInfo, bindNewToStack
                        )
-import CgTailCall      ( performReturn, mkStaticAlgReturnCode )
-import CgUsages                ( getHpRelOffset )
-import CLabelInfo      ( CLabel, mkClosureLabel, mkInfoTableLabel,
-                          mkPhantomInfoTableLabel,
-                         mkConEntryLabel, mkStdEntryLabel
+import CgStackery      ( mkVirtStkOffsets, freeStackSlots, updateFrameSize )
+import CgUsages                ( getRealSp, getVirtSp, setRealAndVirtualSp,
+                         getSpRelOffset )
+import CgRetConv       ( assignRegs )
+import Constants       ( mAX_INTLIKE, mIN_INTLIKE, mAX_CHARLIKE, mIN_CHARLIKE,
+                         mIN_UPD_SIZE )
+import CgHeapery       ( allocDynClosure )
+import CgTailCall      ( performReturn, mkStaticAlgReturnCode,
+                         returnUnboxedTuple )
+import CLabel          ( mkClosureLabel )
+import ClosureInfo     ( mkConLFInfo, mkLFArgument, layOutDynConstr, 
+                         layOutStaticConstr, closureSize, mkStaticClosure
                        )
-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 CostCentre      ( currentOrSubsumedCCS, dontCareCCS, CostCentreStack,
+                         currentCCS )
+import DataCon         ( DataCon, dataConTag, 
+                         isUnboxedTupleCon, isNullaryDataCon, dataConWorkId, 
+                         dataConName, dataConRepArity
                        )
-import CmdLineOpts     ( GlobalSwitch(..) )
-import Maybes          ( maybeToBool, Maybe(..) )
-import PrimKind                ( PrimKind(..), isFloatingKind, getKindSize )
-import CostCentre
-import UniqSet         -- ( emptyUniqSet, UniqSet(..) )
+import Id              ( Id, idName, idPrimRep, isDeadBinder )
+import Literal         ( Literal(..) )
+import PrelInfo                ( maybeCharLikeCon, maybeIntLikeCon )
+import PrimRep         ( PrimRep(..), isFollowableRep )
+import Unique          ( Uniquable(..) )
 import Util
+import Outputable
+
+import List            ( partition )
 \end{code}
 
 %************************************************************************
@@ -78,237 +65,41 @@ import Util
 \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
+  = ASSERT( not (isDllConApp con args) )       -- checks for litlit args too
+    ASSERT( args `lengthIs` dataConRepArity con )
 
        -- LAY IT OUT
-    getAtomAmodes args         `thenFC` \ amodes ->
+    getArgAmodes args          `thenFC` \ amodes ->
 
     let
-       (closure_info, amodes_w_offsets)
-         = layOutStaticClosure name getAmodeKind amodes lf_info
+       name          = idName id
+       lf_info       = mkConLFInfo con
+       closure_label = mkClosureLabel name
+       (closure_info, amodes_w_offsets) 
+               = layOutStaticConstr con getAmodeRep amodes
+       caffy = any stgArgHasCafRefs args
     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`
+    absC (mkStaticClosure
+           closure_label
+           closure_info
+           dontCareCCS                 -- because it's static data
+           (map fst amodes_w_offsets)  -- Sorted into ptrs first, then nonptrs
+           caffy                       -- has CAF refs
+         )                                     `thenC`
+               -- NOTE: can't use idCafInfo instead of nonEmptySRT above,
+               -- because top-level constructors that were floated by
+               -- CorePrep don't have CafInfo attached.  The SRT is more
+               -- reliable.
 
        -- 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
+    returnFC (id, stableAmodeIdInfo id (CLbl closure_label PtrRep) 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                                          *
@@ -319,83 +110,90 @@ load up \tr{Node} and call \tr{Cons}'s entry code---not some special
 \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
+           -> CostCentreStack  -- Where to grab cost centre from;
+                               -- current CCS if currentOrSubsumedCCS
            -> 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
+
+-- 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) 
+buildDynCon binder cc con []
+  = returnFC (stableAmodeIdInfo binder
+                               (CLbl (mkClosureLabel (dataConName con)) PtrRep)
                                (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))
+buildDynCon binder cc con [arg_amode]
+  | maybeIntLikeCon con && in_range_int_lit arg_amode
+  = 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
 
-    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]
+  | maybeCharLikeCon con && in_range_char_lit arg_amode
+  = returnFC (stableAmodeIdInfo binder (CCharLike arg_amode) (mkConLFInfo con))
+  where
+    in_range_char_lit (CLit (MachChar val)) = val <= mAX_CHARLIKE && val >= mIN_CHARLIKE
+    in_range_char_lit _other_amode         = False
 \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
+  = allocDynClosure closure_info use_cc blame_cc amodes_w_offsets `thenFC` \ hp_off ->
+    returnFC (heapIdInfo binder hp_off lf_info)
   where
-    (closure_info, amodes_w_offsets)
-      = layOutDynClosure binder getAmodeKind args (mkConLFInfo con)
+    lf_info = mkConLFInfo con
+
+    (closure_info, amodes_w_offsets) = layOutDynConstr con getAmodeRep args
 
     use_cc     -- cost-centre to stick in the object
-      = if currentOrSubsumedCosts cc
+      = if currentOrSubsumedCCS ccs
        then CReg CurCostCentre
-       else mkCCostCentre cc
+       else mkCCostCentreStack ccs
 
     blame_cc = use_cc -- cost-centre on which to blame the alloc (same)
 \end{code}
@@ -414,20 +212,69 @@ binders $args$, assuming that we have just returned from a @case@ which
 found a $con$.
 
 \begin{code}
-bindConArgs :: DataCon -> [Id] -> Code
+bindConArgs 
+       :: DataCon -> [Id]              -- Constructor and args
+       -> 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
+  = ASSERT(not (isUnboxedTupleCon con))
+    mapCs bind_arg args_w_offsets
    where
-     bind_arg (arg, offset) = bindNewToNode arg offset mkLFArgument
+     bind_arg (arg, offset) = bindNewToNode arg offset (mkLFArgument arg)
+     (_, args_w_offsets)    = layOutDynConstr con idPrimRep args
 \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]                         -- Aargs
+       -> FCode ([MagicId],            -- Regs assigned
+                 Int,                  -- Number of pointer stack slots
+                 Int,                  -- Number of non-pointer stack slots
+                 VirtualSpOffset)      -- Offset of return address slot
+                                       -- (= realSP on entry)
+
+bindUnboxedTupleComponents args
+ =      -- Assign as many components as possible to registers
+    let (arg_regs, _leftovers) = assignRegs [] (map idPrimRep args)
+       (reg_args, stk_args)   = splitAtList arg_regs args
+
+       -- separate the rest of the args into pointers and non-pointers
+       (ptr_args, nptr_args) = 
+          partition (isFollowableRep . idPrimRep) stk_args
+    in
+  
+    -- Allocate the rest on the stack
+    -- The real SP points to the return address, above which any 
+    -- leftover unboxed-tuple components will be allocated
+    getVirtSp `thenFC` \ vsp ->
+    getRealSp `thenFC` \ rsp ->
+    let 
+       (ptr_sp,  ptr_offsets)  = mkVirtStkOffsets rsp    idPrimRep ptr_args
+       (nptr_sp, nptr_offsets) = mkVirtStkOffsets ptr_sp idPrimRep nptr_args
+        ptrs  = ptr_sp - rsp
+       nptrs = nptr_sp - ptr_sp
+    in
+
+    -- The stack pointer points to the last stack-allocated component
+    setRealAndVirtualSp nptr_sp                `thenC`
+
+    -- 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]                `thenC`
+
+    bindArgsToRegs reg_args arg_regs           `thenC`
+    mapCs bindNewToStack ptr_offsets           `thenC`
+    mapCs bindNewToStack nptr_offsets          `thenC`
+
+    returnFC (arg_regs, ptrs, nptrs, rsp)
+\end{code}
 
 %************************************************************************
 %*                                                                     *
@@ -439,17 +286,17 @@ 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 -> PlainStgLiveVars -> Code
+cgReturnDataCon :: DataCon -> [CAddrMode] -> Code
 
-cgReturnDataCon con amodes all_zero_size_args live_vars
-  = ASSERT(isDataCon con)
-    getEndOfBlockInfo          `thenFC` \ (EndOfBlockInfo args_spa args_spb sequel) ->
+cgReturnDataCon con amodes
+  = ASSERT( amodes `lengthIs` dataConRepArity con )
+    getEndOfBlockInfo  `thenFC` \ (EndOfBlockInfo args_sp sequel) ->
 
     case sequel of
 
-      CaseAlts _ (Just (alts, Just (maybe_deflt_binder, (_,deflt_lbl))))
-       | not (getDataConTag con `is_elem` map fst alts)
-       ->      
+      CaseAlts _ (Just (alts, Just (deflt_bndr, (_,deflt_lbl)))) False
+       | not (dataConTag con `is_elem` map fst alts)
+       ->
                -- Special case!  We're returning a constructor to the default case
                -- of an enclosing case.  For example:
                --
@@ -457,59 +304,42 @@ cgReturnDataCon con amodes all_zero_size_args live_vars
                --        D x -> ...
                --        y   -> ...<returning here!>...
                --
-               -- In this case, 
+               -- 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
+
+               if isDeadBinder deflt_bndr
+               then performReturn AbsCNop {- No reg assts -} jump_to_join_point
+               else build_it_then jump_to_join_point
        where
          is_elem = isIn "cgReturnDataCon"
-         jump_to_join_point sequel = absC (CJump (CLbl deflt_lbl CodePtrKind))
+         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 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
+      other_sequel     -- The usual case
+         | isUnboxedTupleCon con -> returnUnboxedTuple amodes
+          | otherwise ->            build_it_then (mkStaticAlgReturnCode con)
+
   where
     move_to_reg :: CAddrMode -> MagicId -> AbstractC
     move_to_reg src_amode dest_reg = CAssign (CReg dest_reg) src_amode
+
+    build_it_then return =
+               -- 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' :-)
+         buildDynCon (dataConWorkId con) currentCCS con amodes `thenFC` \ idinfo ->
+         idInfoToAmode PtrRep idinfo                           `thenFC` \ amode ->
+
+
+               -- RETURN
+         profCtrC FSLIT("TICK_RET_NEW") [mkIntCLit (length amodes)] `thenC`
+         -- could use doTailCall here.
+         performReturn (move_to_reg amode node) return
 \end{code}