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