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