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