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