ghc/compiler/nativeGen/StixInfo.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1993-1996
   3 %
   4
   5 \begin{code}
   6 #include "HsVersions.h"
   7
   8 module StixInfo ( genCodeInfoTable ) where
   9
  10 IMP_Ubiq(){-uitious-}
  11
  12 import AbsCSyn          ( AbstractC(..), CAddrMode, ReturnInfo,
  13                           RegRelative, MagicId, CStmtMacro
  14                         )
  15 import ClosureInfo      ( closurePtrsSize, closureSizeWithoutFixedHdr,
  16                           closureNonHdrSize, closureSemiTag, maybeSelectorInfo,
  17                           closureSMRep, closureLabelFromCI,
  18                           infoTableLabelFromCI
  19                         )
  20 import HeapOffs         ( hpRelToInt )
  21 import Maybes           ( maybeToBool )
  22 import PrimRep          ( PrimRep(..) )
  23 import SMRep            ( SMRep(..), SMSpecRepKind(..), SMUpdateKind(..),
  24                           isSpecRep
  25                         )
  26 import Stix             -- all of it
  27 import StixPrim         ( amodeToStix )
  28 import UniqSupply       ( returnUs, UniqSM(..) )
  29 import Unpretty         ( uppBesides, uppPStr, uppInt, uppChar )
  30 \end{code}
  31
  32 Generating code for info tables (arrays of data).
  33
  34 \begin{code}
  35 static___rtbl   = sStLitLbl SLIT("Static___rtbl") -- out here to avoid CAF (sigh)
  36 const___rtbl    = sStLitLbl SLIT("Const___rtbl")
  37 charlike___rtbl = sStLitLbl SLIT("CharLike___rtbl")
  38 intlike___rtbl  = sStLitLbl SLIT("IntLike___rtbl")
  39 gen_N___rtbl    = sStLitLbl SLIT("Gen_N___rtbl")
  40 gen_S___rtbl    = sStLitLbl SLIT("Gen_S___rtbl")
  41 gen_U___rtbl    = sStLitLbl SLIT("Gen_U___rtbl")
  42 tuple___rtbl    = sStLitLbl SLIT("Tuple___rtbl")
  43 data___rtbl     = sStLitLbl SLIT("Data___rtbl")
  44 dyn___rtbl      = sStLitLbl SLIT("Dyn___rtbl")
  45
  46 genCodeInfoTable
  47     :: AbstractC
  48     -> UniqSM StixTreeList
  49
  50 genCodeInfoTable (CClosureInfoAndCode cl_info _ _ upd cl_descr _)
  51   = returnUs (\xs -> info : lbl : xs)
  52
  53     where
  54         info = StData PtrRep table
  55         lbl = StLabel info_lbl
  56
  57         table = case sm_rep of
  58             StaticRep _ _ -> [
  59                 StInt (toInteger ptrs),
  60                 StInt (toInteger size),
  61                 upd_code,
  62                 static___rtbl,
  63                 tag]
  64
  65             SpecialisedRep ConstantRep _ _ _ -> [
  66                 StCLbl closure_lbl,
  67                 upd_code,
  68                 const___rtbl,
  69                 tag]
  70
  71             SpecialisedRep CharLikeRep _ _ _ -> [
  72                 upd_code,
  73                 charlike___rtbl,
  74                 tag]
  75
  76             SpecialisedRep IntLikeRep _ _ _ -> [
  77                 upd_code,
  78                 intlike___rtbl,
  79                 tag]
  80
  81             SpecialisedRep _ _ _ updatable ->
  82                 let rtbl = uppBesides (
  83                        if is_selector then
  84                           [uppPStr SLIT("Select__"),
  85                            uppInt select_word,
  86                            uppPStr SLIT("_rtbl")]
  87                        else
  88                           [uppPStr (case updatable of
  89                                     SMNormalForm -> SLIT("Spec_N_")
  90                                     SMSingleEntry -> SLIT("Spec_S_")
  91                                     SMUpdatable -> SLIT("Spec_U_")
  92                                    ),
  93                            uppInt size,
  94                            uppChar '_',
  95                            uppInt ptrs,
  96                            uppPStr SLIT("_rtbl")])
  97                 in
  98                     case updatable of
  99                         SMNormalForm -> [upd_code, StLitLbl rtbl, tag]
 100                         _            -> [StLitLbl rtbl, tag]
 101
 102             GenericRep _ _ updatable ->
 103                 let rtbl = case updatable of
 104                             SMNormalForm  -> gen_N___rtbl
 105                             SMSingleEntry -> gen_S___rtbl
 106                             SMUpdatable   -> gen_U___rtbl
 107                 in [
 108                     StInt (toInteger ptrs),
 109                     StInt (toInteger size),
 110                     upd_code,
 111                     rtbl,
 112                     tag]
 113
 114             BigTupleRep _ -> [
 115                 tuple___rtbl,
 116                 tag]
 117             DataRep _     -> [
 118                 data___rtbl,
 119                 tag]
 120             DynamicRep    -> [
 121                 dyn___rtbl,
 122                 tag]
 123
 124             PhantomRep -> [
 125                 upd_code,
 126                 info_unused,    -- no rep table
 127                 tag]
 128
 129         info_lbl        = infoTableLabelFromCI cl_info
 130         closure_lbl     = closureLabelFromCI   cl_info
 131
 132         sm_rep  = closureSMRep cl_info
 133         maybe_selector = maybeSelectorInfo cl_info
 134         is_selector = maybeToBool maybe_selector
 135         (Just (_, select_word)) = maybe_selector
 136
 137         tag = StInt (toInteger (closureSemiTag cl_info))
 138
 139         size    = if isSpecRep sm_rep
 140                   then closureNonHdrSize cl_info
 141                   else hpRelToInt (closureSizeWithoutFixedHdr cl_info)
 142         ptrs    = closurePtrsSize cl_info
 143
 144         upd_code = amodeToStix upd
 145
 146         info_unused = StInt (-1)
 147 \end{code}