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