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