[project @ 2002-09-13 15:02:25 by simonpj]

[ghc-hetmet.git] / ghc / compiler / nativeGen / StixInfo.lhs

diff --git a/ghc/compiler/nativeGen/StixInfo.lhs b/ghc/compiler/nativeGen/StixInfo.lhs
index 3bf427e..7dcae06 100644 (file)
--- a/ghc/compiler/nativeGen/StixInfo.lhs
+++ b/ghc/compiler/nativeGen/StixInfo.lhs
@@ -3,32 +3,33 @@
 %
 
 \begin{code}
-module StixInfo ( genCodeInfoTable, genBitmapInfoTable ) where
+module StixInfo (
+
+       genCodeInfoTable, genBitmapInfoTable,
+
+       bitmapToIntegers, bitmapIsSmall, livenessIsSmall
+
+    ) where
 
 #include "HsVersions.h"
 #include "../includes/config.h"
+#include "NCG.h"
 
-import AbsCSyn         ( AbstractC(..), Liveness(..) )
-import CLabel          ( CLabel )
-import StgSyn          ( SRT(..) )
+import AbsCSyn         ( AbstractC(..), Liveness(..), C_SRT(..), needsSRT )
 import ClosureInfo     ( closurePtrsSize,
                          closureNonHdrSize, closureSMRep,
                          infoTableLabelFromCI,
-                         infoTblNeedsSRT, getSRTInfo
+                         closureSRT, closureSemiTag
                        )
 import PrimRep         ( PrimRep(..) )
-import SMRep           ( SMRep(..), getSMRepClosureTypeInt )
+import SMRep           ( getSMRepClosureTypeInt )
 import Stix            -- all of it
 import UniqSupply      ( returnUs, UniqSM )
-import Outputable      ( int )
-import BitSet          ( intBS )
-
-import Bits
-import Word
+import BitSet          ( BitSet, intBS )
+import Maybes          ( maybeToBool )
 
-#if __GLASGOW_HASKELL__ >= 404
-import GlaExts         ( fromInt )
-#endif
+import DATA_BITS
+import DATA_WORD
 \end{code}
 
 Generating code for info tables (arrays of data).
@@ -36,14 +37,13 @@ Generating code for info tables (arrays of data).
 \begin{code}
 genCodeInfoTable
     :: AbstractC
-    -> UniqSM StixTreeList
+    -> UniqSM StixStmtList
 
 genCodeInfoTable (CClosureInfoAndCode cl_info _ _ cl_descr)
   = returnUs (\xs -> StData PtrRep table : StLabel info_lbl : xs)
 
     where
        info_lbl  = infoTableLabelFromCI cl_info
-        needs_srt = infoTblNeedsSRT cl_info
 
        table | needs_srt = srt_label : rest_of_table
              | otherwise = rest_of_table
@@ -59,30 +59,32 @@ genCodeInfoTable (CClosureInfoAndCode cl_info _ _ cl_descr)
        -- ToDo: do this using .byte and .word directives.
        type_info :: Word32
 #ifdef WORDS_BIGENDIAN
-        type_info = (fromInt flags `shiftL` 24) .|.
-                   (fromInt closure_type `shiftL` 16) .|.
-                   (fromInt srt_len)
+        type_info = (fromIntegral closure_type `shiftL` 16) .|.
+                   (fromIntegral srt_len)
 #else 
-        type_info = (fromInt flags) .|.
-                   (fromInt closure_type `shiftL` 8) .|.
-                   (fromInt srt_len `shiftL` 16)
+        type_info = (fromIntegral closure_type) .|.
+                   (fromIntegral srt_len `shiftL` 16)
 #endif      
-       srt = getSRTInfo cl_info             
+       srt       = closureSRT cl_info       
+        needs_srt = needsSRT srt
 
        (srt_label,srt_len)
-           | needs_srt
-          = case srt of
-               (lbl, SRT off len) -> 
-                       (StIndex DataPtrRep (StCLbl lbl) 
-                               (StInt (toInteger off)), len)
+           | is_constr
+           = (StInt 0, tag)
            | otherwise
