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       ( mkTaggedVirtStkOffsets, freeStackSlots,
  30                           updateFrameSize
  31                         )
  32 import CgUsages         ( getRealSp, getVirtSp, setRealAndVirtualSp,
  33                           getSpRelOffset )
  34 import CgRetConv        ( assignRegs )
  35 import Constants        ( mAX_INTLIKE, mIN_INTLIKE, mAX_CHARLIKE, mIN_CHARLIKE,
  36                           mIN_UPD_SIZE )
  37 import CgHeapery        ( allocDynClosure, inPlaceAllocDynClosure )
  38 import CgTailCall       ( performReturn, mkStaticAlgReturnCode, doTailCall,
  39                           mkUnboxedTupleReturnCode )
  40 import CLabel           ( mkClosureLabel )
  41 import ClosureInfo      ( mkConLFInfo, mkLFArgument, closureLFInfo,
  42                           layOutDynConstr, layOutDynClosure,
  43                           layOutStaticConstr, closureSize, mkStaticClosure
  44                         )
  45 import CostCentre       ( currentOrSubsumedCCS, dontCareCCS, CostCentreStack,
  46                           currentCCS )
  47 import DataCon          ( DataCon, dataConName, dataConTag,
  48                           isUnboxedTupleCon, isNullaryDataCon, dataConId,
  49                           dataConWrapId, dataConRepArity
  50                         )
  51 import Id               ( Id, idName, idPrimRep, idCafInfo )
  52 import IdInfo           ( mayHaveCafRefs )
  53 import Literal          ( Literal(..) )
  54 import PrelInfo         ( maybeCharLikeCon, maybeIntLikeCon )
  55 import PrimRep          ( PrimRep(..), isFollowableRep )
  56 import Unique           ( Uniquable(..) )
  57 import Util
  58 import Outputable
  59 \end{code}
  60
  61 %************************************************************************
  62 %*                                                                      *
  63 \subsection[toplevel-constructors]{Top-level constructors}
  64 %*                                                                      *
  65 %************************************************************************
  66
  67 \begin{code}
  68 cgTopRhsCon :: Id               -- Name of thing bound to this RHS
  69             -> DataCon          -- Id
  70             -> [StgArg]         -- Args
  71             -> SRT
  72             -> FCode (Id, CgIdInfo)
  73 cgTopRhsCon id con args srt
  74   = ASSERT( not (isDllConApp con args) )        -- checks for litlit args too
  75     ASSERT( args `lengthIs` dataConRepArity con )
  76
  77         -- LAY IT OUT
  78     getArgAmodes args           `thenFC` \ amodes ->
  79
  80     let
  81         name          = idName id
  82         lf_info       = closureLFInfo closure_info
  83         closure_label = mkClosureLabel name
  84         (closure_info, amodes_w_offsets)
  85                 = layOutStaticConstr name con getAmodeRep amodes
  86     in
  87
  88         -- BUILD THE OBJECT
  89     absC (mkStaticClosure
  90             closure_info
  91             dontCareCCS                 -- because it's static data
  92             (map fst amodes_w_offsets)  -- Sorted into ptrs first, then nonptrs
  93             (nonEmptySRT srt)           -- has CAF refs
  94           )                                     `thenC`
  95                 -- NOTE: can't use idCafInfo instead of nonEmptySRT above,
  96                 -- because top-level constructors that were floated by
  97                 -- CorePrep don't have CafInfo attached.  The SRT is more
  98                 -- reliable.
  99
 100         -- RETURN
 101     returnFC (id, stableAmodeIdInfo id (CLbl closure_label PtrRep) lf_info)
 102 \end{code}
 103
 104 %************************************************************************
 105 %*                                                                      *
 106 %* non-top-level constructors                                           *
 107 %*                                                                      *
 108 %************************************************************************
 109 \subsection[code-for-constructors]{The code for constructors}
 110
 111 \begin{code}
 112 buildDynCon :: Id               -- Name of the thing to which this constr will
 113                                 -- be bound
 114             -> CostCentreStack  -- Where to grab cost centre from;
 115                                 -- current CCS if currentOrSubsumedCCS
 116             -> DataCon          -- The data constructor
 117             -> [CAddrMode]      -- Its args
 118             -> FCode CgIdInfo   -- Return details about how to find it
 119
 120 -- We used to pass a boolean indicating whether all the
 121 -- args were of size zero, so we could use a static
 122 -- construtor; but I concluded that it just isn't worth it.
 123 -- Now I/O uses unboxed tuples there just aren't any constructors
 124 -- with all size-zero args.
 125 --
 126 -- The reason for having a separate argument, rather than looking at
 127 -- the addr modes of the args is that we may be in a "knot", and
 128 -- premature looking at the args will cause the compiler to black-hole!
 129 \end{code}
 130
 131 First we deal with the case of zero-arity constructors.  Now, they
 132 will probably be unfolded, so we don't expect to see this case much,
 133 if at all, but it does no harm, and sets the scene for characters.
 134
 135 In the case of zero-arity constructors, or, more accurately, those
 136 which have exclusively size-zero (VoidRep) args, we generate no code
 137 at all.
 138
 139 \begin{code}
 140 buildDynCon binder cc con []
 141   = returnFC (stableAmodeIdInfo binder
 142                                 (CLbl (mkClosureLabel (idName (dataConWrapId con))) PtrRep)
 143                                 (mkConLFInfo con))
 144 \end{code}
 145
 146 The following three paragraphs about @Char@-like and @Int@-like
 147 closures are obsolete, but I don't understand the details well enough
 148 to properly word them, sorry. I've changed the treatment of @Char@s to
 149 be analogous to @Int@s: only a subset is preallocated, because @Char@
 150 has now 31 bits. Only literals are handled here. -- Qrczak
 151
 152 Now for @Char@-like closures.  We generate an assignment of the
 153 address of the closure to a temporary.  It would be possible simply to
 154 generate no code, and record the addressing mode in the environment,
 155 but we'd have to be careful if the argument wasn't a constant --- so
 156 for simplicity we just always asssign to a temporary.
 157
 158 Last special case: @Int@-like closures.  We only special-case the
 159 situation in which the argument is a literal in the range
 160 @mIN_INTLIKE@..@mAX_INTLILKE@.  NB: for @Char@-like closures we can
 161 work with any old argument, but for @Int@-like ones the argument has
 162 to be a literal.  Reason: @Char@ like closures have an argument type
 163 which is guaranteed in range.
 164
 165 Because of this, we use can safely return an addressing mode.
 166
 167 \begin{code}
 168 buildDynCon binder cc con [arg_amode]
 169   | maybeIntLikeCon con && in_range_int_lit arg_amode
 170   = returnFC (stableAmodeIdInfo binder (CIntLike arg_amode) (mkConLFInfo con))
 171   where
 172     in_range_int_lit (CLit (MachInt val)) = val <= mAX_INTLIKE && val >= mIN_INTLIKE
 173     in_range_int_lit _other_amode         = False
 174
 175 buildDynCon binder cc con [arg_amode]
 176   | maybeCharLikeCon con && in_range_char_lit arg_amode
 177   = returnFC (stableAmodeIdInfo binder (CCharLike arg_amode) (mkConLFInfo con))
 178   where
 179     in_range_char_lit (CLit (MachChar val)) = val <= mAX_CHARLIKE && val >= mIN_CHARLIKE
 180     in_range_char_lit _other_amode          = False
 181 \end{code}
 182
 183 Now the general case.
 184
 185 \begin{code}
 186 buildDynCon binder ccs con args
 187   = allocDynClosure closure_info use_cc blame_cc amodes_w_offsets `thenFC` \ hp_off ->
 188     returnFC (heapIdInfo binder hp_off lf_info)
 189   where
 190     (closure_info, amodes_w_offsets)
 191       = layOutDynClosure (idName binder) getAmodeRep args lf_info NoC_SRT
 192     lf_info = mkConLFInfo con
 193
 194     use_cc      -- cost-centre to stick in the object
 195       = if currentOrSubsumedCCS ccs
 196         then CReg CurCostCentre
 197         else mkCCostCentreStack ccs
 198
 199     blame_cc = use_cc -- cost-centre on which to blame the alloc (same)
 200 \end{code}
 201
 202
 203 %************************************************************************
 204 %*                                                                      *
 205 %* constructor-related utility function:                                *
 206 %*              bindConArgs is called from cgAlt of a case              *
 207 %*                                                                      *
 208 %************************************************************************
 209 \subsection[constructor-utilities]{@bindConArgs@: constructor-related utility}
 210
 211 @bindConArgs@ $con args$ augments the environment with bindings for the
 212 binders $args$, assuming that we have just returned from a @case@ which
 213 found a $con$.
 214
 215 \begin{code}
 216 bindConArgs
 217         :: DataCon -> [Id]              -- Constructor and args
 218         -> Code
 219
 220 bindConArgs con args
 221   = ASSERT(not (isUnboxedTupleCon con))
 222     mapCs bind_arg args_w_offsets
 223    where
 224      bind_arg (arg, offset) = bindNewToNode arg offset mkLFArgument
 225      (_, args_w_offsets)    = layOutDynConstr bogus_name con idPrimRep args
 226
 227 bogus_name = panic "bindConArgs"
 228 \end{code}
 229
 230 Unboxed tuples are handled slightly differently - the object is
 231 returned in registers and on the stack instead of the heap.
 232
 233 \begin{code}
 234 bindUnboxedTupleComponents
 235         :: [Id]                                 -- args
 236         -> FCode ([MagicId],                    -- regs assigned
 237                   [(VirtualSpOffset,Int)],      -- tag slots
 238                   Bool)                         -- any components on stack?
 239
 240 bindUnboxedTupleComponents args
 241  =  -- Assign as many components as possible to registers
 242     let (arg_regs, _leftovers) = assignRegs [] (map idPrimRep args)
 243         (reg_args, stk_args)   = splitAtList arg_regs args
 244     in
 245
 246     -- Allocate the rest on the stack (ToDo: separate out pointers)
 247     getVirtSp `thenFC` \ vsp ->
 248     getRealSp `thenFC` \ rsp ->
 249     let (top_sp, stk_offsets, tags) =
 250                 mkTaggedVirtStkOffsets rsp idPrimRep stk_args
 251     in
 252
 253     -- The stack pointer points to the last stack-allocated component
 254     setRealAndVirtualSp top_sp                  `thenC`
 255
 256     -- need to explicitly free any empty slots we just jumped over
 257     (if vsp < rsp then freeStackSlots [vsp+1 .. rsp] else nopC) `thenC`
 258
 259     bindArgsToRegs reg_args arg_regs            `thenC`
 260     mapCs bindNewToStack stk_offsets            `thenC`
 261     returnFC (arg_regs,tags, not (null stk_offsets))
 262 \end{code}
 263
 264 %************************************************************************
 265 %*                                                                      *
 266 \subsubsection[CgRetConv-cgReturnDataCon]{Actually generate code for a constructor return}
 267 %*                                                                      *
 268 %************************************************************************
 269
 270
 271 Note: it's the responsibility of the @cgReturnDataCon@ caller to be
 272 sure the @amodes@ passed don't conflict with each other.
 273 \begin{code}
 274 cgReturnDataCon :: DataCon -> [CAddrMode] -> Code
 275
 276 cgReturnDataCon con amodes
 277   = ASSERT( amodes `lengthIs` dataConRepArity con )
 278     getEndOfBlockInfo   `thenFC` \ (EndOfBlockInfo args_sp sequel) ->
 279
 280     case sequel of
 281
 282       CaseAlts _ (Just (alts, Just (maybe_deflt, (_,deflt_lbl))))
 283         | not (dataConTag con `is_elem` map fst alts)
 284         ->
 285                 -- Special case!  We're returning a constructor to the default case
 286                 -- of an enclosing case.  For example:
 287                 --
 288                 --      case (case e of (a,b) -> C a b) of
 289                 --        D x -> ...
 290                 --        y   -> ...<returning here!>...
 291                 --
 292                 -- In this case,
 293                 --      if the default is a non-bind-default (ie does not use y),
 294                 --      then we should simply jump to the default join point;
 295
 296                 case maybe_deflt of
 297                     Nothing -> performReturn AbsCNop {- No reg assts -} jump_to_join_point
 298                     Just _  -> build_it_then jump_to_join_point
 299         where
 300           is_elem = isIn "cgReturnDataCon"
 301           jump_to_join_point sequel = absC (CJump (CLbl deflt_lbl CodePtrRep))
 302                 -- Ignore the sequel: we've already looked at it above
 303
 304         -- If the sequel is an update frame, we might be able to
 305         -- do update in place...
 306       UpdateCode
 307         |  not (isNullaryDataCon con)  -- no nullary constructors, please
 308         && not (any isFollowableRep (map getAmodeRep amodes))
 309                                         -- no ptrs please (generational gc...)
 310         && closureSize closure_info <= mIN_UPD_SIZE
 311                                         -- don't know the real size of the
 312                                         -- thunk, so assume mIN_UPD_SIZE
 313
 314         ->      -- get a new temporary and make it point to the updatee
 315            let
 316                 uniq = getUnique con
 317                 temp = CTemp uniq PtrRep
 318            in
 319
 320            profCtrC SLIT("TICK_UPD_CON_IN_PLACE")
 321                         [mkIntCLit (length amodes)] `thenC`
 322
 323            getSpRelOffset args_sp                       `thenFC` \ sp_rel ->
 324            absC (CAssign temp
 325                     (CMacroExpr PtrRep UPD_FRAME_UPDATEE [CAddr sp_rel]))
 326                 `thenC`
 327
 328                 -- stomp all over it with the new constructor
 329            inPlaceAllocDynClosure closure_info temp (CReg CurCostCentre) stuff
 330                 `thenC`
 331
 332                 -- don't forget to update Su from the update frame
 333            absC (CMacroStmt UPDATE_SU_FROM_UPD_FRAME [CAddr sp_rel])  `thenC`
 334
 335                 -- set Node to point to the closure being returned
 336                 -- (can't be done earlier: node might conflict with amodes)
 337            absC (CAssign (CReg node) temp) `thenC`
 338
 339                 -- pop the update frame off the stack, and do the proper
 340                 -- return.
 341            let new_sp = args_sp - updateFrameSize in
 342            setEndOfBlockInfo (EndOfBlockInfo new_sp (OnStack new_sp)) $
 343            performReturn (AbsCNop) (mkStaticAlgReturnCode con)
 344
 345         where
 346            (closure_info, stuff)
 347                   = layOutDynConstr (dataConName con) con getAmodeRep amodes
 348
 349       other_sequel      -- The usual case
 350
 351           | isUnboxedTupleCon con ->
 352                         -- Return unboxed tuple in registers
 353                   let (ret_regs, leftovers) =
 354                          assignRegs [] (map getAmodeRep amodes)
 355                   in
 356                   profCtrC SLIT("TICK_RET_UNBOXED_TUP")
 357                                 [mkIntCLit (length amodes)] `thenC`
 358
 359                   doTailCall amodes ret_regs
 360                         mkUnboxedTupleReturnCode
 361                         (length leftovers)  {- fast args arity -}
 362                         AbsCNop {-no pending assigments-}
 363                         Nothing {-not a let-no-escape-}
 364                         False   {-node doesn't point-}
 365
 366           | otherwise ->
 367                 build_it_then (mkStaticAlgReturnCode con)
 368
 369   where
 370     move_to_reg :: CAddrMode -> MagicId -> AbstractC
 371     move_to_reg src_amode dest_reg = CAssign (CReg dest_reg) src_amode
 372
 373     build_it_then return =
 374                 -- BUILD THE OBJECT IN THE HEAP
 375                 -- The first "con" says that the name bound to this
 376                 -- closure is "con", which is a bit of a fudge, but it only
 377                 -- affects profiling
 378
 379                 -- This Id is also used to get a unique for a
 380                 -- temporary variable, if the closure is a CHARLIKE.
 381                 -- funnily enough, this makes the unique always come
 382                 -- out as '54' :-)
 383           buildDynCon (dataConId con) currentCCS con amodes     `thenFC` \ idinfo ->
 384           idInfoToAmode PtrRep idinfo                           `thenFC` \ amode ->
 385
 386
 387                 -- RETURN
 388           profCtrC SLIT("TICK_RET_NEW") [mkIntCLit (length amodes)] `thenC`
 389           -- could use doTailCall here.
 390           performReturn (move_to_reg amode node) return
 391 \end{code}