Remove the implementation of gmp primops from the rts
[ghc-hetmet.git] / compiler / cmm / CmmLex.x
1 -----------------------------------------------------------------------------
2 --
3 -- (c) The University of Glasgow, 2004-2006
4 --
5 -- Lexer for concrete Cmm.  We try to stay close to the C-- spec, but there
6 -- are a few minor differences:
7 --
8 --   * extra keywords for our macros, and float32/float64 types
9 --   * global registers (Sp,Hp, etc.)
10 --
11 -----------------------------------------------------------------------------
12
13 {
14 {-# OPTIONS -Wwarn -w #-}
15 -- The above warning supression flag is a temporary kludge.
16 -- While working on this module you are encouraged to remove it and fix
17 -- any warnings in the module. See
18 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
19 -- for details
20
21 module CmmLex (
22    CmmToken(..), cmmlex,
23   ) where
24
25 #include "HsVersions.h"
26
27 import Cmm
28 import Lexer
29
30 import SrcLoc
31 import UniqFM
32 import StringBuffer
33 import FastString
34 import Ctype
35 import Util
36 --import TRACE
37 }
38
39 $whitechar   = [\ \t\n\r\f\v\xa0] -- \xa0 is Unicode no-break space
40 $white_no_nl = $whitechar # \n
41
42 $ascdigit  = 0-9
43 $unidigit  = \x01 -- Trick Alex into handling Unicode. See alexGetChar.
44 $digit     = [$ascdigit $unidigit]
45 $octit     = 0-7
46 $hexit     = [$digit A-F a-f]
47
48 $unilarge  = \x03 -- Trick Alex into handling Unicode. See alexGetChar.
49 $asclarge  = [A-Z \xc0-\xd6 \xd8-\xde]
50 $large     = [$asclarge $unilarge]
51
52 $unismall  = \x04 -- Trick Alex into handling Unicode. See alexGetChar.
53 $ascsmall  = [a-z \xdf-\xf6 \xf8-\xff]
54 $small     = [$ascsmall $unismall \_]
55
56 $namebegin = [$large $small \. \$ \@]
57 $namechar  = [$namebegin $digit]
58
59 @decimal     = $digit+
60 @octal       = $octit+
61 @hexadecimal = $hexit+
62 @exponent    = [eE] [\-\+]? @decimal
63
64 @floating_point = @decimal \. @decimal @exponent? | @decimal @exponent
65
66 @escape      = \\ ([abfnrt\\\'\"\?] | x $hexit{1,2} | $octit{1,3})
67 @strchar     = ($printable # [\"\\]) | @escape
68
69 cmm :-
70
71 $white_no_nl+           ;
72 ^\# pragma .* \n        ; -- Apple GCC 3.3 CPP generates pragmas in its output
73
74 ^\# (line)?             { begin line_prag }
75
76 -- single-line line pragmas, of the form
77 --    # <line> "<file>" <extra-stuff> \n
78 <line_prag> $digit+                     { setLine line_prag1 }
79 <line_prag1> \" ($printable # \")* \"   { setFile line_prag2 }
80 <line_prag2> .*                         { pop }
81
82 <0> {
83   \n                    ;
84
85   [\:\;\{\}\[\]\(\)\=\`\~\/\*\%\-\+\&\^\|\>\<\,\!]      { special_char }
86   
87   ".."                  { kw CmmT_DotDot }
88   "::"                  { kw CmmT_DoubleColon }
89   ">>"                  { kw CmmT_Shr }
90   "<<"                  { kw CmmT_Shl }
91   ">="                  { kw CmmT_Ge }
92   "<="                  { kw CmmT_Le }
93   "=="                  { kw CmmT_Eq }
94   "!="                  { kw CmmT_Ne }
95   "&&"                  { kw CmmT_BoolAnd }
96   "||"                  { kw CmmT_BoolOr }
97   
98   P@decimal             { global_regN (\n -> VanillaReg n VGcPtr) }
99   R@decimal             { global_regN (\n -> VanillaReg n VNonGcPtr) }
100   F@decimal             { global_regN FloatReg }
101   D@decimal             { global_regN DoubleReg }
102   L@decimal             { global_regN LongReg }
103   Sp                    { global_reg Sp }
104   SpLim                 { global_reg SpLim }
105   Hp                    { global_reg Hp }
106   HpLim                 { global_reg HpLim }
107   CurrentTSO            { global_reg CurrentTSO }
108   CurrentNursery        { global_reg CurrentNursery }
109   HpAlloc               { global_reg HpAlloc }
110   BaseReg               { global_reg BaseReg }
111   
112   $namebegin $namechar* { name }
113   
114   0 @octal              { tok_octal }
115   @decimal              { tok_decimal }
116   0[xX] @hexadecimal    { tok_hexadecimal }
117   @floating_point       { strtoken tok_float }
118   
119   \" @strchar* \"       { strtoken tok_string }
120 }
121
122 {
123 data CmmToken
124   = CmmT_SpecChar  Char
125   | CmmT_DotDot
126   | CmmT_DoubleColon
127   | CmmT_Shr
128   | CmmT_Shl
129   | CmmT_Ge
130   | CmmT_Le
131   | CmmT_Eq
132   | CmmT_Ne
133   | CmmT_BoolAnd
134   | CmmT_BoolOr
135   | CmmT_CLOSURE
136   | CmmT_INFO_TABLE
137   | CmmT_INFO_TABLE_RET
138   | CmmT_INFO_TABLE_FUN
139   | CmmT_INFO_TABLE_CONSTR
140   | CmmT_INFO_TABLE_SELECTOR
141   | CmmT_else
142   | CmmT_export
143   | CmmT_section
144   | CmmT_align
145   | CmmT_goto
146   | CmmT_if
147   | CmmT_jump
148   | CmmT_foreign
149   | CmmT_never
150   | CmmT_prim
151   | CmmT_return
152   | CmmT_returns
153   | CmmT_import
154   | CmmT_switch
155   | CmmT_case
156   | CmmT_default
157   | CmmT_bits8
158   | CmmT_bits16
159   | CmmT_bits32
160   | CmmT_bits64
161   | CmmT_float32
162   | CmmT_float64
163   | CmmT_gcptr
164   | CmmT_GlobalReg GlobalReg
165   | CmmT_Name      FastString
166   | CmmT_String    String
167   | CmmT_Int       Integer
168   | CmmT_Float     Rational
169   | CmmT_EOF
170 #ifdef DEBUG
171   deriving (Show)
172 #endif
173
174 -- -----------------------------------------------------------------------------
175 -- Lexer actions
176
177 type Action = SrcSpan -> StringBuffer -> Int -> P (Located CmmToken)
178
179 begin :: Int -> Action
180 begin code _span _str _len = do pushLexState code; lexToken
181
182 pop :: Action
183 pop _span _buf _len = do popLexState; lexToken
184
185 special_char :: Action
186 special_char span buf len = return (L span (CmmT_SpecChar (currentChar buf)))
187
188 kw :: CmmToken -> Action
189 kw tok span buf len = return (L span tok)
190
191 global_regN :: (Int -> GlobalReg) -> Action
192 global_regN con span buf len 
193   = return (L span (CmmT_GlobalReg (con (fromIntegral n))))
194   where buf' = stepOn buf
195         n = parseUnsignedInteger buf' (len-1) 10 octDecDigit
196
197 global_reg :: GlobalReg -> Action
198 global_reg r span buf len = return (L span (CmmT_GlobalReg r))
199
200 strtoken :: (String -> CmmToken) -> Action
201 strtoken f span buf len = 
202   return (L span $! (f $! lexemeToString buf len))
203
204 name :: Action
205 name span buf len = 
206   case lookupUFM reservedWordsFM fs of
207         Just tok -> return (L span tok)
208         Nothing  -> return (L span (CmmT_Name fs))
209   where
210         fs = lexemeToFastString buf len
211
212 reservedWordsFM = listToUFM $
213         map (\(x, y) -> (mkFastString x, y)) [
214         ( "CLOSURE",            CmmT_CLOSURE ),
215         ( "INFO_TABLE",         CmmT_INFO_TABLE ),
216         ( "INFO_TABLE_RET",     CmmT_INFO_TABLE_RET ),
217         ( "INFO_TABLE_FUN",     CmmT_INFO_TABLE_FUN ),
218         ( "INFO_TABLE_CONSTR",  CmmT_INFO_TABLE_CONSTR ),
219         ( "INFO_TABLE_SELECTOR",CmmT_INFO_TABLE_SELECTOR ),
220         ( "else",               CmmT_else ),
221         ( "export",             CmmT_export ),
222         ( "section",            CmmT_section ),
223         ( "align",              CmmT_align ),
224         ( "goto",               CmmT_goto ),
225         ( "if",                 CmmT_if ),
226         ( "jump",               CmmT_jump ),
227         ( "foreign",            CmmT_foreign ),
228         ( "never",              CmmT_never ),
229         ( "prim",               CmmT_prim ),
230         ( "return",             CmmT_return ),
231         ( "returns",            CmmT_returns ),
232         ( "import",             CmmT_import ),
233         ( "switch",             CmmT_switch ),
234         ( "case",               CmmT_case ),
235         ( "default",            CmmT_default ),
236         ( "bits8",              CmmT_bits8 ),
237         ( "bits16",             CmmT_bits16 ),
238         ( "bits32",             CmmT_bits32 ),
239         ( "bits64",             CmmT_bits64 ),
240         ( "float32",            CmmT_float32 ),
241         ( "float64",            CmmT_float64 ),
242 -- New forms
243         ( "b8",                 CmmT_bits8 ),
244         ( "b16",                CmmT_bits16 ),
245         ( "b32",                CmmT_bits32 ),
246         ( "b64",                CmmT_bits64 ),
247         ( "f32",                CmmT_float32 ),
248         ( "f64",                CmmT_float64 ),
249         ( "gcptr",              CmmT_gcptr )
250         ]
251
252 tok_decimal span buf len 
253   = return (L span (CmmT_Int  $! parseUnsignedInteger buf len 10 octDecDigit))
254
255 tok_octal span buf len 
256   = return (L span (CmmT_Int  $! parseUnsignedInteger (offsetBytes 1 buf) (len-1) 8 octDecDigit))
257
258 tok_hexadecimal span buf len 
259   = return (L span (CmmT_Int  $! parseUnsignedInteger (offsetBytes 2 buf) (len-2) 16 hexDigit))
260
261 tok_float str = CmmT_Float $! readRational str
262
263 tok_string str = CmmT_String (read str)
264                  -- urk, not quite right, but it'll do for now
265
266 -- -----------------------------------------------------------------------------
267 -- Line pragmas
268
269 setLine :: Int -> Action
270 setLine code span buf len = do
271   let line = parseUnsignedInteger buf len 10 octDecDigit
272   setSrcLoc (mkSrcLoc (srcSpanFile span) (fromIntegral line - 1) 0)
273         -- subtract one: the line number refers to the *following* line
274   -- trace ("setLine "  ++ show line) $ do
275   popLexState
276   pushLexState code
277   lexToken
278
279 setFile :: Int -> Action
280 setFile code span buf len = do
281   let file = lexemeToFastString (stepOn buf) (len-2)
282   setSrcLoc (mkSrcLoc file (srcSpanEndLine span) (srcSpanEndCol span))
283   popLexState
284   pushLexState code
285   lexToken
286
287 -- -----------------------------------------------------------------------------
288 -- This is the top-level function: called from the parser each time a
289 -- new token is to be read from the input.
290
291 cmmlex :: (Located CmmToken -> P a) -> P a
292 cmmlex cont = do
293   tok@(L _ tok__) <- lexToken
294   --trace ("token: " ++ show tok__) $ do
295   cont tok
296
297 lexToken :: P (Located CmmToken)
298 lexToken = do
299   inp@(loc1,buf) <- getInput
300   sc <- getLexState
301   case alexScan inp sc of
302     AlexEOF -> do let span = mkSrcSpan loc1 loc1
303                   setLastToken span 0 0
304                   return (L span CmmT_EOF)
305     AlexError (loc2,_) -> do failLocMsgP loc1 loc2 "lexical error"
306     AlexSkip inp2 _ -> do
307         setInput inp2
308         lexToken
309     AlexToken inp2@(end,buf2) len t -> do
310         setInput inp2
311         let span = mkSrcSpan loc1 end
312         span `seq` setLastToken span len len
313         t span buf len
314
315 -- -----------------------------------------------------------------------------
316 -- Monad stuff
317
318 -- Stuff that Alex needs to know about our input type:
319 type AlexInput = (SrcLoc,StringBuffer)
320
321 alexInputPrevChar :: AlexInput -> Char
322 alexInputPrevChar (_,s) = prevChar s '\n'
323
324 alexGetChar :: AlexInput -> Maybe (Char,AlexInput)
325 alexGetChar (loc,s) 
326   | atEnd s   = Nothing
327   | otherwise = c `seq` loc' `seq` s' `seq` Just (c, (loc', s'))
328   where c = currentChar s
329         loc' = advanceSrcLoc loc c
330         s'   = stepOn s
331
332 getInput :: P AlexInput
333 getInput = P $ \s@PState{ loc=l, buffer=b } -> POk s (l,b)
334
335 setInput :: AlexInput -> P ()
336 setInput (l,b) = P $ \s -> POk s{ loc=l, buffer=b } ()
337 }