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