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 StgSyn           ( SRT(..) )
  20 import ClosureInfo      ( closurePtrsSize,
  21                           closureNonHdrSize, closureSMRep,
  22                           infoTableLabelFromCI,
  23                           closureSRT, closureSemiTag
  24                         )
  25 import PrimRep          ( PrimRep(..) )
  26 import SMRep            ( getSMRepClosureTypeInt )
  27 import Stix             -- all of it
  28 import UniqSupply       ( returnUs, UniqSM )
  29 import BitSet           ( BitSet, intBS )
  30 import Maybes           ( maybeToBool )
  31
  32 import Bits
  33 import Word
  34 \end{code}
  35
  36 Generating code for info tables (arrays of data).
  37
  38 \begin{code}
  39 genCodeInfoTable
  40     :: AbstractC
  41     -> UniqSM StixStmtList
  42
  43 genCodeInfoTable (CClosureInfoAndCode cl_info _ _ cl_descr)
  44   = returnUs (\xs -> StData PtrRep table : StLabel info_lbl : xs)
  45
  46     where
  47         info_lbl  = infoTableLabelFromCI 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 = (fromIntegral closure_type `shiftL` 16) .|.
  64                     (fromIntegral srt_len)
  65 #else
  66         type_info = (fromIntegral closure_type) .|.
  67                     (fromIntegral srt_len `shiftL` 16)
  68 #endif
  69         srt       = closureSRT cl_info
  70         needs_srt = needsSRT srt
  71
  72         (srt_label,srt_len)
  73            | is_constr
  74            = (StInt 0, tag)
  75            | otherwise
  76            = case srt of
  77                 NoC_SRT           -> (StInt 0, 0)
  78                 C_SRT lbl off len -> (StIndex DataPtrRep (StCLbl lbl) (StInt (toInteger off)), len)
  79
  80         maybe_tag = closureSemiTag cl_info
  81         is_constr = maybeToBool maybe_tag
  82         (Just tag) = maybe_tag
  83
  84         layout_info :: Word32
  85 #ifdef WORDS_BIGENDIAN
  86         layout_info = (fromIntegral ptrs `shiftL` 16) .|. fromIntegral nptrs
  87 #else
  88         layout_info = (fromIntegral ptrs) .|. (fromIntegral nptrs `shiftL` 16)
  89 #endif
  90
  91         ptrs    = closurePtrsSize cl_info
  92         nptrs   = size - ptrs
  93
  94         size = closureNonHdrSize cl_info
  95
  96         closure_type = getSMRepClosureTypeInt (closureSMRep cl_info)
  97
  98
  99
 100 genBitmapInfoTable
 101         :: Liveness
 102         -> C_SRT
 103         -> Int
 104         -> Bool                 -- must include SRT field (i.e. it's a vector)
 105         -> UniqSM StixStmtList
 106
 107 genBitmapInfoTable liveness srt closure_type include_srt
 108   = returnUs (\xs -> StData PtrRep table : xs)
 109
 110   where
 111         table = if srt_len == 0 && not include_srt then
 112                    rest_of_table
 113                 else
 114                    srt_label : rest_of_table
 115
 116         rest_of_table =
 117                 [
 118                 {- par, prof, debug -}
 119                   layout_info
 120                 , StInt (toInteger type_info)
 121                 ]
 122
 123         layout_info = case liveness of
 124                       Liveness lbl mask ->
 125                         case bitmapToIntegers mask of
 126                         [ ] -> StInt 0
 127                         [i] -> StInt i
 128                         _   -> StCLbl lbl
 129
 130         type_info :: Word32
 131 #ifdef WORDS_BIGENDIAN
 132         type_info = (fromIntegral closure_type `shiftL` 16) .|.
 133                     (fromIntegral srt_len)
 134 #else
 135         type_info = (fromIntegral closure_type) .|.
 136                     (fromIntegral srt_len `shiftL` 16)
 137 #endif
 138
 139         (srt_label,srt_len) =
 140              case srt of
 141                 NoC_SRT -> (StInt 0, 0)
 142                 C_SRT lbl off len ->
 143                         (StIndex DataPtrRep (StCLbl lbl)
 144                                 (StInt (toInteger off)), len)
 145
 146 bitmapToIntegers :: [BitSet] -> [Integer]
 147 bitmapToIntegers = bundle . map (toInteger . intBS)
 148   where
 149 #if BYTES_PER_WORD == 4
 150     bundle = id
 151 #else
 152     bundle [] = []
 153     bundle is = case splitAt (BYTES_PER_WORD/4) is of
 154                 (these, those) ->
 155                     ( foldr1 (\x y -> x + 4294967296 * y)
 156                              [x `mod` 4294967296 | x <- these]
 157                     : bundle those
 158                     )
 159 #endif
 160
 161 bitmapIsSmall :: [BitSet] -> Bool
 162 bitmapIsSmall bitmap
 163   = case bitmapToIntegers bitmap of
 164     _:_:_ -> False
 165     _     -> True
 166
 167 livenessIsSmall :: Liveness -> Bool
 168 livenessIsSmall (Liveness _ mask) = bitmapIsSmall mask
 169 \end{code}