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