[project @ 2000-06-29 13:08:59 by simonmar]
[ghc-hetmet.git] / ghc / compiler / nativeGen / StixInfo.lhs
1 %
2 % (c) The AQUA Project, Glasgow University, 1993-1998
3 %
4
5 \begin{code}
6 module StixInfo ( genCodeInfoTable, genBitmapInfoTable ) where
7
8 #include "HsVersions.h"
9 #include "../includes/config.h"
10
11 import AbsCSyn          ( AbstractC(..), Liveness(..) )
12 import CLabel           ( CLabel )
13 import StgSyn           ( SRT(..) )
14 import ClosureInfo      ( closurePtrsSize,
15                           closureNonHdrSize, closureSMRep,
16                           infoTableLabelFromCI,
17                           infoTblNeedsSRT, getSRTInfo, closureSemiTag
18                         )
19 import PrimRep          ( PrimRep(..) )
20 import SMRep            ( SMRep(..), getSMRepClosureTypeInt )
21 import Stix             -- all of it
22 import UniqSupply       ( returnUs, UniqSM )
23 import Outputable       ( int )
24 import BitSet           ( intBS )
25 import Maybes           ( maybeToBool )
26
27 import Bits
28 import Word
29
30 #if __GLASGOW_HASKELL__ >= 404
31 import GlaExts          ( fromInt )
32 #endif
33 \end{code}
34
35 Generating code for info tables (arrays of data).
36
37 \begin{code}
38 genCodeInfoTable
39     :: AbstractC
40     -> UniqSM StixTreeList
41
42 genCodeInfoTable (CClosureInfoAndCode cl_info _ _ cl_descr)
43   = returnUs (\xs -> StData PtrRep table : StLabel info_lbl : xs)
44
45     where
46         info_lbl  = infoTableLabelFromCI cl_info
47         needs_srt = infoTblNeedsSRT 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 = (fromInt closure_type `shiftL` 16) .|.
64                     (fromInt srt_len)
65 #else 
66         type_info = (fromInt closure_type) .|.
67                     (fromInt srt_len `shiftL` 16)
68 #endif       
69         srt = getSRTInfo cl_info             
70
71         (srt_label,srt_len)
72            | is_constr
73            = (StInt 0, tag)
74            | needs_srt
75            = case srt of
76                 (lbl, SRT off len) -> 
77                         (StIndex DataPtrRep (StCLbl lbl) 
78                                 (StInt (toInteger off)), len)
79            | otherwise
80            = (StInt 0, 0)
81
82         maybe_tag = closureSemiTag cl_info
83         is_constr = maybeToBool maybe_tag
84         (Just tag) = maybe_tag
85
86         layout_info :: Word32
87 #ifdef WORDS_BIGENDIAN
88         layout_info = (fromInt ptrs `shiftL` 16) .|. fromInt nptrs
89 #else 
90         layout_info = (fromInt ptrs) .|. (fromInt nptrs `shiftL` 16)
91 #endif       
92
93         ptrs    = closurePtrsSize cl_info
94         nptrs   = size - ptrs
95
96         size = closureNonHdrSize cl_info
97
98         closure_type = getSMRepClosureTypeInt (closureSMRep cl_info)
99
100
101
102 genBitmapInfoTable
103         :: Liveness
104         -> (CLabel, SRT)
105         -> Int
106         -> Bool                 -- must include SRT field (i.e. it's a vector)
107         -> UniqSM StixTreeList
108
109 genBitmapInfoTable liveness srt closure_type include_srt
110   = returnUs (\xs -> StData PtrRep table : xs)
111
112   where
113         table = if srt_len == 0 && not include_srt then
114                    rest_of_table
115                 else
116                    srt_label : rest_of_table
117
118         rest_of_table = 
119                 [
120                 {- par, prof, debug -} 
121                   layout_info
122                 , StInt (toInteger type_info)
123                 ]
124
125         layout_info = case liveness of
126                         LvSmall mask -> StInt (toInteger (intBS mask))
127                         LvLarge lbl  -> StCLbl lbl
128
129         type_info :: Word32
130 #ifdef WORDS_BIGENDIAN
131         type_info = (fromInt closure_type `shiftL` 16) .|.
132                     (fromInt srt_len)
133 #else 
134         type_info = (fromInt closure_type) .|.
135                     (fromInt srt_len `shiftL` 16)
136 #endif       
137
138         (srt_label,srt_len) = 
139              case srt of
140                 (lbl, NoSRT) -> (StInt 0, 0)
141                 (lbl, SRT off len) -> 
142                         (StIndex DataPtrRep (StCLbl lbl) 
143                                 (StInt (toInteger off)), len)
144 \end{code}