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