Fix Ticky histogram on Windows
[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 -- See Note [Warnings in code generated by Alex] in compiler/parser/Lexer.x
15 {-# OPTIONS_GHC -fno-warn-unused-matches #-}
16 {-# OPTIONS_GHC -fno-warn-unused-binds #-}
17 {-# OPTIONS_GHC -fno-warn-unused-imports #-}
18 {-# OPTIONS_GHC -fno-warn-tabs #-}
19 {-# OPTIONS_GHC -fno-warn-missing-signatures #-}
20
21 module CmmLex (
22    CmmToken(..), cmmlex,
23   ) where
24
25 import CmmExpr
26
27 import Lexer
28 import CmmMonad
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   MachSp                { global_reg MachSp }
115   UnwindReturnReg       { global_reg UnwindReturnReg }
116
117   $namebegin $namechar* { name }
118
119   0 @octal              { tok_octal }
120   @decimal              { tok_decimal }
121   0[xX] @hexadecimal    { tok_hexadecimal }
122   @floating_point       { strtoken tok_float }
123
124   \" @strchar* \"       { strtoken tok_string }
125 }
126
127 {
128 data CmmToken
129   = CmmT_SpecChar  Char
130   | CmmT_DotDot
131   | CmmT_DoubleColon
132   | CmmT_Shr
133   | CmmT_Shl
134   | CmmT_Ge
135   | CmmT_Le
136   | CmmT_Eq
137   | CmmT_Ne
138   | CmmT_BoolAnd
139   | CmmT_BoolOr
140   | CmmT_CLOSURE
141   | CmmT_INFO_TABLE
142   | CmmT_INFO_TABLE_RET
143   | CmmT_INFO_TABLE_FUN
144   | CmmT_INFO_TABLE_CONSTR
145   | CmmT_INFO_TABLE_SELECTOR
146   | CmmT_else
147   | CmmT_export
148   | CmmT_section
149   | CmmT_goto
150   | CmmT_if
151   | CmmT_call
152   | CmmT_jump
153   | CmmT_foreign
154   | CmmT_never
155   | CmmT_prim
156   | CmmT_reserve
157   | CmmT_return
158   | CmmT_returns
159   | CmmT_import
160   | CmmT_switch
161   | CmmT_case
162   | CmmT_default
163   | CmmT_push
164   | CmmT_unwind
165   | CmmT_bits8
166   | CmmT_bits16
167   | CmmT_bits32
168   | CmmT_bits64
169   | CmmT_bits128
170   | CmmT_bits256
171   | CmmT_bits512
172   | CmmT_float32
173   | CmmT_float64
174   | CmmT_gcptr
175   | CmmT_GlobalReg GlobalReg
176   | CmmT_Name      FastString
177   | CmmT_String    String
178   | CmmT_Int       Integer
179   | CmmT_Float     Rational
180   | CmmT_EOF
181   deriving (Show)
182
183 -- -----------------------------------------------------------------------------
184 -- Lexer actions
185
186 type Action = RealSrcSpan -> StringBuffer -> Int -> PD (RealLocated CmmToken)
187
188 begin :: Int -> Action
189 begin code _span _str _len = do liftP (pushLexState code); lexToken
190
191 pop :: Action
192 pop _span _buf _len = liftP popLexState >> lexToken
193
194 special_char :: Action
195 special_char span buf _len = return (L span (CmmT_SpecChar (currentChar buf)))
196
197 kw :: CmmToken -> Action
198 kw tok span _buf _len = return (L span tok)
199
200 global_regN :: (Int -> GlobalReg) -> Action
201 global_regN con span buf len
202   = return (L span (CmmT_GlobalReg (con (fromIntegral n))))
203   where buf' = stepOn buf
204         n = parseUnsignedInteger buf' (len-1) 10 octDecDigit
205
206 global_reg :: GlobalReg -> Action
207 global_reg r span _buf _len = return (L span (CmmT_GlobalReg r))
208
209 strtoken :: (String -> CmmToken) -> Action
210 strtoken f span buf len =
211   return (L span $! (f $! lexemeToString buf len))
212
213 name :: Action
214 name span buf len =
215   case lookupUFM reservedWordsFM fs of
216         Just tok -> return (L span tok)
217         Nothing  -> return (L span (CmmT_Name fs))
218   where
219         fs = lexemeToFastString buf len
220
221 reservedWordsFM = listToUFM $
222         map (\(x, y) -> (mkFastString x, y)) [
223         ( "CLOSURE",            CmmT_CLOSURE ),
224         ( "INFO_TABLE",         CmmT_INFO_TABLE ),
225         ( "INFO_TABLE_RET",     CmmT_INFO_TABLE_RET ),
226         ( "INFO_TABLE_FUN",     CmmT_INFO_TABLE_FUN ),
227         ( "INFO_TABLE_CONSTR",  CmmT_INFO_TABLE_CONSTR ),
228         ( "INFO_TABLE_SELECTOR",CmmT_INFO_TABLE_SELECTOR ),
229         ( "else",               CmmT_else ),
230         ( "export",             CmmT_export ),
231         ( "section",            CmmT_section ),
232         ( "goto",               CmmT_goto ),
233         ( "if",                 CmmT_if ),
234         ( "call",               CmmT_call ),
235         ( "jump",               CmmT_jump ),
236         ( "foreign",            CmmT_foreign ),
237         ( "never",              CmmT_never ),
238         ( "prim",               CmmT_prim ),
239         ( "reserve",            CmmT_reserve ),
240         ( "return",             CmmT_return ),
241         ( "returns",            CmmT_returns ),
242         ( "import",             CmmT_import ),
243         ( "switch",             CmmT_switch ),
244         ( "case",               CmmT_case ),
245         ( "default",            CmmT_default ),
246         ( "push",               CmmT_push ),
247         ( "unwind",             CmmT_unwind ),
248         ( "bits8",              CmmT_bits8 ),
249         ( "bits16",             CmmT_bits16 ),
250         ( "bits32",             CmmT_bits32 ),
251         ( "bits64",             CmmT_bits64 ),
252         ( "bits128",            CmmT_bits128 ),
253         ( "bits256",            CmmT_bits256 ),
254         ( "bits512",            CmmT_bits512 ),
255         ( "float32",            CmmT_float32 ),
256         ( "float64",            CmmT_float64 ),
257 -- New forms
258         ( "b8",                 CmmT_bits8 ),
259         ( "b16",                CmmT_bits16 ),
260         ( "b32",                CmmT_bits32 ),
261         ( "b64",                CmmT_bits64 ),
262         ( "b128",               CmmT_bits128 ),
263         ( "b256",               CmmT_bits256 ),
264         ( "b512",               CmmT_bits512 ),
265         ( "f32",                CmmT_float32 ),
266         ( "f64",                CmmT_float64 ),
267         ( "gcptr",              CmmT_gcptr )
268         ]
269
270 tok_decimal span buf len
271   = return (L span (CmmT_Int  $! parseUnsignedInteger buf len 10 octDecDigit))
272
273 tok_octal span buf len
274   = return (L span (CmmT_Int  $! parseUnsignedInteger (offsetBytes 1 buf) (len-1) 8 octDecDigit))
275
276 tok_hexadecimal span buf len
277   = return (L span (CmmT_Int  $! parseUnsignedInteger (offsetBytes 2 buf) (len-2) 16 hexDigit))
278
279 tok_float str = CmmT_Float $! readRational str
280
281 tok_string str = CmmT_String (read str)
282                  -- urk, not quite right, but it'll do for now
283
284 -- -----------------------------------------------------------------------------
285 -- Line pragmas
286
287 setLine :: Int -> Action
288 setLine code span buf len = do
289   let line = parseUnsignedInteger buf len 10 octDecDigit
290   liftP $ do
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   liftP $ do
301     setSrcLoc (mkRealSrcLoc file (srcSpanEndLine span) (srcSpanEndCol span))
302     popLexState >> pushLexState code
303   lexToken
304
305 -- -----------------------------------------------------------------------------
306 -- This is the top-level function: called from the parser each time a
307 -- new token is to be read from the input.
308
309 cmmlex :: (Located CmmToken -> PD a) -> PD a
310 cmmlex cont = do
311   (L span tok) <- lexToken
312   --trace ("token: " ++ show tok) $ do
313   cont (L (RealSrcSpan span) tok)
314
315 lexToken :: PD (RealLocated CmmToken)
316 lexToken = do
317   inp@(loc1,buf) <- getInput
318   sc <- liftP getLexState
319   case alexScan inp sc of
320     AlexEOF -> do let span = mkRealSrcSpan loc1 loc1
321                   liftP (setLastToken span 0)
322                   return (L span CmmT_EOF)
323     AlexError (loc2,_) -> liftP $ failLocMsgP loc1 loc2 "lexical error"
324     AlexSkip inp2 _ -> do
325         setInput inp2
326         lexToken
327     AlexToken inp2@(end,_buf2) len t -> do
328         setInput inp2
329         let span = mkRealSrcSpan loc1 end
330         span `seq` liftP (setLastToken span len)
331         t span buf len
332
333 -- -----------------------------------------------------------------------------
334 -- Monad stuff
335
336 -- Stuff that Alex needs to know about our input type:
337 type AlexInput = (RealSrcLoc,StringBuffer)
338
339 alexInputPrevChar :: AlexInput -> Char
340 alexInputPrevChar (_,s) = prevChar s '\n'
341
342 -- backwards compatibility for Alex 2.x
343 alexGetChar :: AlexInput -> Maybe (Char,AlexInput)
344 alexGetChar inp = case alexGetByte inp of
345                     Nothing    -> Nothing
346                     Just (b,i) -> c `seq` Just (c,i)
347                        where c = chr $ fromIntegral b
348
349 alexGetByte :: AlexInput -> Maybe (Word8,AlexInput)
350 alexGetByte (loc,s)
351   | atEnd s   = Nothing
352   | otherwise = b `seq` loc' `seq` s' `seq` Just (b, (loc', s'))
353   where c    = currentChar s
354         b    = fromIntegral $ ord $ c
355         loc' = advanceSrcLoc loc c
356         s'   = stepOn s
357
358 getInput :: PD AlexInput
359 getInput = PD $ \_ s@PState{ loc=l, buffer=b } -> POk s (l,b)
360
361 setInput :: AlexInput -> PD ()
362 setInput (l,b) = PD $ \_ s -> POk s{ loc=l, buffer=b } ()
363 }