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