ghc/compiler/codeGen/CgCon.lhs

   1 %
   2 % (c) The GRASP Project, Glasgow University, 1992-1998
   3 %
   4 \section[CgCon]{Code generation for constructors}
   5
   6 This module provides the support code for @StgToAbstractC@ to deal
   7 with {\em constructors} on the RHSs of let(rec)s.  See also
   8 @CgClosure@, which deals with closures.
   9
  10 \begin{code}
  11 module CgCon (
  12         cgTopRhsCon, buildDynCon,
  13         bindConArgs, bindUnboxedTupleComponents,
  14         cgReturnDataCon
  15     ) where
  16
  17 #include "HsVersions.h"
  18
  19 import CgMonad
  20 import AbsCSyn
  21 import StgSyn
  22
  23 import AbsCUtils        ( getAmodeRep )
  24 import CgBindery        ( getArgAmodes, bindNewToNode,
  25                           bindArgsToRegs,
  26                           idInfoToAmode, stableAmodeIdInfo,
  27                           heapIdInfo, CgIdInfo, bindNewToStack
  28                         )
  29 import CgStackery       ( mkVirtStkOffsets, freeStackSlots )
  30 import CgUsages         ( getRealSp, getVirtSp, setRealAndVirtualSp )
  31 import CgRetConv        ( assignRegs )
  32 import Constants        ( mAX_INTLIKE, mIN_INTLIKE, mAX_CHARLIKE, mIN_CHARLIKE )
  33 import CgHeapery        ( allocDynClosure )
  34 import CgTailCall       ( performReturn, mkStaticAlgReturnCode,
  35                           returnUnboxedTuple )
  36 import CLabel           ( mkClosureLabel )
  37 import ClosureInfo      ( mkConLFInfo, mkLFArgument, layOutDynConstr,
  38                           layOutStaticConstr, mkStaticClosure
  39                         )
  40 import CostCentre       ( currentOrSubsumedCCS, dontCareCCS, CostCentreStack,
  41                           currentCCS )
  42 import DataCon          ( DataCon, dataConTag,
  43                           isUnboxedTupleCon, dataConWorkId,
  44                           dataConName, dataConRepArity
  45                         )
  46 import Id               ( Id, idName, idPrimRep, isDeadBinder )
  47 import Literal          ( Literal(..) )
  48 import PrelInfo         ( maybeCharLikeCon, maybeIntLikeCon )
  49 import PrimRep          ( PrimRep(..), isFollowableRep )
  50 import Util
  51 import Outputable
  52
  53 import List             ( partition )
  54 \end{code}
  55
  56 %************************************************************************
  57 %*                                                                      *
  58 \subsection[toplevel-constructors]{Top-level constructors}
  59 %*                                                                      *
  60 %************************************************************************
  61
  62 \begin{code}
  63 cgTopRhsCon :: Id               -- Name of thing bound to this RHS
  64             -> DataCon          -- Id
  65             -> [StgArg]         -- Args
  66             -> FCode (Id, CgIdInfo)
  67 cgTopRhsCon id con args
  68   = ASSERT( not (isDllConApp con args) )
  69     ASSERT( args `lengthIs` dataConRepArity con )
  70
  71         -- LAY IT OUT
  72     getArgAmodes args           `thenFC` \ amodes ->
  73
  74     let
  75         name          = idName id
  76         lf_info       = mkConLFInfo con
  77         closure_label = mkClosureLabel name
  78         (closure_info, amodes_w_offsets)
  79                 = layOutStaticConstr con getAmodeRep amodes
  80         caffy = any stgArgHasCafRefs args
  81     in
  82
  83         -- BUILD THE OBJECT
  84     absC (mkStaticClosure
  85             closure_label
  86             closure_info
  87             dontCareCCS                 -- because it's static data
  88             (map fst amodes_w_offsets)  -- Sorted into ptrs first, then nonptrs
  89             caffy                       -- has CAF refs
  90           )                                     `thenC`
  91                 -- NOTE: can't use idCafInfo instead of nonEmptySRT above,
  92                 -- because top-level constructors that were floated by
  93                 -- CorePrep don't have CafInfo attached.  The SRT is more
  94                 -- reliable.
  95
  96         -- RETURN
  97     returnFC (id, stableAmodeIdInfo id (CLbl closure_label PtrRep) lf_info)
  98 \end{code}
  99
 100 %************************************************************************
 101 %*                                                                      *
 102 %* non-top-level constructors                                           *
 103 %*                                                                      *
 104 %************************************************************************
 105 \subsection[code-for-constructors]{The code for constructors}
 106
 107 \begin{code}
 108 buildDynCon :: Id               -- Name of the thing to which this constr will
 109                                 -- be bound
 110             -> CostCentreStack  -- Where to grab cost centre from;
 111                                 -- current CCS if currentOrSubsumedCCS
 112             -> DataCon          -- The data constructor
 113             -> [CAddrMode]      -- Its args
 114             -> FCode CgIdInfo   -- Return details about how to find it
 115
 116 -- We used to pass a boolean indicating whether all the
 117 -- args were of size zero, so we could use a static
 118 -- construtor; but I concluded that it just isn't worth it.
 119 -- Now I/O uses unboxed tuples there just aren't any constructors
 120 -- with all size-zero args.
 121 --
 122 -- The reason for having a separate argument, rather than looking at
 123 -- the addr modes of the args is that we may be in a "knot", and
 124 -- premature looking at the args will cause the compiler to black-hole!
 125 \end{code}
 126
 127 First we deal with the case of zero-arity constructors.  Now, they
 128 will probably be unfolded, so we don't expect to see this case much,
 129 if at all, but it does no harm, and sets the scene for characters.
 130
 131 In the case of zero-arity constructors, or, more accurately, those
 132 which have exclusively size-zero (VoidRep) args, we generate no code
 133 at all.
 134
 135 \begin{code}
 136 buildDynCon binder cc con []
 137   = returnFC (stableAmodeIdInfo binder
 138                                 (CLbl (mkClosureLabel (dataConName con)) PtrRep)
 139                                 (mkConLFInfo con))
 140 \end{code}
 141
 142 The following three paragraphs about @Char@-like and @Int@-like
 143 closures are obsolete, but I don't understand the details well enough
 144 to properly word them, sorry. I've changed the treatment of @Char@s to
 145 be analogous to @Int@s: only a subset is preallocated, because @Char@
 146 has now 31 bits. Only literals are handled here. -- Qrczak
 147
 148 Now for @Char@-like closures.  We generate an assignment of the
 149 address of the closure to a temporary.  It would be possible simply to
 150 generate no code, and record the addressing mode in the environment,
 151 but we'd have to be careful if the argument wasn't a constant --- so
 152 for simplicity we just always asssign to a temporary.
 153
 154 Last special case: @Int@-like closures.  We only special-case the
 155 situation in which the argument is a literal in the range
 156 @mIN_INTLIKE@..@mAX_INTLILKE@.  NB: for @Char@-like closures we can
 157 work with any old argument, but for @Int@-like ones the argument has
 158 to be a literal.  Reason: @Char@ like closures have an argument type
 159 which is guaranteed in range.
 160
 161 Because of this, we use can safely return an addressing mode.
 162
 163 \begin{code}
 164 buildDynCon binder cc con [arg_amode]
 165   | maybeIntLikeCon con && in_range_int_lit arg_amode
 166   = returnFC (stableAmodeIdInfo binder (CIntLike arg_amode) (mkConLFInfo con))
 167   where
 168     in_range_int_lit (CLit (MachInt val)) = val <= mAX_INTLIKE && val >= mIN_INTLIKE
 169     in_range_int_lit _other_amode         = False
 170
 171 buildDynCon binder cc con [arg_amode]
 172   | maybeCharLikeCon con && in_range_char_lit arg_amode
 173   = returnFC (stableAmodeIdInfo binder (CCharLike arg_amode) (mkConLFInfo con))
 174   where
 175     in_range_char_lit (CLit (MachChar val)) = val <= mAX_CHARLIKE && val >= mIN_CHARLIKE
 176     in_range_char_lit _other_amode          = False
 177 \end{code}
 178
 179 Now the general case.
 180
 181 \begin{code}
 182 buildDynCon binder ccs con args
 183   = allocDynClosure closure_info use_cc blame_cc amodes_w_offsets `thenFC` \ hp_off ->
 184     returnFC (heapIdInfo binder hp_off lf_info)
 185   where
 186     lf_info = mkConLFInfo con
 187
 188     (closure_info, amodes_w_offsets) = layOutDynConstr con getAmodeRep args
 189
 190     use_cc      -- cost-centre to stick in the object
 191       = if currentOrSubsumedCCS ccs
 192         then CReg CurCostCentre
 193         else mkCCostCentreStack ccs
 194
 195     blame_cc = use_cc -- cost-centre on which to blame the alloc (same)
 196 \end{code}
 197
 198
 199 %************************************************************************
 200 %*                                                                      *
 201 %* constructor-related utility function:                                *
 202 %*              bindConArgs is called from cgAlt of a case              *
 203 %*                                                                      *
 204 %************************************************************************
 205 \subsection[constructor-utilities]{@bindConArgs@: constructor-related utility}
 206
 207 @bindConArgs@ $con args$ augments the environment with bindings for the
 208 binders $args$, assuming that we have just returned from a @case@ which
 209 found a $con$.
 210
 211 \begin{code}
 212 bindConArgs
 213         :: DataCon -> [Id]              -- Constructor and args
 214         -> Code
 215
 216 bindConArgs con args
 217   = ASSERT(not (isUnboxedTupleCon con))
 218     mapCs bind_arg args_w_offsets
 219    where
 220      bind_arg (arg, offset) = bindNewToNode arg offset (mkLFArgument arg)
 221      (_, args_w_offsets)    = layOutDynConstr con idPrimRep args
 222 \end{code}
 223
 224 Unboxed tuples are handled slightly differently - the object is
 225 returned in registers and on the stack instead of the heap.
 226
 227 \begin{code}
 228 bindUnboxedTupleComponents
 229         :: [Id]                         -- Aargs
 230         -> FCode ([MagicId],            -- Regs assigned
 231                   Int,                  -- Number of pointer stack slots
 232                   Int,                  -- Number of non-pointer stack slots
 233                   VirtualSpOffset)      -- Offset of return address slot
 234                                         -- (= realSP on entry)
 235
 236 bindUnboxedTupleComponents args
 237  =      -- Assign as many components as possible to registers
 238     let (arg_regs, _leftovers) = assignRegs [] (map idPrimRep args)
 239         (reg_args, stk_args)   = splitAtList arg_regs args
 240
 241         -- separate the rest of the args into pointers and non-pointers
 242         (ptr_args, nptr_args) =
 243            partition (isFollowableRep . idPrimRep) stk_args
 244     in
 245
 246     -- Allocate the rest on the stack
 247     -- The real SP points to the return address, above which any
 248     -- leftover unboxed-tuple components will be allocated
 249     getVirtSp `thenFC` \ vsp ->
 250     getRealSp `thenFC` \ rsp ->
 251     let
 252         (ptr_sp,  ptr_offsets)  = mkVirtStkOffsets rsp    idPrimRep ptr_args
 253         (nptr_sp, nptr_offsets) = mkVirtStkOffsets ptr_sp idPrimRep nptr_args
 254         ptrs  = ptr_sp - rsp
 255         nptrs = nptr_sp - ptr_sp
 256     in
 257
 258     -- The stack pointer points to the last stack-allocated component
 259     setRealAndVirtualSp nptr_sp                 `thenC`
 260
 261     -- We have just allocated slots starting at real SP + 1, and set the new
 262     -- virtual SP to the topmost allocated slot.
 263     -- If the virtual SP started *below* the real SP, we've just jumped over
 264     -- some slots that won't be in the free-list, so put them there
 265     -- This commonly happens because we've freed the return-address slot
 266     -- (trimming back the virtual SP), but the real SP still points to that slot
 267     freeStackSlots [vsp+1,vsp+2 .. rsp]         `thenC`
 268
 269     bindArgsToRegs reg_args arg_regs            `thenC`
 270     mapCs bindNewToStack ptr_offsets            `thenC`
 271     mapCs bindNewToStack nptr_offsets           `thenC`
 272
 273     returnFC (arg_regs, ptrs, nptrs, rsp)
 274 \end{code}
 275
 276 %************************************************************************
 277 %*                                                                      *
 278 \subsubsection[CgRetConv-cgReturnDataCon]{Actually generate code for a constructor return}
 279 %*                                                                      *
 280 %************************************************************************
 281
 282
 283 Note: it's the responsibility of the @cgReturnDataCon@ caller to be
 284 sure the @amodes@ passed don't conflict with each other.
 285 \begin{code}
 286 cgReturnDataCon :: DataCon -> [CAddrMode] -> Code
 287
 288 cgReturnDataCon con amodes
 289   = ASSERT( amodes `lengthIs` dataConRepArity con )
 290     getEndOfBlockInfo   `thenFC` \ (EndOfBlockInfo args_sp sequel) ->
 291
 292     case sequel of
 293
 294       CaseAlts _ (Just (alts, Just (deflt_bndr, (_,deflt_lbl)))) False
 295         | not (dataConTag con `is_elem` map fst alts)
 296         ->
 297                 -- Special case!  We're returning a constructor to the default case
 298                 -- of an enclosing case.  For example:
 299                 --
 300                 --      case (case e of (a,b) -> C a b) of
 301                 --        D x -> ...
 302                 --        y   -> ...<returning here!>...
 303                 --
 304                 -- In this case,
 305                 --      if the default is a non-bind-default (ie does not use y),
 306                 --      then we should simply jump to the default join point;
 307
 308                 if isDeadBinder deflt_bndr
 309                 then performReturn AbsCNop {- No reg assts -} jump_to_join_point
 310                 else build_it_then jump_to_join_point
 311         where
 312           is_elem = isIn "cgReturnDataCon"
 313           jump_to_join_point sequel = absC (CJump (CLbl deflt_lbl CodePtrRep))
 314                 -- Ignore the sequel: we've already looked at it above
 315
 316       other_sequel      -- The usual case
 317           | isUnboxedTupleCon con -> returnUnboxedTuple amodes
 318           | otherwise ->             build_it_then (mkStaticAlgReturnCode con)
 319
 320   where
 321     move_to_reg :: CAddrMode -> MagicId -> AbstractC
 322     move_to_reg src_amode dest_reg = CAssign (CReg dest_reg) src_amode
 323
 324     build_it_then return =
 325                 -- BUILD THE OBJECT IN THE HEAP
 326                 -- The first "con" says that the name bound to this
 327                 -- closure is "con", which is a bit of a fudge, but it only
 328                 -- affects profiling
 329
 330                 -- This Id is also used to get a unique for a
 331                 -- temporary variable, if the closure is a CHARLIKE.
 332                 -- funnily enough, this makes the unique always come
 333                 -- out as '54' :-)
 334           buildDynCon (dataConWorkId con) currentCCS con amodes `thenFC` \ idinfo ->
 335           idInfoToAmode PtrRep idinfo                           `thenFC` \ amode ->
 336
 337
 338                 -- RETURN
 339           profCtrC FSLIT("TICK_RET_NEW") [mkIntCLit (length amodes)] `thenC`
 340           -- could use doTailCall here.
 341           performReturn (move_to_reg amode node) return
 342 \end{code}