compiler/cmm/CmmLex.x

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