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