ghc/compiler/nativeGen/StixInfo.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1993-1998
   3 %
   4
   5 \begin{code}
   6 module StixInfo (
   7
   8         genCodeInfoTable, genBitmapInfoTable,
   9
  10         bitmapToIntegers, bitmapIsSmall, livenessIsSmall
  11
  12     ) where
  13
  14 #include "HsVersions.h"
  15 #include "../includes/config.h"
  16 #include "NCG.h"
  17
  18 import AbsCSyn          ( AbstractC(..), Liveness(..), C_SRT(..), needsSRT )
  19 import ClosureInfo      ( closurePtrsSize,
  20                           closureNonHdrSize, closureSMRep,
  21                           infoTableLabelFromCI,
  22                           closureSRT, closureSemiTag
  23                         )
  24 import PrimRep          ( PrimRep(..) )
  25 import SMRep            ( getSMRepClosureTypeInt )
  26 import Stix             -- all of it
  27 import UniqSupply       ( returnUs, UniqSM )
  28 import BitSet           ( BitSet, intBS )
  29 import Maybes           ( maybeToBool )
  30
  31 import Bits
  32 import Word
  33 \end{code}
  34
  35 Generating code for info tables (arrays of data).
  36
  37 \begin{code}
  38 genCodeInfoTable
  39     :: AbstractC
  40     -> UniqSM StixStmtList
  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
  48         table | needs_srt = srt_label : rest_of_table
  49               | otherwise = rest_of_table
  50
  51         rest_of_table =
  52                 [
  53                 {- par, prof, debug -}
  54                   StInt (toInteger layout_info)
  55                 , StInt (toInteger type_info)
  56                 ]
  57
  58         -- sigh: building up the info table is endian-dependent.
  59         -- ToDo: do this using .byte and .word directives.
  60         type_info :: Word32
  61 #ifdef WORDS_BIGENDIAN
  62         type_info = (fromIntegral closure_type `shiftL` 16) .|.
  63                     (fromIntegral srt_len)
  64 #else
  65         type_info = (fromIntegral closure_type) .|.
  66                     (fromIntegral srt_len `shiftL` 16)
  67 #endif
  68         srt       = closureSRT cl_info
  69         needs_srt = needsSRT srt
  70
  71         (srt_label,srt_len)
  72            | is_constr
  73            = (StInt 0, tag)
  74            | otherwise
  75            = case srt of
  76                 NoC_SRT           -> (StInt 0, 0)
  77                 C_SRT lbl off len -> (StIndex DataPtrRep (StCLbl lbl) (StInt (toInteger off)), len)
  78
  79         maybe_tag = closureSemiTag cl_info
  80         is_constr = maybeToBool maybe_tag
  81         (Just tag) = maybe_tag
  82
  83         layout_info :: Word32
  84 #ifdef WORDS_BIGENDIAN
  85         layout_info = (fromIntegral ptrs `shiftL` 16) .|. fromIntegral nptrs
  86 #else
  87         layout_info = (fromIntegral ptrs) .|. (fromIntegral nptrs `shiftL` 16)
  88 #endif
  89
  90         ptrs    = closurePtrsSize cl_info
  91         nptrs   = size - ptrs
  92
  93         size = closureNonHdrSize cl_info
  94
  95         closure_type = getSMRepClosureTypeInt (closureSMRep cl_info)
  96
  97
  98
  99 genBitmapInfoTable
 100         :: Liveness
 101         -> C_SRT
 102         -> Int
 103         -> Bool                 -- must include SRT field (i.e. it's a vector)
 104         -> UniqSM StixStmtList
 105
 106 genBitmapInfoTable liveness srt closure_type include_srt
 107   = returnUs (\xs -> StData PtrRep table : xs)
 108
 109   where
 110         table = if srt_len == 0 && not include_srt then
 111                    rest_of_table
 112                 else
 113                    srt_label : rest_of_table
 114
 115         rest_of_table =
 116                 [
 117                 {- par, prof, debug -}
 118                   layout_info
 119                 , StInt (toInteger type_info)
 120                 ]
 121
 122         layout_info = case liveness of
 123                       Liveness lbl mask ->
 124                         case bitmapToIntegers mask of
 125                         [ ] -> StInt 0
 126                         [i] -> StInt i
 127                         _   -> StCLbl lbl
 128
 129         type_info :: Word32
 130 #ifdef WORDS_BIGENDIAN
 131         type_info = (fromIntegral closure_type `shiftL` 16) .|.
 132                     (fromIntegral srt_len)
 133 #else
 134         type_info = (fromIntegral closure_type) .|.
 135                     (fromIntegral srt_len `shiftL` 16)
 136 #endif
 137
 138         (srt_label,srt_len) =
 139              case srt of
 140                 NoC_SRT -> (StInt 0, 0)
 141                 C_SRT lbl off len ->
 142                         (StIndex DataPtrRep (StCLbl lbl)
 143                                 (StInt (toInteger off)), len)
 144
 145 bitmapToIntegers :: [BitSet] -> [Integer]
 146 bitmapToIntegers = bundle . map (toInteger . intBS)
 147   where
 148 #if BYTES_PER_WORD == 4
 149     bundle = id
 150 #else
 151     bundle [] = []
 152     bundle is = case splitAt (BYTES_PER_WORD/4) is of
 153                 (these, those) ->
 154                     ( foldr1 (\x y -> x + 4294967296 * y)
 155                              [x `mod` 4294967296 | x <- these]
 156                     : bundle those
 157                     )
 158 #endif
 159
 160 bitmapIsSmall :: [BitSet] -> Bool
 161 bitmapIsSmall bitmap
 162   = case bitmapToIntegers bitmap of
 163     _:_:_ -> False
 164     _     -> True
 165
 166 livenessIsSmall :: Liveness -> Bool
 167 livenessIsSmall (Liveness _ mask) = bitmapIsSmall mask
 168 \end{code}