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