ghc/compiler/codeGen/CgConTbls.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
   3 %
   4 \section[CgConTbls]{Info tables and update bits for constructors}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module CgConTbls (
  10         genStaticConBits,
  11
  12         -- and to complete the interface...
  13         TCE(..), UniqFM, CompilationInfo, AbstractC
  14     ) where
  15
  16 import Pretty           -- ToDo: rm (debugging)
  17 import Outputable
  18
  19 import AbsCSyn
  20 import CgMonad
  21
  22 import Type             ( getTyConDataCons, primRepFromType,
  23                           maybeIntLikeTyCon, mkSpecTyCon,
  24                           TyVarTemplate, TyCon, Class,
  25                           TauType(..), Type, ThetaType(..)
  26                         )
  27 import CgHeapery        ( heapCheck, allocDynClosure )
  28 import CgRetConv        ( dataReturnConvAlg, ctrlReturnConvAlg,
  29                           mkLiveRegsBitMask,
  30                           CtrlReturnConvention(..),
  31                           DataReturnConvention(..)
  32                         )
  33 import CgTailCall       ( performReturn, mkStaticAlgReturnCode )
  34 import CgUsages         ( getHpRelOffset )
  35 import CLabel   ( mkConEntryLabel, mkStaticConEntryLabel,
  36                           mkClosureLabel,
  37                           mkConUpdCodePtrVecLabel, mkStdUpdCodePtrVecLabel,
  38                           mkStdUpdVecTblLabel, CLabel
  39                         )
  40 import ClosureInfo      ( layOutStaticClosure, layOutDynCon,
  41                           closureSizeWithoutFixedHdr, closurePtrsSize,
  42                           fitsMinUpdSize, mkConLFInfo, layOutPhantomClosure,
  43                           infoTableLabelFromCI, dataConLiveness
  44                         )
  45 import FiniteMap
  46 import Id               ( getDataConTag, getDataConSig, getDataConTyCon,
  47                           mkSameSpecCon,
  48                           getDataConArity, fIRST_TAG, ConTag(..),
  49                           DataCon(..)
  50                         )
  51 import CgCompInfo       ( uF_UPDATEE )
  52 import Maybes           ( maybeToBool, Maybe(..) )
  53 import PrimRep          ( getPrimRepSize, retPrimRepSize )
  54 import CostCentre
  55 import UniqSet          -- ( emptyUniqSet, UniqSet(..) )
  56 import Util
  57 \end{code}
  58
  59 For every constructor we generate the following info tables:
  60         A static info table, for static instances of the constructor,
  61
  62         For constructors which return in registers (and only them),
  63                 an "inregs" info table.  This info table is rather emaciated;
  64                 it only contains update code and tag.
  65
  66         Plus:
  67
  68 \begin{tabular}{lll}
  69 Info tbls &      Macro  &            Kind of constructor \\
  70 \hline
  71 info & @CONST_INFO_TABLE@&    Zero arity (no info -- compiler uses static closure)\\
  72 info & @CHARLIKE_INFO_TABLE@& Charlike   (no info -- compiler indexes fixed array)\\
  73 info & @INTLIKE_INFO_TABLE@&  Intlike; the one macro generates both info tbls\\
  74 info & @SPEC_INFO_TABLE@&     SPECish, and bigger than or equal to @MIN_UPD_SIZE@\\
  75 info & @GEN_INFO_TABLE@&      GENish (hence bigger than or equal to @MIN_UPD_SIZE@)\\
  76 \end{tabular}
  77
  78 Possible info tables for constructor con:
  79
  80 \begin{description}
  81 \item[@con_info@:]
  82 Used for dynamically let(rec)-bound occurrences of
  83 the constructor, and for updates.  For constructors
  84 which are int-like, char-like or nullary, when GC occurs,
  85 the closure tries to get rid of itself.
  86
  87 \item[@con_inregs_info@:]
  88 Used when returning a new constructor in registers.
  89 Only for return-in-regs constructors.
  90 Macro: @INREGS_INFO_TABLE@.
  91
  92 \item[@con_static_info@:]
  93 Static occurrences of the constructor
  94 macro: @STATIC_INFO_TABLE@.
  95 \end{description}
  96
  97 For zero-arity constructors, \tr{con}, we also generate a static closure:
  98
  99 \begin{description}
 100 \item[@con_closure@:]
 101 A single static copy of the (zero-arity) constructor itself.
 102 \end{description}
 103
 104 For charlike and intlike closures there is a fixed array of static
 105 closures predeclared.
 106
 107 \begin{code}
 108 genStaticConBits :: CompilationInfo     -- global info about the compilation
 109                  -> [TyCon]             -- tycons to generate
 110                  -> FiniteMap TyCon [(Bool, [Maybe Type])]
 111                                         -- tycon specialisation info
 112                  -> AbstractC           -- output
 113
 114 genStaticConBits comp_info gen_tycons tycon_specs
 115   = -- for each type constructor:
 116     --   grab all its data constructors;
 117     --      for each one, generate an info table
 118     -- for each specialised type constructor
 119     --   for each specialisation of the type constructor
 120     --     grab data constructors, and generate info tables
 121
 122     -- ToDo: for tycons and specialisations which are not
 123     --       declared in this module we must ensure that the
 124     --       C labels are local to this module i.e. static
 125     --       since they may be duplicated in other modules
 126
 127     mkAbstractCs [ gen_for_tycon tc | tc <- gen_tycons ]
 128       `mkAbsCStmts`
 129     mkAbstractCs [ mkAbstractCs [ gen_for_spec_tycon tc spec
 130                                 | (imported_spec, spec) <- specs,
 131                                   -- no code generated if spec is imported
 132                                   not imported_spec
 133                                 ]
 134                  | (tc, specs) <- fmToList tycon_specs ]
 135   where
 136     gen_for_tycon :: TyCon -> AbstractC
 137     gen_for_tycon tycon
 138       = mkAbstractCs (map (genConInfo comp_info tycon) data_cons)
 139           `mkAbsCStmts`
 140         maybe_tycon_vtbl
 141       where
 142         data_cons       = getTyConDataCons tycon
 143         tycon_upd_label = mkStdUpdVecTblLabel tycon
 144
 145         maybe_tycon_vtbl =
 146           case ctrlReturnConvAlg tycon of
 147             UnvectoredReturn 1 -> CRetUnVector tycon_upd_label
 148                                         (mk_upd_label tycon (head data_cons))
 149             UnvectoredReturn _ -> AbsCNop
 150             VectoredReturn   _ -> CFlatRetVector tycon_upd_label
 151                                         (map (mk_upd_label tycon) data_cons)
 152     ------------------
 153     gen_for_spec_tycon :: TyCon -> [Maybe Type] -> AbstractC
 154
 155     gen_for_spec_tycon tycon ty_maybes
 156       = mkAbstractCs (map (genConInfo comp_info spec_tycon) spec_data_cons)
 157           `mkAbsCStmts`
 158         maybe_spec_tycon_vtbl
 159       where
 160         data_cons      = getTyConDataCons tycon
 161
 162         spec_tycon     = mkSpecTyCon tycon ty_maybes
 163         spec_data_cons = map (mkSameSpecCon ty_maybes) data_cons
 164
 165         spec_tycon_upd_label = mkStdUpdVecTblLabel spec_tycon
 166
 167         maybe_spec_tycon_vtbl =
 168           case ctrlReturnConvAlg spec_tycon of
 169             UnvectoredReturn 1 -> CRetUnVector spec_tycon_upd_label
 170                                         (mk_upd_label spec_tycon (head spec_data_cons))
 171             UnvectoredReturn _ -> AbsCNop
 172             VectoredReturn   _ -> CFlatRetVector spec_tycon_upd_label
 173                                         (map (mk_upd_label spec_tycon) spec_data_cons)
 174     ------------------
 175     mk_upd_label tycon con
 176       = CLbl
 177         (case (dataReturnConvAlg isw_chkr con) of
 178           ReturnInRegs _ -> mkConUpdCodePtrVecLabel tycon tag
 179           ReturnInHeap   -> mkStdUpdCodePtrVecLabel tycon tag)
 180         CodePtrRep
 181       where
 182         tag = getDataConTag con
 183
 184     ------------------
 185     (MkCompInfo sw_chkr isw_chkr _) = comp_info
 186 \end{code}
 187
 188 %************************************************************************
 189 %*                                                                      *
 190 \subsection[CgConTbls-info-tables]{Generating info tables for constructors}
 191 %*                                                                      *
 192 %************************************************************************
 193
 194 Generate the entry code, info tables, and (for niladic constructor) the
 195 static closure, for a constructor.
 196
 197 \begin{code}
 198 genConInfo :: CompilationInfo -> TyCon -> Id -> AbstractC
 199
 200 genConInfo comp_info@(MkCompInfo _ isw_chkr _) tycon data_con
 201   = mkAbstractCs [
 202                   CSplitMarker,
 203                   inregs_upd_maybe,
 204                   closure_code,
 205                   static_code,
 206                   closure_maybe]
 207         -- Order of things is to reduce forward references
 208   where
 209     (closure_info, body_code) = mkConCodeAndInfo isw_chkr data_con
 210
 211     -- To allow the debuggers, interpreters, etc to cope with static
 212     -- data structures (ie those built at compile time), we take care that
 213     -- info-table contains the information we need.
 214     (static_ci,_) = layOutStaticClosure data_con primRepFromType arg_tys (mkConLFInfo data_con)
 215
 216     body       = (initC comp_info (
 217                       profCtrC SLIT("ENT_CON") [CReg node] `thenC`
 218                       body_code))
 219
 220     entry_addr = CLbl entry_label CodePtrRep
 221     con_descr  = _UNPK_ (getOccurrenceName data_con)
 222
 223     closure_code        = CClosureInfoAndCode closure_info body Nothing
 224                                               stdUpd con_descr
 225                                               (dataConLiveness isw_chkr closure_info)
 226     static_code         = CClosureInfoAndCode static_ci body Nothing
 227                                               stdUpd con_descr
 228                                               (dataConLiveness isw_chkr static_ci)
 229
 230     inregs_upd_maybe    = genPhantomUpdInfo comp_info tycon data_con
 231
 232     stdUpd              = CLbl (mkStdUpdCodePtrVecLabel tycon tag) CodePtrRep
 233
 234     tag                 = getDataConTag data_con
 235
 236     cost_centre = mkCCostCentre dontCareCostCentre -- not worried about static data costs
 237
 238     -- For zero-arity data constructors, or, more accurately,
 239     --   those which only have VoidRep args (or none):
 240     --  We make the closure too (not just info tbl), so that we can share
 241     --  one copy throughout.
 242     closure_maybe = if not (all zero_size arg_tys) then
 243                         AbsCNop
 244                     else
 245                         CStaticClosure  closure_label           -- Label for closure
 246                                         static_ci               -- Info table
 247                                         cost_centre
 248                                         [{-No args!  A slight lie for constrs with VoidRep args-}]
 249
 250     zero_size arg_ty = getPrimRepSize (primRepFromType arg_ty) == 0
 251
 252     (_,_,arg_tys,_) = getDataConSig   data_con
 253     con_arity       = getDataConArity data_con
 254     entry_label     = mkConEntryLabel data_con
 255     closure_label   = mkClosureLabel  data_con
 256 \end{code}
 257
 258 \begin{code}
 259 mkConCodeAndInfo :: IntSwitchChecker
 260                  -> Id                  -- Data constructor
 261                  -> (ClosureInfo, Code) -- The info table
 262
 263 mkConCodeAndInfo isw_chkr con
 264   = case (dataReturnConvAlg isw_chkr con) of
 265
 266     ReturnInRegs regs ->
 267         let
 268             (closure_info, regs_w_offsets)
 269               = layOutDynCon con kindFromMagicId regs
 270
 271             body_code
 272               = profCtrC SLIT("RET_OLD_IN_REGS") [mkIntCLit (length regs_w_offsets)] `thenC`
 273
 274                 performReturn (mkAbstractCs (map move_to_reg regs_w_offsets))
 275                               (mkStaticAlgReturnCode con Nothing {- Info-ptr already loaded-})
 276                               emptyUniqSet{-no live vars-}
 277         in
 278         (closure_info, body_code)
 279
 280     ReturnInHeap ->
 281         let
 282             (_, _, arg_tys, _) = getDataConSig con
 283
 284             (closure_info, arg_things)
 285                 = layOutDynCon con primRepFromType arg_tys
 286
 287             body_code
 288                 = -- NB: We don't set CC when entering data (WDP 94/06)
 289                   profCtrC SLIT("RET_OLD_IN_HEAP") [mkIntCLit (length arg_things)] `thenC`
 290
 291                   performReturn AbsCNop -- Ptr to thing already in Node
 292                                 (mkStaticAlgReturnCode con Nothing {- Info-ptr already loaded-})
 293                                 emptyUniqSet{-no live vars-}
 294         in
 295         (closure_info, body_code)
 296
 297   where
 298     move_to_reg :: (MagicId, VirtualHeapOffset {-from Node-}) -> AbstractC
 299     move_to_reg (reg, offset)
 300       = CAssign (CReg reg) (CVal (NodeRel offset) (kindFromMagicId reg))
 301 \end{code}
 302
 303 %************************************************************************
 304 %*                                                                      *
 305 \subsection[CgConTbls-updates]{Generating update bits for constructors}
 306 %*                                                                      *
 307 %************************************************************************
 308
 309 Generate the "phantom" info table and update code, iff the constructor returns in regs
 310
 311 \begin{code}
 312
 313 genPhantomUpdInfo :: CompilationInfo -> TyCon -> Id{-data con-} -> AbstractC
 314
 315 genPhantomUpdInfo comp_info@(MkCompInfo _ isw_chkr _) tycon data_con
 316   = case (dataReturnConvAlg isw_chkr data_con) of
 317
 318       ReturnInHeap -> AbsCNop   -- No need for a phantom update
 319
 320       ReturnInRegs regs ->
 321         let
 322             phantom_itbl = CClosureInfoAndCode phantom_ci AbsCNop Nothing
 323                                 upd_code con_descr
 324                                 (dataConLiveness isw_chkr phantom_ci)
 325
 326             phantom_ci = layOutPhantomClosure data_con (mkConLFInfo data_con)
 327
 328             con_descr = _UNPK_ (getOccurrenceName data_con)
 329
 330             con_arity = getDataConArity data_con
 331
 332             upd_code = CLabelledCode upd_label (mkAbsCStmts build_closure perform_return)
 333             upd_label = mkConUpdCodePtrVecLabel tycon tag
 334             tag = getDataConTag data_con
 335
 336             updatee = CVal (SpBRel 0 (-uF_UPDATEE)) PtrRep
 337
 338             perform_return = mkAbstractCs
 339               [
 340                 CMacroStmt POP_STD_UPD_FRAME [],
 341                 CReturn (CReg RetReg) return_info
 342               ]
 343
 344             return_info =
 345               case (ctrlReturnConvAlg tycon) of
 346                 UnvectoredReturn _ -> DirectReturn
 347                 VectoredReturn   _ -> StaticVectoredReturn (tag - fIRST_TAG)
 348
 349             -- Determine cost centre for the updated closures CC (and allocation)
 350             -- CCC for lexical (now your only choice)
 351             use_cc = CReg CurCostCentre -- what to put in the closure
 352             blame_cc = use_cc -- who to blame for allocation
 353
 354             do_move (reg, virt_offset) =
 355                 CAssign (CVal (NodeRel virt_offset) (kindFromMagicId reg)) (CReg reg)
 356
 357
 358             -- Code for building a new constructor in place over the updatee
 359             overwrite_code
 360               = profCtrC SLIT("UPD_CON_IN_PLACE")
 361                          [mkIntCLit (length regs_w_offsets)]    `thenC`
 362                 absC (mkAbstractCs
 363                   [
 364                     CAssign (CReg node) updatee,
 365
 366                     -- Tell the storage mgr that we intend to update in place
 367                     -- This may (in complicated mgrs eg generational) cause gc,
 368                     -- and it may modify Node to point to another place to
 369                     -- actually update into.
 370                     CMacroStmt upd_inplace_macro [liveness_mask],
 371
 372                     -- Initialise the closure pointed to by node
 373                     CInitHdr closure_info (NodeRel zeroOff) use_cc True,
 374                     mkAbstractCs (map do_move regs_w_offsets),
 375                     if con_arity /= 0 then
 376                         CAssign (CReg infoptr) (CLbl info_label DataPtrRep)
 377                     else
 378                         AbsCNop
 379                   ])
 380
 381             upd_inplace_macro = if closurePtrsSize closure_info == 0
 382                                 then UPD_INPLACE_NOPTRS
 383                                 else UPD_INPLACE_PTRS
 384
 385             -- Code for allocating a new constructor in the heap
 386             alloc_code
 387               = let
 388                     amodes_w_offsets = [ (CReg r, o) | (r,o) <- regs_w_offsets ]
 389                 in
 390                     -- Allocate and build closure specifying upd_new_w_regs
 391                     allocDynClosure closure_info use_cc blame_cc amodes_w_offsets
 392                                                         `thenFC` \ hp_offset ->
 393                     getHpRelOffset hp_offset            `thenFC` \ hp_rel ->
 394                     let
 395                         amode = CAddr hp_rel
 396                     in
 397                     profCtrC SLIT("UPD_CON_IN_NEW")
 398                              [mkIntCLit (length amodes_w_offsets)] `thenC`
 399                     absC (mkAbstractCs
 400                       [ CMacroStmt UPD_IND [updatee, amode],
 401                         CAssign (CReg node) amode,
 402                         CAssign (CReg infoptr) (CLbl info_label DataPtrRep)
 403                       ])
 404
 405             (closure_info, regs_w_offsets) = layOutDynCon data_con kindFromMagicId regs
 406             info_label = infoTableLabelFromCI closure_info
 407             liveness_mask = mkIntCLit (mkLiveRegsBitMask (node:regs))
 408
 409             build_closure =
 410               if fitsMinUpdSize closure_info then
 411                 initC comp_info overwrite_code
 412               else
 413                 initC comp_info (heapCheck regs False alloc_code)
 414
 415         in CClosureUpdInfo phantom_itbl
 416
 417 \end{code}
 418