-           = (StInt 0, 0)
+          = case srt of
+               NoC_SRT           -> (StInt 0, 0)
+               C_SRT lbl off len -> (StIndex DataPtrRep (StCLbl lbl) (StInt (toInteger off)), len)
+
+        maybe_tag = closureSemiTag cl_info
+        is_constr = maybeToBool maybe_tag
+        (Just tag) = maybe_tag
 
        layout_info :: Word32
 #ifdef WORDS_BIGENDIAN
-       layout_info = (fromInt ptrs `shiftL` 16) .|. fromInt nptrs
+       layout_info = (fromIntegral ptrs `shiftL` 16) .|. fromIntegral nptrs
 #else 
-       layout_info = (fromInt ptrs) .|. (fromInt nptrs `shiftL` 16)
+       layout_info = (fromIntegral ptrs) .|. (fromIntegral nptrs `shiftL` 16)
 #endif      
 
        ptrs    = closurePtrsSize cl_info
@@ -92,15 +94,14 @@ genCodeInfoTable (CClosureInfoAndCode cl_info _ _ cl_descr)
 
        closure_type = getSMRepClosureTypeInt (closureSMRep cl_info)
 
-       flags = 0 -- for now
 
 
 genBitmapInfoTable
        :: Liveness
-       -> (CLabel, SRT)
+       -> C_SRT
        -> Int
        -> Bool                 -- must include SRT field (i.e. it's a vector)
-       -> UniqSM StixTreeList
+       -> UniqSM StixStmtList
 
 genBitmapInfoTable liveness srt closure_type include_srt
   = returnUs (\xs -> StData PtrRep table : xs)
@@ -119,26 +120,49 @@ genBitmapInfoTable liveness srt closure_type include_srt
                ]
 
        layout_info = case liveness of
-                       LvSmall mask -> StInt (toInteger (intBS mask))
-                       LvLarge lbl  -> StCLbl lbl
+                     Liveness lbl mask ->
+                       case bitmapToIntegers mask of
+                       [ ] -> StInt 0
+                       [i] -> StInt i
+                       _   -> StCLbl lbl
 
        type_info :: Word32
 #ifdef WORDS_BIGENDIAN
-        type_info = (fromInt flags `shiftL` 24) .|.
-                   (fromInt closure_type `shiftL` 16) .|.
-                   (fromInt srt_len)
+        type_info = (fromIntegral closure_type `shiftL` 16) .|.
+                   (fromIntegral srt_len)
 #else 
-        type_info = (fromInt flags) .|.
-                   (fromInt closure_type `shiftL` 8) .|.
-                   (fromInt srt_len `shiftL` 16)
+        type_info = (fromIntegral closure_type) .|.
+                   (fromIntegral srt_len `shiftL` 16)
 #endif      
 
        (srt_label,srt_len) = 
             case srt of
-               (lbl, NoSRT) -> (StInt 0, 0)
-               (lbl, SRT off len) -> 
+               NoC_SRT -> (StInt 0, 0)
+               C_SRT lbl off len -> 
                        (StIndex DataPtrRep (StCLbl lbl) 
                                (StInt (toInteger off)), len)
 
-       flags = 0 -- for now
+bitmapToIntegers :: [BitSet] -> [Integer]
+bitmapToIntegers = bundle . map (toInteger . intBS)
+  where
+#if BYTES_PER_WORD == 4
+    bundle = id
+#else
+    bundle [] = []
+    bundle is = case splitAt (BYTES_PER_WORD/4) is of
+                (these, those) ->
+                   ( foldr1 (\x y -> x + 4294967296 * y)
+                            [x `mod` 4294967296 | x <- these]
+                   : bundle those
+                   )
+#endif
+
+bitmapIsSmall :: [BitSet] -> Bool
+bitmapIsSmall bitmap
+  = case bitmapToIntegers bitmap of
+    _:_:_ -> False
+    _     -> True
+
+livenessIsSmall :: Liveness -> Bool
+livenessIsSmall (Liveness _ mask) = bitmapIsSmall mask
 \end{code}