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, isDynDataCon, dataConId, dataConWrapId
  49                         )
  50 import Id               ( Id, idName, idType, idPrimRep )
  51 import Name             ( nameModule, isLocallyDefinedName )
  52 import Module           ( isDynamicModule )
  53 import Literal          ( Literal(..) )
  54 import PrelInfo         ( maybeCharLikeCon, maybeIntLikeCon )
  55 import PrimRep          ( PrimRep(..), isFollowableRep )
  56 import Unique           ( Uniquable(..) )
  57 import Util
  58 import Panic            ( assertPanic, trace )
  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 dynamic_con_or_args)     -- checks for litlit args too
  74     (
  75         -- LAY IT OUT
  76     getArgAmodes args           `thenFC` \ amodes ->
  77
  78     let
  79         (closure_info, amodes_w_offsets)
  80           = layOutStaticClosure name getAmodeRep amodes lf_info
  81     in
  82
  83         -- BUILD THE OBJECT
  84     absC (CStaticClosure
  85             closure_label               -- Labelled with the name on lhs of defn
  86             closure_info                -- Closure is static
  87             top_ccc
  88             (map fst amodes_w_offsets)) -- Sorted into ptrs first, then nonptrs
  89
  90     ) `thenC`
  91
  92         -- RETURN
  93     returnFC (id, stableAmodeIdInfo id (CLbl closure_label PtrRep) lf_info)
  94   where
  95     con_tycon       = dataConTyCon   con
  96     lf_info         = mkConLFInfo    con
  97     closure_label   = mkClosureLabel name
  98     name            = idName id
  99
 100     top_ccc = mkCCostCentreStack dontCareCCS -- because it's static data
 101
 102     -- stuff needed by the assert pred only.
 103     dynamic_con_or_args = isDynDataCon con || any isDynArg args
 104 \end{code}
 105
 106 %************************************************************************
 107 %*                                                                      *
 108 %* non-top-level constructors                                           *
 109 %*                                                                      *
 110 %************************************************************************
 111 \subsection[code-for-constructors]{The code for constructors}
 112
 113 \begin{code}
 114 buildDynCon :: Id               -- Name of the thing to which this constr will
 115                                 -- be bound
 116             -> CostCentreStack  -- Where to grab cost centre from;
 117                                 -- current CCS if currentOrSubsumedCCS
 118             -> DataCon          -- The data constructor
 119             -> [CAddrMode]      -- Its args
 120             -> FCode CgIdInfo   -- Return details about how to find it
 121
 122 -- We used to pass a boolean indicating whether all the
 123 -- args were of size zero, so we could use a static
 124 -- construtor; but I concluded that it just isn't worth it.
 125 -- Now I/O uses unboxed tuples there just aren't any constructors
 126 -- with all size-zero args.
 127 --
 128 -- The reason for having a separate argument, rather than looking at
 129 -- the addr modes of the args is that we may be in a "knot", and
 130 -- premature looking at the args will cause the compiler to black-hole!
 131 \end{code}
 132
 133 First we deal with the case of zero-arity constructors.  Now, they
 134 will probably be unfolded, so we don't expect to see this case much,
 135 if at all, but it does no harm, and sets the scene for characters.
 136
 137 In the case of zero-arity constructors, or, more accurately, those
 138 which have exclusively size-zero (VoidRep) args, we generate no code
 139 at all.
 140
 141 \begin{code}
 142 buildDynCon binder cc con []
 143   = returnFC (stableAmodeIdInfo binder
 144                                 (CLbl (mkClosureLabel (idName (dataConWrapId con))) PtrRep)
 145                                 (mkConLFInfo con))
 146 \end{code}
 147
 148 Now for @Char@-like closures.  We generate an assignment of the
 149 address of the closure to a temporary.  It would be possible simply to
 150 generate no code, and record the addressing mode in the environment,
 151 but we'd have to be careful if the argument wasn't a constant --- so
 152 for simplicity we just always asssign to a temporary.
 153
 154 Last special case: @Int@-like closures.  We only special-case the
 155 situation in which the argument is a literal in the range
 156 @mIN_INTLIKE@..@mAX_INTLILKE@.  NB: for @Char@-like closures we can
 157 work with any old argument, but for @Int@-like ones the argument has
 158 to be a literal.  Reason: @Char@ like closures have an argument type
 159 which is guaranteed in range.
 160
 161 Because of this, we use can safely return an addressing mode.
 162
 163 \begin{code}
 164 buildDynCon binder cc con [arg_amode]
 165
 166   | maybeCharLikeCon con
 167   = absC (CAssign temp_amode (CCharLike arg_amode))     `thenC`
 168     returnFC temp_id_info
 169
 170   | maybeIntLikeCon con && in_range_int_lit arg_amode
 171   = returnFC (stableAmodeIdInfo binder (CIntLike arg_amode) (mkConLFInfo con))
 172   where
 173     (temp_amode, temp_id_info) = newTempAmodeAndIdInfo binder (mkConLFInfo con)
 174
 175     in_range_int_lit (CLit (MachInt val)) = val <= mAX_INTLIKE && val >= mIN_INTLIKE
 176     in_range_int_lit other_amode          = False
 177
 178     tycon = dataConTyCon con
 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     (closure_info, amodes_w_offsets)
 189       = layOutDynClosure (idName binder) getAmodeRep args lf_info
 190     lf_info = mkConLFInfo con
 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
 223      (_, args_w_offsets) = layOutDynCon 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]                                 -- args
 232         -> FCode ([MagicId],                    -- regs assigned
 233                   [(VirtualSpOffset,Int)],      -- tag slots
 234                   Bool)                         -- any components on stack?
 235
 236 bindUnboxedTupleComponents args
 237  =  -- Assign as many components as possible to registers
 238     let (arg_regs, leftovers) = assignRegs [] (map idPrimRep args)
 239         (reg_args, stk_args) = splitAt (length arg_regs) args
 240     in
 241
 242     -- Allocate the rest on the stack (ToDo: separate out pointers)
 243     getVirtSp `thenFC` \ vsp ->
 244     getRealSp `thenFC` \ rsp ->
 245     let (top_sp, stk_offsets, tags) =
 246                 mkTaggedVirtStkOffsets rsp idPrimRep stk_args
 247     in
 248
 249     -- The stack pointer points to the last stack-allocated component
 250     setRealAndVirtualSp top_sp                  `thenC`
 251
 252     -- need to explicitly free any empty slots we just jumped over
 253     (if vsp < rsp then freeStackSlots [vsp+1 .. rsp] else nopC) `thenC`
 254
 255     bindArgsToRegs reg_args arg_regs            `thenC`
 256     mapCs bindNewToStack stk_offsets            `thenC`
 257     returnFC (arg_regs,tags, not (null stk_offsets))
 258 \end{code}
 259
 260 %************************************************************************
 261 %*                                                                      *
 262 \subsubsection[CgRetConv-cgReturnDataCon]{Actually generate code for a constructor return}
 263 %*                                                                      *
 264 %************************************************************************
 265
 266
 267 Note: it's the responsibility of the @cgReturnDataCon@ caller to be
 268 sure the @amodes@ passed don't conflict with each other.
 269 \begin{code}
 270 cgReturnDataCon :: DataCon -> [CAddrMode] -> Code
 271
 272 cgReturnDataCon con amodes
 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 (maybeCharLikeCon con)  -- no chars please (these are all static)
 304         && not (any isFollowableRep (map getAmodeRep amodes))
 305                                         -- no ptrs please (generational gc...)
 306         && closureSize closure_info <= mIN_UPD_SIZE
 307                                         -- don't know the real size of the
 308                                         -- thunk, so assume mIN_UPD_SIZE
 309
 310         ->      -- get a new temporary and make it point to the updatee
 311            let
 312                 uniq = getUnique con
 313                 temp = CTemp uniq PtrRep
 314            in
 315
 316            profCtrC SLIT("TICK_UPD_CON_IN_PLACE")
 317                         [mkIntCLit (length amodes)] `thenC`
 318
 319            getSpRelOffset args_sp                       `thenFC` \ sp_rel ->
 320            absC (CAssign temp
 321                     (CMacroExpr PtrRep UPD_FRAME_UPDATEE [CAddr sp_rel]))
 322                 `thenC`
 323
 324                 -- stomp all over it with the new constructor
 325            inPlaceAllocDynClosure closure_info temp (CReg CurCostCentre) stuff
 326                 `thenC`
 327
 328                 -- don't forget to update Su from the update frame
 329            absC (CMacroStmt UPDATE_SU_FROM_UPD_FRAME [CAddr sp_rel])  `thenC`
 330
 331                 -- set Node to point to the closure being returned
 332                 -- (can't be done earlier: node might conflict with amodes)
 333            absC (CAssign (CReg node) temp) `thenC`
 334
 335                 -- pop the update frame off the stack, and do the proper
 336                 -- return.
 337            let new_sp = args_sp - updateFrameSize in
 338            setEndOfBlockInfo (EndOfBlockInfo new_sp (OnStack new_sp)) $
 339            performReturn (AbsCNop) (mkStaticAlgReturnCode con)
 340
 341         where (closure_info, stuff)
 342                   = layOutDynClosure (dataConName con)
 343                         getAmodeRep amodes lf_info
 344
 345               lf_info = mkConLFInfo con
 346
 347       other_sequel      -- The usual case
 348
 349           | isUnboxedTupleCon con ->
 350                         -- Return unboxed tuple in registers
 351                   let (ret_regs, leftovers) =
 352                          assignRegs [] (map getAmodeRep amodes)
 353                   in
 354                   profCtrC SLIT("TICK_RET_UNBOXED_TUP")
 355                                 [mkIntCLit (length amodes)] `thenC`
 356
 357                   doTailCall amodes ret_regs
 358                         mkUnboxedTupleReturnCode
 359                         (length leftovers)  {- fast args arity -}
 360                         AbsCNop {-no pending assigments-}
 361                         Nothing {-not a let-no-escape-}
 362                         False   {-node doesn't point-}
 363
 364           | otherwise ->
 365                 build_it_then (mkStaticAlgReturnCode con)
 366
 367   where
 368     con_name = dataConName con
 369
 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}