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