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