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