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                           --UNUSED: 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, dataConLiveness
  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       = CLbl
 181         (case (dataReturnConvAlg isw_chkr con) of
 182           ReturnInRegs _ -> mkConUpdCodePtrVecLabel tycon tag
 183           ReturnInHeap   -> mkStdUpdCodePtrVecLabel tycon tag)
 184         CodePtrKind
 185       where
 186         tag = getDataConTag con
 187
 188     ------------------
 189     (MkCompInfo sw_chkr isw_chkr _) = comp_info
 190 \end{code}
 191
 192 %************************************************************************
 193 %*                                                                      *
 194 \subsection[CgConTbls-info-tables]{Generating info tables for constructors}
 195 %*                                                                      *
 196 %************************************************************************
 197
 198 Generate the entry code, info tables, and (for niladic constructor) the
 199 static closure, for a constructor.
 200
 201 \begin{code}
 202 genConInfo :: CompilationInfo -> TyCon -> Id -> AbstractC
 203
 204 genConInfo comp_info@(MkCompInfo _ isw_chkr _) tycon data_con
 205   = mkAbstractCs [
 206                   CSplitMarker,
 207                   inregs_upd_maybe,
 208                   closure_code,
 209                   static_code,
 210                   closure_maybe]
 211         -- Order of things is to reduce forward references
 212   where
 213     (closure_info, body_code) = mkConCodeAndInfo isw_chkr data_con
 214
 215     -- To allow the debuggers, interpreters, etc to cope with static
 216     -- data structures (ie those built at compile time), we take care that
 217     -- info-table contains the information we need.
 218     (static_ci,_) = layOutStaticClosure data_con kindFromType arg_tys (mkConLFInfo data_con)
 219
 220     body       = (initC comp_info (
 221                       profCtrC SLIT("ENT_CON") [CReg node] `thenC`
 222                       body_code))
 223
 224     entry_addr = CLbl entry_label CodePtrKind
 225     con_descr  = _UNPK_ (getOccurrenceName data_con)
 226
 227     closure_code        = CClosureInfoAndCode closure_info body Nothing
 228                                               stdUpd con_descr
 229                                               (dataConLiveness isw_chkr closure_info)
 230     static_code         = CClosureInfoAndCode static_ci body Nothing
 231                                               stdUpd con_descr
 232                                               (dataConLiveness isw_chkr static_ci)
 233
 234     inregs_upd_maybe    = genPhantomUpdInfo comp_info tycon data_con
 235
 236     stdUpd              = CLbl (mkStdUpdCodePtrVecLabel tycon tag) CodePtrKind
 237
 238     tag                 = getDataConTag data_con
 239
 240     cost_centre = mkCCostCentre dontCareCostCentre -- not worried about static data costs
 241
 242     -- For zero-arity data constructors, or, more accurately,
 243     --   those which only have VoidKind args (or none):
 244     --  We make the closure too (not just info tbl), so that we can share
 245     --  one copy throughout.
 246     closure_maybe = -- OLD: if con_arity /= 0 then
 247                     if not (all zero_size arg_tys) then
 248                         AbsCNop
 249                     else
 250                         CStaticClosure  closure_label           -- Label for closure
 251                                         static_ci               -- Info table
 252                                         cost_centre
 253                                         [{-No args!  A slight lie for constrs with VoidKind args-}]
 254
 255     zero_size arg_ty = getKindSize (kindFromType arg_ty) == 0
 256
 257     (_,_,arg_tys,_) = getDataConSig   data_con
 258     con_arity       = getDataConArity data_con
 259     entry_label     = mkConEntryLabel data_con
 260     closure_label   = mkClosureLabel  data_con
 261 \end{code}
 262
 263 \begin{code}
 264 mkConCodeAndInfo :: IntSwitchChecker
 265                  -> Id                  -- Data constructor
 266                  -> (ClosureInfo, Code) -- The info table
 267
 268 mkConCodeAndInfo isw_chkr con
 269   = case (dataReturnConvAlg isw_chkr con) of
 270
 271     ReturnInRegs regs ->
 272         let
 273             (closure_info, regs_w_offsets)
 274               = layOutDynCon con kindFromMagicId regs
 275
 276             body_code
 277               = profCtrC SLIT("RET_OLD_IN_REGS") [mkIntCLit (length regs_w_offsets)] `thenC`
 278
 279                 performReturn (mkAbstractCs (map move_to_reg regs_w_offsets))
 280                               (mkStaticAlgReturnCode con Nothing {- Info-ptr already loaded-})
 281                               emptyUniqSet{-no live vars-}
 282         in
 283         (closure_info, body_code)
 284
 285     ReturnInHeap ->
 286         let
 287             (_, _, arg_tys, _) = getDataConSig con
 288
 289             (closure_info, arg_things)
 290                 = layOutDynCon con kindFromType arg_tys
 291
 292             body_code
 293                 = -- OLD: We don't set CC when entering data any more (WDP 94/06)
 294                   -- lexCostCentreC "ENTER_CC_DCL" [CReg node]          `thenC`
 295                   profCtrC SLIT("RET_OLD_IN_HEAP") [mkIntCLit (length arg_things)] `thenC`
 296
 297                   performReturn AbsCNop -- Ptr to thing already in Node
 298                                 (mkStaticAlgReturnCode con Nothing {- Info-ptr already loaded-})
 299                                 emptyUniqSet{-no live vars-}
 300         in
 301         (closure_info, body_code)
 302
 303   where
 304     move_to_reg :: (MagicId, VirtualHeapOffset {-from Node-}) -> AbstractC
 305     move_to_reg (reg, offset)
 306       = CAssign (CReg reg) (CVal (NodeRel offset) (kindFromMagicId reg))
 307 \end{code}
 308
 309 %************************************************************************
 310 %*                                                                      *
 311 \subsection[CgConTbls-updates]{Generating update bits for constructors}
 312 %*                                                                      *
 313 %************************************************************************
 314
 315 Generate the "phantom" info table and update code, iff the constructor returns in regs
 316
 317 \begin{code}
 318
 319 genPhantomUpdInfo :: CompilationInfo -> TyCon -> Id{-data con-} -> AbstractC
 320
 321 genPhantomUpdInfo comp_info@(MkCompInfo _ isw_chkr _) tycon data_con
 322   = case (dataReturnConvAlg isw_chkr data_con) of
 323
 324       ReturnInHeap -> --OLD: pprTrace "NoPhantom: " (ppr PprDebug data_con) $
 325                       AbsCNop   -- No need for a phantom update
 326
 327       ReturnInRegs regs ->
 328         --OLD: pprTrace "YesPhantom! " (ppr PprDebug data_con) $
 329         let
 330             phantom_itbl = CClosureInfoAndCode phantom_ci AbsCNop Nothing
 331                                 upd_code con_descr
 332                                 (dataConLiveness isw_chkr phantom_ci)
 333
 334             phantom_ci = layOutPhantomClosure data_con (mkConLFInfo data_con)
 335
 336             con_descr = _UNPK_ (getOccurrenceName data_con)
 337
 338             con_arity = getDataConArity data_con
 339
 340             upd_code = CLabelledCode upd_label (mkAbsCStmts build_closure perform_return)
 341             upd_label = mkConUpdCodePtrVecLabel tycon tag
 342             tag = getDataConTag data_con
 343
 344             updatee = CVal (SpBRel 0 (-uF_UPDATEE)) PtrKind
 345
 346             perform_return = mkAbstractCs
 347               [
 348                 CMacroStmt POP_STD_UPD_FRAME [],
 349                 CReturn (CReg RetReg) return_info
 350               ]
 351
 352             return_info =
 353               -- OLD: pprTrace "ctrlReturn6:" (ppr PprDebug tycon) (
 354               case (ctrlReturnConvAlg tycon) of
 355                 UnvectoredReturn _ -> DirectReturn
 356                 VectoredReturn _ -> StaticVectoredReturn (tag - fIRST_TAG)
 357               -- )
 358
 359             -- Determine cost centre for the updated closures CC (and allocation)
 360             -- CCC for lexical (now your only choice)
 361             use_cc = CReg CurCostCentre -- what to put in the closure
 362             blame_cc = use_cc -- who to blame for allocation
 363
 364             do_move (reg, virt_offset) =
 365                 CAssign (CVal (NodeRel virt_offset) (kindFromMagicId reg)) (CReg reg)
 366
 367
 368             -- Code for building a new constructor in place over the updatee
 369             overwrite_code
 370               = profCtrC SLIT("UPD_CON_IN_PLACE")
 371                          [mkIntCLit (length regs_w_offsets)]    `thenC`
 372                 absC (mkAbstractCs
 373                   [
 374                     CAssign (CReg node) updatee,
 375
 376                     -- Tell the storage mgr that we intend to update in place
 377                     -- This may (in complicated mgrs eg generational) cause gc,
 378                     -- and it may modify Node to point to another place to
 379                     -- actually update into.
 380                     CMacroStmt upd_inplace_macro [liveness_mask],
 381
 382                     -- Initialise the closure pointed to by node
 383                     CInitHdr closure_info (NodeRel zeroOff) use_cc True,
 384                     mkAbstractCs (map do_move regs_w_offsets),
 385                     if con_arity /= 0 then
 386                         CAssign (CReg infoptr) (CLbl info_label DataPtrKind)
 387                     else
 388                         AbsCNop
 389                   ])
 390
 391             upd_inplace_macro = if closurePtrsSize closure_info == 0
 392                                 then UPD_INPLACE_NOPTRS
 393                                 else UPD_INPLACE_PTRS
 394
 395             -- Code for allocating a new constructor in the heap
 396             alloc_code
 397               = let
 398                     amodes_w_offsets = [ (CReg r, o) | (r,o) <- regs_w_offsets ]
 399                 in
 400                     -- Allocate and build closure specifying upd_new_w_regs
 401                     allocDynClosure closure_info use_cc blame_cc amodes_w_offsets
 402                                                         `thenFC` \ hp_offset ->
 403                     getHpRelOffset hp_offset            `thenFC` \ hp_rel ->
 404                     let
 405                         amode = CAddr hp_rel
 406                     in
 407                     profCtrC SLIT("UPD_CON_IN_NEW")
 408                              [mkIntCLit (length amodes_w_offsets)] `thenC`
 409                     absC (mkAbstractCs
 410                       [ CMacroStmt UPD_IND [updatee, amode],
 411                         CAssign (CReg node) amode,
 412                         CAssign (CReg infoptr) (CLbl info_label DataPtrKind)
 413                       ])
 414
 415             (closure_info, regs_w_offsets) = layOutDynCon data_con kindFromMagicId regs
 416             info_label = infoTableLabelFromCI closure_info
 417             liveness_mask = mkIntCLit (mkLiveRegsBitMask (node:regs))
 418
 419             build_closure =
 420               if fitsMinUpdSize closure_info then
 421                 initC comp_info overwrite_code
 422               else
 423                 initC comp_info (heapCheck regs False alloc_code)
 424
 425         in CClosureUpdInfo phantom_itbl
 426
 427 \end{code}
 428