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