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, newTempAmodeAndIdInfo,
  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 CgClosure        ( cgTopRhsClosure )
  35 import CgRetConv        ( assignRegs )
  36 import Constants        ( mAX_INTLIKE, mIN_INTLIKE, mIN_UPD_SIZE )
  37 import CgHeapery        ( allocDynClosure, inPlaceAllocDynClosure )
  38 import CgTailCall       ( performReturn, mkStaticAlgReturnCode, doTailCall,
  39                           mkUnboxedTupleReturnCode )
  40 import CLabel           ( mkClosureLabel )
  41 import ClosureInfo      ( mkClosureLFInfo, mkConLFInfo, mkLFArgument,
  42                           layOutDynCon, layOutDynClosure,
  43                           layOutStaticClosure, closureSize
  44                         )
  45 import CostCentre       ( currentOrSubsumedCCS, dontCareCCS, CostCentreStack,
  46                           currentCCS )
  47 import DataCon          ( DataCon, dataConName, dataConTag, dataConTyCon,
  48                           isUnboxedTupleCon, isNullaryDataCon, dataConId, dataConWrapId
  49                         )
  50 import Id               ( Id, idName, idType, idPrimRep )
  51 import Name             ( nameModule, isLocallyDefinedName )
  52 import Literal          ( Literal(..) )
  53 import PrelInfo         ( maybeCharLikeCon, maybeIntLikeCon )
  54 import PrimRep          ( PrimRep(..), isFollowableRep )
  55 import Unique           ( Uniquable(..) )
  56 import Util
  57 import Panic            ( assertPanic, trace )
  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             -> FCode (Id, CgIdInfo)
  71 cgTopRhsCon id con args
  72   = ASSERT(not dynamic_con_or_args)     -- checks for litlit args too
  73     (
  74         -- LAY IT OUT
  75     getArgAmodes args           `thenFC` \ amodes ->
  76
  77     let
  78         (closure_info, amodes_w_offsets)
  79           = layOutStaticClosure name getAmodeRep amodes lf_info
  80     in
  81
  82         -- BUILD THE OBJECT
  83     absC (CStaticClosure
  84             closure_label               -- Labelled with the name on lhs of defn
  85             closure_info                -- Closure is static
  86             top_ccc
  87             (map fst amodes_w_offsets)) -- Sorted into ptrs first, then nonptrs
  88
  89     ) `thenC`
  90
  91         -- RETURN
  92     returnFC (id, stableAmodeIdInfo id (CLbl closure_label PtrRep) lf_info)
  93   where
  94     lf_info         = mkConLFInfo    con
  95     closure_label   = mkClosureLabel name
  96     name            = idName id
  97
  98     top_ccc = mkCCostCentreStack dontCareCCS -- because it's static data
  99
 100     -- stuff needed by the assert pred only.
 101     dynamic_con_or_args = isDllConApp con args
 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 Now for @Char@-like closures.  We generate an assignment of the
 147 address of the closure to a temporary.  It would be possible simply to
 148 generate no code, and record the addressing mode in the environment,
 149 but we'd have to be careful if the argument wasn't a constant --- so
 150 for simplicity we just always asssign to a temporary.
 151
 152 Last special case: @Int@-like closures.  We only special-case the
 153 situation in which the argument is a literal in the range
 154 @mIN_INTLIKE@..@mAX_INTLILKE@.  NB: for @Char@-like closures we can
 155 work with any old argument, but for @Int@-like ones the argument has
 156 to be a literal.  Reason: @Char@ like closures have an argument type
 157 which is guaranteed in range.
 158
 159 Because of this, we use can safely return an addressing mode.
 160
 161 \begin{code}
 162 buildDynCon binder cc con [arg_amode]
 163
 164   | maybeCharLikeCon con
 165   = absC (CAssign temp_amode (CCharLike arg_amode))     `thenC`
 166     returnFC temp_id_info
 167
 168   | maybeIntLikeCon con && in_range_int_lit arg_amode
 169   = returnFC (stableAmodeIdInfo binder (CIntLike arg_amode) (mkConLFInfo con))
 170   where
 171     (temp_amode, temp_id_info) = newTempAmodeAndIdInfo binder (mkConLFInfo con)
 172
 173     in_range_int_lit (CLit (MachInt val)) = val <= mAX_INTLIKE && val >= mIN_INTLIKE
 174     in_range_int_lit other_amode          = False
 175 \end{code}
 176
 177 Now the general case.
 178
 179 \begin{code}
 180 buildDynCon binder ccs con args
 181   = allocDynClosure closure_info use_cc blame_cc amodes_w_offsets `thenFC` \ hp_off ->
 182     returnFC (heapIdInfo binder hp_off lf_info)
 183   where
 184     (closure_info, amodes_w_offsets)
 185       = layOutDynClosure (idName binder) getAmodeRep args lf_info
 186     lf_info = mkConLFInfo con
 187
 188     use_cc      -- cost-centre to stick in the object
 189       = if currentOrSubsumedCCS ccs
 190         then CReg CurCostCentre
 191         else mkCCostCentreStack ccs
 192
 193     blame_cc = use_cc -- cost-centre on which to blame the alloc (same)
 194 \end{code}
 195
 196
 197 %************************************************************************
 198 %*                                                                      *
 199 %* constructor-related utility function:                                *
 200 %*              bindConArgs is called from cgAlt of a case              *
 201 %*                                                                      *
 202 %************************************************************************
 203 \subsection[constructor-utilities]{@bindConArgs@: constructor-related utility}
 204
 205 @bindConArgs@ $con args$ augments the environment with bindings for the
 206 binders $args$, assuming that we have just returned from a @case@ which
 207 found a $con$.
 208
 209 \begin{code}
 210 bindConArgs
 211         :: DataCon -> [Id]              -- Constructor and args
 212         -> Code
 213
 214 bindConArgs con args
 215   = ASSERT(not (isUnboxedTupleCon con))
 216     mapCs bind_arg args_w_offsets
 217    where
 218      bind_arg (arg, offset) = bindNewToNode arg offset mkLFArgument
 219      (_, args_w_offsets) = layOutDynCon con idPrimRep args
 220 \end{code}
 221
 222 Unboxed tuples are handled slightly differently - the object is
 223 returned in registers and on the stack instead of the heap.
 224
 225 \begin{code}
 226 bindUnboxedTupleComponents
 227         :: [Id]                                 -- args
 228         -> FCode ([MagicId],                    -- regs assigned
 229                   [(VirtualSpOffset,Int)],      -- tag slots
 230                   Bool)                         -- any components on stack?
 231
 232 bindUnboxedTupleComponents args
 233  =  -- Assign as many components as possible to registers
 234     let (arg_regs, leftovers) = assignRegs [] (map idPrimRep args)
 235         (reg_args, stk_args) = splitAt (length arg_regs) args
 236     in
 237
 238     -- Allocate the rest on the stack (ToDo: separate out pointers)
 239     getVirtSp `thenFC` \ vsp ->
 240     getRealSp `thenFC` \ rsp ->
 241     let (top_sp, stk_offsets, tags) =
 242                 mkTaggedVirtStkOffsets rsp idPrimRep stk_args
 243     in
 244
 245     -- The stack pointer points to the last stack-allocated component
 246     setRealAndVirtualSp top_sp                  `thenC`
 247
 248     -- need to explicitly free any empty slots we just jumped over
 249     (if vsp < rsp then freeStackSlots [vsp+1 .. rsp] else nopC) `thenC`
 250
 251     bindArgsToRegs reg_args arg_regs            `thenC`
 252     mapCs bindNewToStack stk_offsets            `thenC`
 253     returnFC (arg_regs,tags, not (null stk_offsets))
 254 \end{code}
 255
 256 %************************************************************************
 257 %*                                                                      *
 258 \subsubsection[CgRetConv-cgReturnDataCon]{Actually generate code for a constructor return}
 259 %*                                                                      *
 260 %************************************************************************
 261
 262
 263 Note: it's the responsibility of the @cgReturnDataCon@ caller to be
 264 sure the @amodes@ passed don't conflict with each other.
 265 \begin{code}
 266 cgReturnDataCon :: DataCon -> [CAddrMode] -> Code
 267
 268 cgReturnDataCon con amodes
 269   = getEndOfBlockInfo   `thenFC` \ (EndOfBlockInfo args_sp sequel) ->
 270
 271     case sequel of
 272
 273       CaseAlts _ (Just (alts, Just (maybe_deflt, (_,deflt_lbl))))
 274         | not (dataConTag con `is_elem` map fst alts)
 275         ->
 276                 -- Special case!  We're returning a constructor to the default case
 277                 -- of an enclosing case.  For example:
 278                 --
 279                 --      case (case e of (a,b) -> C a b) of
 280                 --        D x -> ...
 281                 --        y   -> ...<returning here!>...
 282                 --
 283                 -- In this case,
 284                 --      if the default is a non-bind-default (ie does not use y),
 285                 --      then we should simply jump to the default join point;
 286
 287                 case maybe_deflt of
 288                     Nothing -> performReturn AbsCNop {- No reg assts -} jump_to_join_point
 289                     Just _  -> build_it_then jump_to_join_point
 290         where
 291           is_elem = isIn "cgReturnDataCon"
 292           jump_to_join_point sequel = absC (CJump (CLbl deflt_lbl CodePtrRep))
 293                 -- Ignore the sequel: we've already looked at it above
 294
 295         -- If the sequel is an update frame, we might be able to
 296         -- do update in place...
 297       UpdateCode
 298         |  not (isNullaryDataCon con)  -- no nullary constructors, please
 299         && not (maybeCharLikeCon con)  -- no chars please (these are all static)
 300         && not (any isFollowableRep (map getAmodeRep amodes))
 301                                         -- no ptrs please (generational gc...)
 302         && closureSize closure_info <= mIN_UPD_SIZE
 303                                         -- don't know the real size of the
 304                                         -- thunk, so assume mIN_UPD_SIZE
 305
 306         ->      -- get a new temporary and make it point to the updatee
 307            let
 308                 uniq = getUnique con
 309                 temp = CTemp uniq PtrRep
 310            in
 311
 312            profCtrC SLIT("TICK_UPD_CON_IN_PLACE")
 313                         [mkIntCLit (length amodes)] `thenC`
 314
 315            getSpRelOffset args_sp                       `thenFC` \ sp_rel ->
 316            absC (CAssign temp
 317                     (CMacroExpr PtrRep UPD_FRAME_UPDATEE [CAddr sp_rel]))
 318                 `thenC`
 319
 320                 -- stomp all over it with the new constructor
 321            inPlaceAllocDynClosure closure_info temp (CReg CurCostCentre) stuff
 322                 `thenC`
 323
 324                 -- don't forget to update Su from the update frame
 325            absC (CMacroStmt UPDATE_SU_FROM_UPD_FRAME [CAddr sp_rel])  `thenC`
 326
 327                 -- set Node to point to the closure being returned
 328                 -- (can't be done earlier: node might conflict with amodes)
 329            absC (CAssign (CReg node) temp) `thenC`
 330
 331                 -- pop the update frame off the stack, and do the proper
 332                 -- return.
 333            let new_sp = args_sp - updateFrameSize in
 334            setEndOfBlockInfo (EndOfBlockInfo new_sp (OnStack new_sp)) $
 335            performReturn (AbsCNop) (mkStaticAlgReturnCode con)
 336
 337         where (closure_info, stuff)
 338                   = layOutDynClosure (dataConName con)
 339                         getAmodeRep amodes lf_info
 340
 341               lf_info = mkConLFInfo con
 342
 343       other_sequel      -- The usual case
 344
 345           | isUnboxedTupleCon con ->
 346                         -- Return unboxed tuple in registers
 347                   let (ret_regs, leftovers) =
 348                          assignRegs [] (map getAmodeRep amodes)
 349                   in
 350                   profCtrC SLIT("TICK_RET_UNBOXED_TUP")
 351                                 [mkIntCLit (length amodes)] `thenC`
 352
 353                   doTailCall amodes ret_regs
 354                         mkUnboxedTupleReturnCode
 355                         (length leftovers)  {- fast args arity -}
 356                         AbsCNop {-no pending assigments-}
 357                         Nothing {-not a let-no-escape-}
 358                         False   {-node doesn't point-}
 359
 360           | otherwise ->
 361                 build_it_then (mkStaticAlgReturnCode con)
 362
 363   where
 364     move_to_reg :: CAddrMode -> MagicId -> AbstractC
 365     move_to_reg src_amode dest_reg = CAssign (CReg dest_reg) src_amode
 366
 367     build_it_then return =
 368                 -- BUILD THE OBJECT IN THE HEAP
 369                 -- The first "con" says that the name bound to this
 370                 -- closure is "con", which is a bit of a fudge, but it only
 371                 -- affects profiling
 372
 373                 -- This Id is also used to get a unique for a
 374                 -- temporary variable, if the closure is a CHARLIKE.
 375                 -- funnily enough, this makes the unique always come
 376                 -- out as '54' :-)
 377           buildDynCon (dataConId con) currentCCS con amodes     `thenFC` \ idinfo ->
 378           idInfoToAmode PtrRep idinfo                           `thenFC` \ amode ->
 379
 380
 381                 -- RETURN
 382           profCtrC SLIT("TICK_RET_NEW") [mkIntCLit (length amodes)] `thenC`
 383           -- could use doTailCall here.
 384           performReturn (move_to_reg amode node) return
 385 \end{code}