ghc/compiler/nativeGen/StixInfo.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1993-1998
   3 %
   4
   5 \begin{code}
   6 module StixInfo ( genCodeInfoTable, genBitmapInfoTable ) where
   7
   8 #include "HsVersions.h"
   9 #include "../includes/config.h"
  10
  11 import AbsCSyn          ( AbstractC(..), Liveness(..) )
  12 import CLabel           ( CLabel )
  13 import StgSyn           ( SRT(..) )
  14 import ClosureInfo      ( closurePtrsSize,
  15                           closureNonHdrSize, closureSMRep,
  16                           infoTableLabelFromCI,
  17                           infoTblNeedsSRT, getSRTInfo, closureSemiTag
  18                         )
  19 import PrimRep          ( PrimRep(..) )
  20 import SMRep            ( SMRep(..), getSMRepClosureTypeInt )
  21 import Stix             -- all of it
  22 import UniqSupply       ( returnUs, UniqSM )
  23 import Outputable       ( int )
  24 import BitSet           ( intBS )
  25 import Maybes           ( maybeToBool )
  26
  27 import Bits
  28 import Word
  29
  30 #if __GLASGOW_HASKELL__ >= 404
  31 import GlaExts          ( fromInt )
  32 #endif
  33 \end{code}
  34
  35 Generating code for info tables (arrays of data).
  36
  37 \begin{code}
  38 genCodeInfoTable
  39     :: AbstractC
  40     -> UniqSM StixTreeList
  41
  42 genCodeInfoTable (CClosureInfoAndCode cl_info _ _ cl_descr)
  43   = returnUs (\xs -> StData PtrRep table : StLabel info_lbl : xs)
  44
  45     where
  46         info_lbl  = infoTableLabelFromCI cl_info
  47         needs_srt = infoTblNeedsSRT cl_info
  48
  49         table | needs_srt = srt_label : rest_of_table
  50               | otherwise = rest_of_table
  51
  52         rest_of_table =
  53                 [
  54                 {- par, prof, debug -}
  55                   StInt (toInteger layout_info)
  56                 , StInt (toInteger type_info)
  57                 ]
  58
  59         -- sigh: building up the info table is endian-dependent.
  60         -- ToDo: do this using .byte and .word directives.
  61         type_info :: Word32
  62 #ifdef WORDS_BIGENDIAN
  63         type_info = (fromInt closure_type `shiftL` 16) .|.
  64                     (fromInt srt_len)
  65 #else
  66         type_info = (fromInt closure_type) .|.
  67                     (fromInt srt_len `shiftL` 16)
  68 #endif
  69         srt = getSRTInfo cl_info
  70
  71         (srt_label,srt_len)
  72            | is_constr
  73            = (StInt 0, tag)
  74            | needs_srt
  75            = case srt of
  76                 (lbl, SRT off len) ->
  77                         (StIndex DataPtrRep (StCLbl lbl)
  78                                 (StInt (toInteger off)), len)
  79            | otherwise
  80            = (StInt 0, 0)
  81
  82         maybe_tag = closureSemiTag cl_info
  83         is_constr = maybeToBool maybe_tag
  84         (Just tag) = maybe_tag
  85
  86         layout_info :: Word32
  87 #ifdef WORDS_BIGENDIAN
  88         layout_info = (fromInt ptrs `shiftL` 16) .|. fromInt nptrs
  89 #else
  90         layout_info = (fromInt ptrs) .|. (fromInt nptrs `shiftL` 16)
  91 #endif
  92
  93         ptrs    = closurePtrsSize cl_info
  94         nptrs   = size - ptrs
  95
  96         size = closureNonHdrSize cl_info
  97
  98         closure_type = getSMRepClosureTypeInt (closureSMRep cl_info)
  99
 100
 101
 102 genBitmapInfoTable
 103         :: Liveness
 104         -> (CLabel, SRT)
 105         -> Int
 106         -> Bool                 -- must include SRT field (i.e. it's a vector)
 107         -> UniqSM StixTreeList
 108
 109 genBitmapInfoTable liveness srt closure_type include_srt
 110   = returnUs (\xs -> StData PtrRep table : xs)
 111
 112   where
 113         table = if srt_len == 0 && not include_srt then
 114                    rest_of_table
 115                 else
 116                    srt_label : rest_of_table
 117
 118         rest_of_table =
 119                 [
 120                 {- par, prof, debug -}
 121                   layout_info
 122                 , StInt (toInteger type_info)
 123                 ]
 124
 125         layout_info = case liveness of
 126                         LvSmall mask -> StInt (toInteger (intBS mask))
 127                         LvLarge lbl  -> StCLbl lbl
 128
 129         type_info :: Word32
 130 #ifdef WORDS_BIGENDIAN
 131         type_info = (fromInt closure_type `shiftL` 16) .|.
 132                     (fromInt srt_len)
 133 #else
 134         type_info = (fromInt closure_type) .|.
 135                     (fromInt srt_len `shiftL` 16)
 136 #endif
 137
 138         (srt_label,srt_len) =
 139              case srt of
 140                 (lbl, NoSRT) -> (StInt 0, 0)
 141                 (lbl, SRT off len) ->
 142                         (StIndex DataPtrRep (StCLbl lbl)
 143                                 (StInt (toInteger off)), len)
 144 \end{code}