compiler/cmm/CmmParse.y

   1 -----------------------------------------------------------------------------
   2 --
   3 -- (c) The University of Glasgow, 2004-2006
   4 --
   5 -- Parser for concrete Cmm.
   6 --
   7 -----------------------------------------------------------------------------
   8
   9 {
  10 module CmmParse ( parseCmmFile ) where
  11
  12 import CgMonad
  13 import CgHeapery
  14 import CgUtils
  15 import CgProf
  16 import CgTicky
  17 import CgInfoTbls
  18 import CgForeignCall
  19 import CgTailCall
  20 import CgStackery
  21 import ClosureInfo
  22 import CgCallConv
  23 import CgClosure
  24 import CostCentre
  25
  26 import Cmm
  27 import PprCmm
  28 import CmmUtils
  29 import CmmLex
  30 import CLabel
  31 import MachOp
  32 import SMRep
  33 import Lexer
  34
  35 import ForeignCall
  36 import Literal
  37 import Unique
  38 import UniqFM
  39 import SrcLoc
  40 import DynFlags
  41 import StaticFlags
  42 import ErrUtils
  43 import StringBuffer
  44 import FastString
  45 import Panic
  46 import Constants
  47 import Outputable
  48
  49 import Control.Monad
  50 import Data.Char        ( ord )
  51 import System.Exit
  52
  53 #include "HsVersions.h"
  54 }
  55
  56 %token
  57         ':'     { L _ (CmmT_SpecChar ':') }
  58         ';'     { L _ (CmmT_SpecChar ';') }
  59         '{'     { L _ (CmmT_SpecChar '{') }
  60         '}'     { L _ (CmmT_SpecChar '}') }
  61         '['     { L _ (CmmT_SpecChar '[') }
  62         ']'     { L _ (CmmT_SpecChar ']') }
  63         '('     { L _ (CmmT_SpecChar '(') }
  64         ')'     { L _ (CmmT_SpecChar ')') }
  65         '='     { L _ (CmmT_SpecChar '=') }
  66         '`'     { L _ (CmmT_SpecChar '`') }
  67         '~'     { L _ (CmmT_SpecChar '~') }
  68         '/'     { L _ (CmmT_SpecChar '/') }
  69         '*'     { L _ (CmmT_SpecChar '*') }
  70         '%'     { L _ (CmmT_SpecChar '%') }
  71         '-'     { L _ (CmmT_SpecChar '-') }
  72         '+'     { L _ (CmmT_SpecChar '+') }
  73         '&'     { L _ (CmmT_SpecChar '&') }
  74         '^'     { L _ (CmmT_SpecChar '^') }
  75         '|'     { L _ (CmmT_SpecChar '|') }
  76         '>'     { L _ (CmmT_SpecChar '>') }
  77         '<'     { L _ (CmmT_SpecChar '<') }
  78         ','     { L _ (CmmT_SpecChar ',') }
  79         '!'     { L _ (CmmT_SpecChar '!') }
  80
  81         '..'    { L _ (CmmT_DotDot) }
  82         '::'    { L _ (CmmT_DoubleColon) }
  83         '>>'    { L _ (CmmT_Shr) }
  84         '<<'    { L _ (CmmT_Shl) }
  85         '>='    { L _ (CmmT_Ge) }
  86         '<='    { L _ (CmmT_Le) }
  87         '=='    { L _ (CmmT_Eq) }
  88         '!='    { L _ (CmmT_Ne) }
  89         '&&'    { L _ (CmmT_BoolAnd) }
  90         '||'    { L _ (CmmT_BoolOr) }
  91
  92         'CLOSURE'       { L _ (CmmT_CLOSURE) }
  93         'INFO_TABLE'    { L _ (CmmT_INFO_TABLE) }
  94         'INFO_TABLE_RET'{ L _ (CmmT_INFO_TABLE_RET) }
  95         'INFO_TABLE_FUN'{ L _ (CmmT_INFO_TABLE_FUN) }
  96         'INFO_TABLE_CONSTR'{ L _ (CmmT_INFO_TABLE_CONSTR) }
  97         'INFO_TABLE_SELECTOR'{ L _ (CmmT_INFO_TABLE_SELECTOR) }
  98         'else'          { L _ (CmmT_else) }
  99         'export'        { L _ (CmmT_export) }
 100         'section'       { L _ (CmmT_section) }
 101         'align'         { L _ (CmmT_align) }
 102         'goto'          { L _ (CmmT_goto) }
 103         'if'            { L _ (CmmT_if) }
 104         'jump'          { L _ (CmmT_jump) }
 105         'foreign'       { L _ (CmmT_foreign) }
 106         'prim'          { L _ (CmmT_prim) }
 107         'return'        { L _ (CmmT_return) }
 108         'import'        { L _ (CmmT_import) }
 109         'switch'        { L _ (CmmT_switch) }
 110         'case'          { L _ (CmmT_case) }
 111         'default'       { L _ (CmmT_default) }
 112         'bits8'         { L _ (CmmT_bits8) }
 113         'bits16'        { L _ (CmmT_bits16) }
 114         'bits32'        { L _ (CmmT_bits32) }
 115         'bits64'        { L _ (CmmT_bits64) }
 116         'float32'       { L _ (CmmT_float32) }
 117         'float64'       { L _ (CmmT_float64) }
 118
 119         GLOBALREG       { L _ (CmmT_GlobalReg   $$) }
 120         NAME            { L _ (CmmT_Name        $$) }
 121         STRING          { L _ (CmmT_String      $$) }
 122         INT             { L _ (CmmT_Int         $$) }
 123         FLOAT           { L _ (CmmT_Float       $$) }
 124
 125 %monad { P } { >>= } { return }
 126 %lexer { cmmlex } { L _ CmmT_EOF }
 127 %name cmmParse cmm
 128 %tokentype { Located CmmToken }
 129
 130 -- C-- operator precedences, taken from the C-- spec
 131 %right '||'     -- non-std extension, called %disjoin in C--
 132 %right '&&'     -- non-std extension, called %conjoin in C--
 133 %right '!'
 134 %nonassoc '>=' '>' '<=' '<' '!=' '=='
 135 %left '|'
 136 %left '^'
 137 %left '&'
 138 %left '>>' '<<'
 139 %left '-' '+'
 140 %left '/' '*' '%'
 141 %right '~'
 142
 143 %%
 144
 145 cmm     :: { ExtCode }
 146         : {- empty -}                   { return () }
 147         | cmmtop cmm                    { do $1; $2 }
 148
 149 cmmtop  :: { ExtCode }
 150         : cmmproc                       { $1 }
 151         | cmmdata                       { $1 }
 152         | decl                          { $1 }
 153         | 'CLOSURE' '(' NAME ',' NAME lits ')' ';'
 154                 { do lits <- sequence $6;
 155                      staticClosure $3 $5 (map getLit lits) }
 156
 157 -- The only static closures in the RTS are dummy closures like
 158 -- stg_END_TSO_QUEUE_closure and stg_dummy_ret.  We don't need
 159 -- to provide the full generality of static closures here.
 160 -- In particular:
 161 --      * CCS can always be CCS_DONT_CARE
 162 --      * closure is always extern
 163 --      * payload is always empty
 164 --      * we can derive closure and info table labels from a single NAME
 165
 166 cmmdata :: { ExtCode }
 167         : 'section' STRING '{' statics '}'
 168                 { do ss <- sequence $4;
 169                      code (emitData (section $2) (concat ss)) }
 170
 171 statics :: { [ExtFCode [CmmStatic]] }
 172         : {- empty -}                   { [] }
 173         | static statics                { $1 : $2 }
 174
 175 -- Strings aren't used much in the RTS HC code, so it doesn't seem
 176 -- worth allowing inline strings.  C-- doesn't allow them anyway.
 177 static  :: { ExtFCode [CmmStatic] }
 178         : NAME ':'      { return [CmmDataLabel (mkRtsDataLabelFS $1)] }
 179         | type expr ';' { do e <- $2;
 180                              return [CmmStaticLit (getLit e)] }
 181         | type ';'                      { return [CmmUninitialised
 182                                                         (machRepByteWidth $1)] }
 183         | 'bits8' '[' ']' STRING ';'    { return [mkString $4] }
 184         | 'bits8' '[' INT ']' ';'       { return [CmmUninitialised
 185                                                         (fromIntegral $3)] }
 186         | typenot8 '[' INT ']' ';'      { return [CmmUninitialised
 187                                                 (machRepByteWidth $1 *
 188                                                         fromIntegral $3)] }
 189         | 'align' INT ';'               { return [CmmAlign (fromIntegral $2)] }
 190         | 'CLOSURE' '(' NAME lits ')'
 191                 { do lits <- sequence $4;
 192                      return $ map CmmStaticLit $
 193                        mkStaticClosure (mkRtsInfoLabelFS $3)
 194                          dontCareCCS (map getLit lits) [] [] [] }
 195         -- arrays of closures required for the CHARLIKE & INTLIKE arrays
 196
 197 lits    :: { [ExtFCode CmmExpr] }
 198         : {- empty -}           { [] }
 199         | ',' expr lits         { $2 : $3 }
 200
 201 cmmproc :: { ExtCode }
 202 -- TODO: add real SRT/info tables to parsed Cmm
 203         : info maybe_formals maybe_frame '{' body '}'
 204                 { do ((info_lbl, info, live, formals, frame), stmts) <-
 205                        getCgStmtsEC' $ loopDecls $ do {
 206                          (info_lbl, info, live) <- $1;
 207                          formals <- sequence $2;
 208                          frame <- $3;
 209                          $5;
 210                          return (info_lbl, info, live, formals, frame) }
 211                      blks <- code (cgStmtsToBlocks stmts)
 212                      code (emitInfoTableAndCode info_lbl (CmmInfo Nothing frame info) formals blks) }
 213
 214         | info maybe_formals ';'
 215                 { do (info_lbl, info, live) <- $1;
 216                      formals <- sequence $2;
 217                      code (emitInfoTableAndCode info_lbl (CmmInfo Nothing Nothing info) formals []) }
 218
 219         | NAME maybe_formals maybe_frame '{' body '}'
 220                 { do ((formals, frame), stmts) <-
 221                         getCgStmtsEC' $ loopDecls $ do {
 222                           formals <- sequence $2;
 223                           frame <- $3;
 224                           $5;
 225                           return (formals, frame) }
 226                      blks <- code (cgStmtsToBlocks stmts)
 227                      code (emitProc (CmmInfo Nothing frame CmmNonInfoTable) (mkRtsCodeLabelFS $1) formals blks) }
 228
 229 info    :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) }
 230         : 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
 231                 -- ptrs, nptrs, closure type, description, type
 232                 { do prof <- profilingInfo $11 $13
 233                      return (mkRtsInfoLabelFS $3,
 234                         CmmInfoTable prof (fromIntegral $9)
 235                                      (ThunkInfo (fromIntegral $5, fromIntegral $7) NoC_SRT),
 236                         []) }
 237
 238         | 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ')'
 239                 -- ptrs, nptrs, closure type, description, type, fun type
 240                 { do prof <- profilingInfo $11 $13
 241                      return (mkRtsInfoLabelFS $3,
 242                         CmmInfoTable prof (fromIntegral $9)
 243                                      (FunInfo (fromIntegral $5, fromIntegral $7) NoC_SRT (fromIntegral $15) 0
 244                                       (ArgSpec 0)
 245                                       zeroCLit),
 246                         []) }
 247                 -- we leave most of the fields zero here.  This is only used
 248                 -- to generate the BCO info table in the RTS at the moment.
 249
 250         | 'INFO_TABLE_CONSTR' '(' NAME ',' INT ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
 251                 -- ptrs, nptrs, tag, closure type, description, type
 252                 { do prof <- profilingInfo $13 $15
 253                      -- If profiling is on, this string gets duplicated,
 254                      -- but that's the way the old code did it we can fix it some other time.
 255                      desc_lit <- code $ mkStringCLit $13
 256                      return (mkRtsInfoLabelFS $3,
 257                         CmmInfoTable prof (fromIntegral $11)
 258                                      (ConstrInfo (fromIntegral $5, fromIntegral $7) (fromIntegral $9) desc_lit),
 259                         []) }
 260
 261         | 'INFO_TABLE_SELECTOR' '(' NAME ',' INT ',' INT ',' STRING ',' STRING ')'
 262                 -- selector, closure type, description, type
 263                 { do prof <- profilingInfo $9 $11
 264                      return (mkRtsInfoLabelFS $3,
 265                         CmmInfoTable prof (fromIntegral $7)
 266                                      (ThunkSelectorInfo (fromIntegral $5) NoC_SRT),
 267                         []) }
 268
 269         | 'INFO_TABLE_RET' '(' NAME ',' INT ')'
 270                 -- closure type (no live regs)
 271                 { return (mkRtsInfoLabelFS $3,
 272                         CmmInfoTable (ProfilingInfo zeroCLit zeroCLit) (fromIntegral $5)
 273                                      (ContInfo [] NoC_SRT),
 274                         []) }
 275
 276         | 'INFO_TABLE_RET' '(' NAME ',' INT ',' formals0 ')'
 277                 -- closure type, live regs
 278                 { do live <- sequence (map (liftM Just) $7)
 279                      return (mkRtsInfoLabelFS $3,
 280                         CmmInfoTable (ProfilingInfo zeroCLit zeroCLit) (fromIntegral $5)
 281                                      (ContInfo live NoC_SRT),
 282                         live) }
 283
 284 body    :: { ExtCode }
 285         : {- empty -}                   { return () }
 286         | decl body                     { do $1; $2 }
 287         | stmt body                     { do $1; $2 }
 288
 289 decl    :: { ExtCode }
 290         : type names ';'                { mapM_ (newLocal defaultKind $1) $2 }
 291         | STRING type names ';'         {% do k <- parseKind $1;
 292                                               return $ mapM_ (newLocal k $2) $3 }
 293
 294         | 'import' names ';'            { return () }  -- ignore imports
 295         | 'export' names ';'            { return () }  -- ignore exports
 296
 297 names   :: { [FastString] }
 298         : NAME                  { [$1] }
 299         | NAME ',' names        { $1 : $3 }
 300
 301 stmt    :: { ExtCode }
 302         : ';'                                   { nopEC }
 303
 304         | NAME ':'
 305                 { do l <- newLabel $1; code (labelC l) }
 306
 307         | lreg '=' expr ';'
 308                 { do reg <- $1; e <- $3; stmtEC (CmmAssign reg e) }
 309         | type '[' expr ']' '=' expr ';'
 310                 { doStore $1 $3 $6 }
 311
 312         -- Gah! We really want to say "maybe_results" but that causes
 313         -- a shift/reduce conflict with assignment.  We either
 314         -- we expand out the no-result and single result cases or
 315         -- we tweak the syntax to avoid the conflict.  The later
 316         -- option is taken here because the other way would require
 317         -- multiple levels of expanding and get unwieldy.
 318         | maybe_results 'foreign' STRING expr '(' hint_exprs0 ')' safety vols ';'
 319                 {% foreignCall $3 $1 $4 $6 $9 $8 }
 320         | maybe_results 'prim' '%' NAME '(' hint_exprs0 ')' safety vols ';'
 321                 {% primCall $1 $4 $6 $9 $8 }
 322         -- stmt-level macros, stealing syntax from ordinary C-- function calls.
 323         -- Perhaps we ought to use the %%-form?
 324         | NAME '(' exprs0 ')' ';'
 325                 {% stmtMacro $1 $3  }
 326         | 'switch' maybe_range expr '{' arms default '}'
 327                 { doSwitch $2 $3 $5 $6 }
 328         | 'goto' NAME ';'
 329                 { do l <- lookupLabel $2; stmtEC (CmmBranch l) }
 330         | 'jump' expr maybe_actuals ';'
 331                 { do e1 <- $2; e2 <- sequence $3; stmtEC (CmmJump e1 e2) }
 332         | 'return' maybe_actuals ';'
 333                 { do e <- sequence $2; stmtEC (CmmReturn e) }
 334         | 'if' bool_expr '{' body '}' else
 335                 { ifThenElse $2 $4 $6 }
 336
 337 bool_expr :: { ExtFCode BoolExpr }
 338         : bool_op                       { $1 }
 339         | expr                          { do e <- $1; return (BoolTest e) }
 340
 341 bool_op :: { ExtFCode BoolExpr }
 342         : bool_expr '&&' bool_expr      { do e1 <- $1; e2 <- $3;
 343                                           return (BoolAnd e1 e2) }
 344         | bool_expr '||' bool_expr      { do e1 <- $1; e2 <- $3;
 345                                           return (BoolOr e1 e2)  }
 346         | '!' bool_expr                 { do e <- $2; return (BoolNot e) }
 347         | '(' bool_op ')'               { $2 }
 348
 349 -- This is not C-- syntax.  What to do?
 350 safety  :: { CmmSafety }
 351         : {- empty -}                   { CmmUnsafe } -- Default may change soon
 352         | STRING                        {% parseSafety $1 }
 353
 354 -- This is not C-- syntax.  What to do?
 355 vols    :: { Maybe [GlobalReg] }
 356         : {- empty -}                   { Nothing }
 357         | '[' ']'                       { Just [] }
 358         | '[' globals ']'               { Just $2 }
 359
 360 globals :: { [GlobalReg] }
 361         : GLOBALREG                     { [$1] }
 362         | GLOBALREG ',' globals         { $1 : $3 }
 363
 364 maybe_range :: { Maybe (Int,Int) }
 365         : '[' INT '..' INT ']'  { Just (fromIntegral $2, fromIntegral $4) }
 366         | {- empty -}           { Nothing }
 367
 368 arms    :: { [([Int],ExtCode)] }
 369         : {- empty -}                   { [] }
 370         | arm arms                      { $1 : $2 }
 371
 372 arm     :: { ([Int],ExtCode) }
 373         : 'case' ints ':' '{' body '}'  { ($2, $5) }
 374
 375 ints    :: { [Int] }
 376         : INT                           { [ fromIntegral $1 ] }
 377         | INT ',' ints                  { fromIntegral $1 : $3 }
 378
 379 default :: { Maybe ExtCode }
 380         : 'default' ':' '{' body '}'    { Just $4 }
 381         -- taking a few liberties with the C-- syntax here; C-- doesn't have
 382         -- 'default' branches
 383         | {- empty -}                   { Nothing }
 384
 385 else    :: { ExtCode }
 386         : {- empty -}                   { nopEC }
 387         | 'else' '{' body '}'           { $3 }
 388
 389 -- we have to write this out longhand so that Happy's precedence rules
 390 -- can kick in.
 391 expr    :: { ExtFCode CmmExpr }
 392         : expr '/' expr                 { mkMachOp MO_U_Quot [$1,$3] }
 393         | expr '*' expr                 { mkMachOp MO_Mul [$1,$3] }
 394         | expr '%' expr                 { mkMachOp MO_U_Rem [$1,$3] }
 395         | expr '-' expr                 { mkMachOp MO_Sub [$1,$3] }
 396         | expr '+' expr                 { mkMachOp MO_Add [$1,$3] }
 397         | expr '>>' expr                { mkMachOp MO_U_Shr [$1,$3] }
 398         | expr '<<' expr                { mkMachOp MO_Shl [$1,$3] }
 399         | expr '&' expr                 { mkMachOp MO_And [$1,$3] }
 400         | expr '^' expr                 { mkMachOp MO_Xor [$1,$3] }
 401         | expr '|' expr                 { mkMachOp MO_Or [$1,$3] }
 402         | expr '>=' expr                { mkMachOp MO_U_Ge [$1,$3] }
 403         | expr '>' expr                 { mkMachOp MO_U_Gt [$1,$3] }
 404         | expr '<=' expr                { mkMachOp MO_U_Le [$1,$3] }
 405         | expr '<' expr                 { mkMachOp MO_U_Lt [$1,$3] }
 406         | expr '!=' expr                { mkMachOp MO_Ne [$1,$3] }
 407         | expr '==' expr                { mkMachOp MO_Eq [$1,$3] }
 408         | '~' expr                      { mkMachOp MO_Not [$2] }
 409         | '-' expr                      { mkMachOp MO_S_Neg [$2] }
 410         | expr0 '`' NAME '`' expr0      {% do { mo <- nameToMachOp $3 ;
 411                                                 return (mkMachOp mo [$1,$5]) } }
 412         | expr0                         { $1 }
 413
 414 expr0   :: { ExtFCode CmmExpr }
 415         : INT   maybe_ty         { return (CmmLit (CmmInt $1 $2)) }
 416         | FLOAT maybe_ty         { return (CmmLit (CmmFloat $1 $2)) }
 417         | STRING                 { do s <- code (mkStringCLit $1);
 418                                       return (CmmLit s) }
 419         | reg                    { $1 }
 420         | type '[' expr ']'      { do e <- $3; return (CmmLoad e $1) }
 421         | '%' NAME '(' exprs0 ')' {% exprOp $2 $4 }
 422         | '(' expr ')'           { $2 }
 423
 424
 425 -- leaving out the type of a literal gives you the native word size in C--
 426 maybe_ty :: { MachRep }
 427         : {- empty -}                   { wordRep }
 428         | '::' type                     { $2 }
 429
 430 maybe_actuals :: { [ExtFCode (CmmExpr, MachHint)] }
 431         : {- empty -}           { [] }
 432         | '(' hint_exprs0 ')'   { $2 }
 433
 434 hint_exprs0 :: { [ExtFCode (CmmExpr, MachHint)] }
 435         : {- empty -}                   { [] }
 436         | hint_exprs                    { $1 }
 437
 438 hint_exprs :: { [ExtFCode (CmmExpr, MachHint)] }
 439         : hint_expr                     { [$1] }
 440         | hint_expr ',' hint_exprs      { $1 : $3 }
 441
 442 hint_expr :: { ExtFCode (CmmExpr, MachHint) }
 443         : expr                          { do e <- $1; return (e, inferHint e) }
 444         | expr STRING                   {% do h <- parseHint $2;
 445                                               return $ do
 446                                                 e <- $1; return (e,h) }
 447
 448 exprs0  :: { [ExtFCode CmmExpr] }
 449         : {- empty -}                   { [] }
 450         | exprs                         { $1 }
 451
 452 exprs   :: { [ExtFCode CmmExpr] }
 453         : expr                          { [ $1 ] }
 454         | expr ',' exprs                { $1 : $3 }
 455
 456 reg     :: { ExtFCode CmmExpr }
 457         : NAME                  { lookupName $1 }
 458         | GLOBALREG             { return (CmmReg (CmmGlobal $1)) }
 459
 460 maybe_results :: { [ExtFCode (CmmFormal, MachHint)] }
 461         : {- empty -}           { [] }
 462         | '(' hint_lregs ')' '='        { $2 }
 463
 464 hint_lregs :: { [ExtFCode (CmmFormal, MachHint)] }
 465         : hint_lreg                     { [$1] }
 466         | hint_lreg ','                 { [$1] }
 467         | hint_lreg ',' hint_lregs      { $1 : $3 }
 468
 469 hint_lreg :: { ExtFCode (CmmFormal, MachHint) }
 470         : local_lreg                    { do e <- $1; return (e, inferHint (CmmReg (CmmLocal e))) }
 471         | STRING local_lreg             {% do h <- parseHint $1;
 472                                               return $ do
 473                                                 e <- $2; return (e,h) }
 474
 475 local_lreg :: { ExtFCode LocalReg }
 476         : NAME                  { do e <- lookupName $1;
 477                                      return $
 478                                        case e of
 479                                         CmmReg (CmmLocal r) -> r
 480                                         other -> pprPanic "CmmParse:" (ftext $1 <> text " not a local register") }
 481
 482 lreg    :: { ExtFCode CmmReg }
 483         : NAME                  { do e <- lookupName $1;
 484                                      return $
 485                                        case e of
 486                                         CmmReg r -> r
 487                                         other -> pprPanic "CmmParse:" (ftext $1 <> text " not a register") }
 488         | GLOBALREG             { return (CmmGlobal $1) }
 489
 490 maybe_formals :: { [ExtFCode LocalReg] }
 491         : {- empty -}           { [] }
 492         | '(' formals0 ')'      { $2 }
 493
 494 formals0 :: { [ExtFCode LocalReg] }
 495         : {- empty -}           { [] }
 496         | formals               { $1 }
 497
 498 formals :: { [ExtFCode LocalReg] }
 499         : formal ','            { [$1] }
 500         | formal                { [$1] }
 501         | formal ',' formals    { $1 : $3 }
 502
 503 formal :: { ExtFCode LocalReg }
 504         : type NAME             { newLocal defaultKind $1 $2 }
 505         | STRING type NAME      {% do k <- parseKind $1;
 506                                      return $ newLocal k $2 $3 }
 507
 508 maybe_frame :: { ExtFCode (Maybe UpdateFrame) }
 509         : {- empty -}                   { return Nothing }
 510         | 'jump' expr '(' exprs0 ')'    { do { target <- $2;
 511                                                args <- sequence $4;
 512                                                return $ Just (UpdateFrame target args) } }
 513
 514 type    :: { MachRep }
 515         : 'bits8'               { I8 }
 516         | typenot8              { $1 }
 517
 518 typenot8 :: { MachRep }
 519         : 'bits16'              { I16 }
 520         | 'bits32'              { I32 }
 521         | 'bits64'              { I64 }
 522         | 'float32'             { F32 }
 523         | 'float64'             { F64 }
 524 {
 525 section :: String -> Section
 526 section "text"   = Text
 527 section "data"   = Data
 528 section "rodata" = ReadOnlyData
 529 section "relrodata" = RelocatableReadOnlyData
 530 section "bss"    = UninitialisedData
 531 section s        = OtherSection s
 532
 533 mkString :: String -> CmmStatic
 534 mkString s = CmmString (map (fromIntegral.ord) s)
 535
 536 -- mkMachOp infers the type of the MachOp from the type of its first
 537 -- argument.  We assume that this is correct: for MachOps that don't have
 538 -- symmetrical args (e.g. shift ops), the first arg determines the type of
 539 -- the op.
 540 mkMachOp :: (MachRep -> MachOp) -> [ExtFCode CmmExpr] -> ExtFCode CmmExpr
 541 mkMachOp fn args = do
 542   arg_exprs <- sequence args
 543   return (CmmMachOp (fn (cmmExprRep (head arg_exprs))) arg_exprs)
 544
 545 getLit :: CmmExpr -> CmmLit
 546 getLit (CmmLit l) = l
 547 getLit (CmmMachOp (MO_S_Neg _) [CmmLit (CmmInt i r)])  = CmmInt (negate i) r
 548 getLit _ = panic "invalid literal" -- TODO messy failure
 549
 550 nameToMachOp :: FastString -> P (MachRep -> MachOp)
 551 nameToMachOp name =
 552   case lookupUFM machOps name of
 553         Nothing -> fail ("unknown primitive " ++ unpackFS name)
 554         Just m  -> return m
 555
 556 exprOp :: FastString -> [ExtFCode CmmExpr] -> P (ExtFCode CmmExpr)
 557 exprOp name args_code =
 558   case lookupUFM exprMacros name of
 559      Just f  -> return $ do
 560         args <- sequence args_code
 561         return (f args)
 562      Nothing -> do
 563         mo <- nameToMachOp name
 564         return $ mkMachOp mo args_code
 565
 566 exprMacros :: UniqFM ([CmmExpr] -> CmmExpr)
 567 exprMacros = listToUFM [
 568   ( FSLIT("ENTRY_CODE"),   \ [x] -> entryCode x ),
 569   ( FSLIT("INFO_PTR"),     \ [x] -> closureInfoPtr x ),
 570   ( FSLIT("STD_INFO"),     \ [x] -> infoTable x ),
 571   ( FSLIT("FUN_INFO"),     \ [x] -> funInfoTable x ),
 572   ( FSLIT("GET_ENTRY"),    \ [x] -> entryCode (closureInfoPtr x) ),
 573   ( FSLIT("GET_STD_INFO"), \ [x] -> infoTable (closureInfoPtr x) ),
 574   ( FSLIT("GET_FUN_INFO"), \ [x] -> funInfoTable (closureInfoPtr x) ),
 575   ( FSLIT("INFO_TYPE"),    \ [x] -> infoTableClosureType x ),
 576   ( FSLIT("INFO_PTRS"),    \ [x] -> infoTablePtrs x ),
 577   ( FSLIT("INFO_NPTRS"),   \ [x] -> infoTableNonPtrs x )
 578   ]
 579
 580 -- we understand a subset of C-- primitives:
 581 machOps = listToUFM $
 582         map (\(x, y) -> (mkFastString x, y)) [
 583         ( "add",        MO_Add ),
 584         ( "sub",        MO_Sub ),
 585         ( "eq",         MO_Eq ),
 586         ( "ne",         MO_Ne ),
 587         ( "mul",        MO_Mul ),
 588         ( "neg",        MO_S_Neg ),
 589         ( "quot",       MO_S_Quot ),
 590         ( "rem",        MO_S_Rem ),
 591         ( "divu",       MO_U_Quot ),
 592         ( "modu",       MO_U_Rem ),
 593
 594         ( "ge",         MO_S_Ge ),
 595         ( "le",         MO_S_Le ),
 596         ( "gt",         MO_S_Gt ),
 597         ( "lt",         MO_S_Lt ),
 598
 599         ( "geu",        MO_U_Ge ),
 600         ( "leu",        MO_U_Le ),
 601         ( "gtu",        MO_U_Gt ),
 602         ( "ltu",        MO_U_Lt ),
 603
 604         ( "flt",        MO_S_Lt ),
 605         ( "fle",        MO_S_Le ),
 606         ( "feq",        MO_Eq ),
 607         ( "fne",        MO_Ne ),
 608         ( "fgt",        MO_S_Gt ),
 609         ( "fge",        MO_S_Ge ),
 610         ( "fneg",       MO_S_Neg ),
 611
 612         ( "and",        MO_And ),
 613         ( "or",         MO_Or ),
 614         ( "xor",        MO_Xor ),
 615         ( "com",        MO_Not ),
 616         ( "shl",        MO_Shl ),
 617         ( "shrl",       MO_U_Shr ),
 618         ( "shra",       MO_S_Shr ),
 619
 620         ( "lobits8",  flip MO_U_Conv I8  ),
 621         ( "lobits16", flip MO_U_Conv I16 ),
 622         ( "lobits32", flip MO_U_Conv I32 ),
 623         ( "lobits64", flip MO_U_Conv I64 ),
 624         ( "sx16",     flip MO_S_Conv I16 ),
 625         ( "sx32",     flip MO_S_Conv I32 ),
 626         ( "sx64",     flip MO_S_Conv I64 ),
 627         ( "zx16",     flip MO_U_Conv I16 ),
 628         ( "zx32",     flip MO_U_Conv I32 ),
 629         ( "zx64",     flip MO_U_Conv I64 ),
 630         ( "f2f32",    flip MO_S_Conv F32 ),  -- TODO; rounding mode
 631         ( "f2f64",    flip MO_S_Conv F64 ),  -- TODO; rounding mode
 632         ( "f2i8",     flip MO_S_Conv I8 ),
 633         ( "f2i16",    flip MO_S_Conv I16 ),
 634         ( "f2i32",    flip MO_S_Conv I32 ),
 635         ( "f2i64",    flip MO_S_Conv I64 ),
 636         ( "i2f32",    flip MO_S_Conv F32 ),
 637         ( "i2f64",    flip MO_S_Conv F64 )
 638         ]
 639
 640 callishMachOps = listToUFM $
 641         map (\(x, y) -> (mkFastString x, y)) [
 642         ( "write_barrier", MO_WriteBarrier )
 643         -- ToDo: the rest, maybe
 644     ]
 645
 646 parseSafety :: String -> P CmmSafety
 647 parseSafety "safe"   = return (CmmSafe NoC_SRT)
 648 parseSafety "unsafe" = return CmmUnsafe
 649 parseSafety str      = fail ("unrecognised safety: " ++ str)
 650
 651 parseHint :: String -> P MachHint
 652 parseHint "ptr"    = return PtrHint
 653 parseHint "signed" = return SignedHint
 654 parseHint "float"  = return FloatHint
 655 parseHint str      = fail ("unrecognised hint: " ++ str)
 656
 657 parseKind :: String -> P Kind
 658 parseKind "ptr"    = return KindPtr
 659 parseKind str      = fail ("unrecognized kin: " ++ str)
 660
 661 defaultKind :: Kind
 662 defaultKind = KindNonPtr
 663
 664 -- labels are always pointers, so we might as well infer the hint
 665 inferHint :: CmmExpr -> MachHint
 666 inferHint (CmmLit (CmmLabel _)) = PtrHint
 667 inferHint (CmmReg (CmmGlobal g)) | isPtrGlobalReg g = PtrHint
 668 inferHint _ = NoHint
 669
 670 isPtrGlobalReg Sp               = True
 671 isPtrGlobalReg SpLim            = True
 672 isPtrGlobalReg Hp               = True
 673 isPtrGlobalReg HpLim            = True
 674 isPtrGlobalReg CurrentTSO       = True
 675 isPtrGlobalReg CurrentNursery   = True
 676 isPtrGlobalReg _                = False
 677
 678 happyError :: P a
 679 happyError = srcParseFail
 680
 681 -- -----------------------------------------------------------------------------
 682 -- Statement-level macros
 683
 684 stmtMacro :: FastString -> [ExtFCode CmmExpr] -> P ExtCode
 685 stmtMacro fun args_code = do
 686   case lookupUFM stmtMacros fun of
 687     Nothing -> fail ("unknown macro: " ++ unpackFS fun)
 688     Just fcode -> return $ do
 689         args <- sequence args_code
 690         code (fcode args)
 691
 692 stmtMacros :: UniqFM ([CmmExpr] -> Code)
 693 stmtMacros = listToUFM [
 694   ( FSLIT("CCS_ALLOC"),            \[words,ccs]  -> profAlloc words ccs ),
 695   ( FSLIT("CLOSE_NURSERY"),        \[]  -> emitCloseNursery ),
 696   ( FSLIT("ENTER_CCS_PAP_CL"),     \[e] -> enterCostCentrePAP e ),
 697   ( FSLIT("ENTER_CCS_THUNK"),      \[e] -> enterCostCentreThunk e ),
 698   ( FSLIT("HP_CHK_GEN"),           \[words,liveness,reentry] ->
 699                                       hpChkGen words liveness reentry ),
 700   ( FSLIT("HP_CHK_NP_ASSIGN_SP0"), \[e,f] -> hpChkNodePointsAssignSp0 e f ),
 701   ( FSLIT("LOAD_THREAD_STATE"),    \[] -> emitLoadThreadState ),
 702   ( FSLIT("LDV_ENTER"),            \[e] -> ldvEnter e ),
 703   ( FSLIT("LDV_RECORD_CREATE"),    \[e] -> ldvRecordCreate e ),
 704   ( FSLIT("OPEN_NURSERY"),         \[]  -> emitOpenNursery ),
 705   ( FSLIT("PUSH_UPD_FRAME"),       \[sp,e] -> emitPushUpdateFrame sp e ),
 706   ( FSLIT("SAVE_THREAD_STATE"),    \[] -> emitSaveThreadState ),
 707   ( FSLIT("SET_HDR"),              \[ptr,info,ccs] ->
 708                                         emitSetDynHdr ptr info ccs ),
 709   ( FSLIT("STK_CHK_GEN"),          \[words,liveness,reentry] ->
 710                                       stkChkGen words liveness reentry ),
 711   ( FSLIT("STK_CHK_NP"),           \[e] -> stkChkNodePoints e ),
 712   ( FSLIT("TICK_ALLOC_PRIM"),      \[hdr,goods,slop] ->
 713                                         tickyAllocPrim hdr goods slop ),
 714   ( FSLIT("TICK_ALLOC_PAP"),       \[goods,slop] ->
 715                                         tickyAllocPAP goods slop ),
 716   ( FSLIT("TICK_ALLOC_UP_THK"),    \[goods,slop] ->
 717                                         tickyAllocThunk goods slop ),
 718   ( FSLIT("UPD_BH_UPDATABLE"),       \[] -> emitBlackHoleCode False ),
 719   ( FSLIT("UPD_BH_SINGLE_ENTRY"),    \[] -> emitBlackHoleCode True ),
 720
 721   ( FSLIT("RET_P"),     \[a] ->       emitRetUT [(PtrArg,a)]),
 722   ( FSLIT("RET_N"),     \[a] ->       emitRetUT [(NonPtrArg,a)]),
 723   ( FSLIT("RET_PP"),    \[a,b] ->     emitRetUT [(PtrArg,a),(PtrArg,b)]),
 724   ( FSLIT("RET_NN"),    \[a,b] ->     emitRetUT [(NonPtrArg,a),(NonPtrArg,b)]),
 725   ( FSLIT("RET_NP"),    \[a,b] ->     emitRetUT [(NonPtrArg,a),(PtrArg,b)]),
 726   ( FSLIT("RET_PPP"),   \[a,b,c] ->   emitRetUT [(PtrArg,a),(PtrArg,b),(PtrArg,c)]),
 727   ( FSLIT("RET_NPP"),   \[a,b,c] ->   emitRetUT [(NonPtrArg,a),(PtrArg,b),(PtrArg,c)]),
 728   ( FSLIT("RET_NNP"),   \[a,b,c] ->   emitRetUT [(NonPtrArg,a),(NonPtrArg,b),(PtrArg,c)]),
 729   ( FSLIT("RET_NNNP"),  \[a,b,c,d] -> emitRetUT [(NonPtrArg,a),(NonPtrArg,b),(NonPtrArg,c),(PtrArg,d)]),
 730   ( FSLIT("RET_NPNP"),  \[a,b,c,d] -> emitRetUT [(NonPtrArg,a),(PtrArg,b),(NonPtrArg,c),(PtrArg,d)])
 731
 732  ]
 733
 734 -- -----------------------------------------------------------------------------
 735 -- Our extended FCode monad.
 736
 737 -- We add a mapping from names to CmmExpr, to support local variable names in
 738 -- the concrete C-- code.  The unique supply of the underlying FCode monad
 739 -- is used to grab a new unique for each local variable.
 740
 741 -- In C--, a local variable can be declared anywhere within a proc,
 742 -- and it scopes from the beginning of the proc to the end.  Hence, we have
 743 -- to collect declarations as we parse the proc, and feed the environment
 744 -- back in circularly (to avoid a two-pass algorithm).
 745
 746 data Named = Var CmmExpr | Label BlockId
 747 type Decls = [(FastString,Named)]
 748 type Env   = UniqFM Named
 749
 750 newtype ExtFCode a = EC { unEC :: Env -> Decls -> FCode (Decls, a) }
 751
 752 type ExtCode = ExtFCode ()
 753
 754 returnExtFC a = EC $ \e s -> return (s, a)
 755 thenExtFC (EC m) k = EC $ \e s -> do (s',r) <- m e s; unEC (k r) e s'
 756
 757 instance Monad ExtFCode where
 758   (>>=) = thenExtFC
 759   return = returnExtFC
 760
 761 -- This function takes the variable decarations and imports and makes
 762 -- an environment, which is looped back into the computation.  In this
 763 -- way, we can have embedded declarations that scope over the whole
 764 -- procedure, and imports that scope over the entire module.
 765 loopDecls :: ExtFCode a -> ExtFCode a
 766 loopDecls (EC fcode) =
 767    EC $ \e s -> fixC (\ ~(decls,a) -> fcode (addListToUFM e decls) [])
 768
 769 getEnv :: ExtFCode Env
 770 getEnv = EC $ \e s -> return (s, e)
 771
 772 addVarDecl :: FastString -> CmmExpr -> ExtCode
 773 addVarDecl var expr = EC $ \e s -> return ((var, Var expr):s, ())
 774
 775 addLabel :: FastString -> BlockId -> ExtCode
 776 addLabel name block_id = EC $ \e s -> return ((name, Label block_id):s, ())
 777
 778 newLocal :: Kind -> MachRep -> FastString -> ExtFCode LocalReg
 779 newLocal kind ty name = do
 780    u <- code newUnique
 781    let reg = LocalReg u ty kind
 782    addVarDecl name (CmmReg (CmmLocal reg))
 783    return reg
 784
 785 newLabel :: FastString -> ExtFCode BlockId
 786 newLabel name = do
 787    u <- code newUnique
 788    addLabel name (BlockId u)
 789    return (BlockId u)
 790
 791 lookupLabel :: FastString -> ExtFCode BlockId
 792 lookupLabel name = do
 793   env <- getEnv
 794   return $
 795      case lookupUFM env name of
 796         Just (Label l) -> l
 797         _other -> BlockId (newTagUnique (getUnique name) 'L')
 798
 799 -- Unknown names are treated as if they had been 'import'ed.
 800 -- This saves us a lot of bother in the RTS sources, at the expense of
 801 -- deferring some errors to link time.
 802 lookupName :: FastString -> ExtFCode CmmExpr
 803 lookupName name = do
 804   env <- getEnv
 805   return $
 806      case lookupUFM env name of
 807         Just (Var e) -> e
 808         _other -> CmmLit (CmmLabel (mkRtsCodeLabelFS name))
 809
 810 -- Lifting FCode computations into the ExtFCode monad:
 811 code :: FCode a -> ExtFCode a
 812 code fc = EC $ \e s -> do r <- fc; return (s, r)
 813
 814 code2 :: (FCode (Decls,b) -> FCode ((Decls,b),c))
 815          -> ExtFCode b -> ExtFCode c
 816 code2 f (EC ec) = EC $ \e s -> do ((s',b),c) <- f (ec e s); return (s',c)
 817
 818 nopEC = code nopC
 819 stmtEC stmt = code (stmtC stmt)
 820 stmtsEC stmts = code (stmtsC stmts)
 821 getCgStmtsEC = code2 getCgStmts'
 822 getCgStmtsEC' = code2 (\m -> getCgStmts' m >>= f)
 823   where f ((decl, b), c) = return ((decl, b), (b, c))
 824
 825 forkLabelledCodeEC ec = do
 826   stmts <- getCgStmtsEC ec
 827   code (forkCgStmts stmts)
 828
 829
 830 profilingInfo desc_str ty_str = do
 831   lit1 <- if opt_SccProfilingOn
 832                    then code $ mkStringCLit desc_str
 833                    else return (mkIntCLit 0)
 834   lit2 <- if opt_SccProfilingOn
 835                    then code $ mkStringCLit ty_str
 836                    else return (mkIntCLit 0)
 837   return (ProfilingInfo lit1 lit2)
 838
 839
 840 staticClosure :: FastString -> FastString -> [CmmLit] -> ExtCode
 841 staticClosure cl_label info payload
 842   = code $ emitDataLits (mkRtsDataLabelFS cl_label) lits
 843   where  lits = mkStaticClosure (mkRtsInfoLabelFS info) dontCareCCS payload [] [] []
 844
 845 foreignCall
 846         :: String
 847         -> [ExtFCode (CmmFormal,MachHint)]
 848         -> ExtFCode CmmExpr
 849         -> [ExtFCode (CmmExpr,MachHint)]
 850         -> Maybe [GlobalReg]
 851         -> CmmSafety
 852         -> P ExtCode
 853 foreignCall conv_string results_code expr_code args_code vols safety
 854   = do  convention <- case conv_string of
 855           "C" -> return CCallConv
 856           "C--" -> return CmmCallConv
 857           _ -> fail ("unknown calling convention: " ++ conv_string)
 858         return $ do
 859           results <- sequence results_code
 860           expr <- expr_code
 861           args <- sequence args_code
 862           case convention of
 863             -- Temporary hack so at least some functions are CmmSafe
 864             CmmCallConv -> code (stmtC (CmmCall (CmmForeignCall expr convention) results args safety))
 865             _ -> case safety of
 866               CmmUnsafe ->
 867                 code (emitForeignCall' PlayRisky results
 868                    (CmmForeignCall expr convention) args vols NoC_SRT)
 869               CmmSafe srt ->
 870                 code (emitForeignCall' (PlaySafe unused) results
 871                    (CmmForeignCall expr convention) args vols NoC_SRT) where
 872                 unused = panic "not used by emitForeignCall'"
 873
 874 primCall
 875         :: [ExtFCode (CmmFormal,MachHint)]
 876         -> FastString
 877         -> [ExtFCode (CmmExpr,MachHint)]
 878         -> Maybe [GlobalReg]
 879         -> CmmSafety
 880         -> P ExtCode
 881 primCall results_code name args_code vols safety
 882   = case lookupUFM callishMachOps name of
 883         Nothing -> fail ("unknown primitive " ++ unpackFS name)
 884         Just p  -> return $ do
 885                 results <- sequence results_code
 886                 args <- sequence args_code
 887                 case safety of
 888                   CmmUnsafe ->
 889                     code (emitForeignCall' PlayRisky results
 890                       (CmmPrim p) args vols NoC_SRT)
 891                   CmmSafe srt ->
 892                     code (emitForeignCall' (PlaySafe unused) results
 893                       (CmmPrim p) args vols NoC_SRT) where
 894                     unused = panic "not used by emitForeignCall'"
 895
 896 doStore :: MachRep -> ExtFCode CmmExpr  -> ExtFCode CmmExpr -> ExtCode
 897 doStore rep addr_code val_code
 898   = do addr <- addr_code
 899        val <- val_code
 900         -- if the specified store type does not match the type of the expr
 901         -- on the rhs, then we insert a coercion that will cause the type
 902         -- mismatch to be flagged by cmm-lint.  If we don't do this, then
 903         -- the store will happen at the wrong type, and the error will not
 904         -- be noticed.
 905        let coerce_val
 906                 | cmmExprRep val /= rep = CmmMachOp (MO_U_Conv rep rep) [val]
 907                 | otherwise             = val
 908        stmtEC (CmmStore addr coerce_val)
 909
 910 -- Return an unboxed tuple.
 911 emitRetUT :: [(CgRep,CmmExpr)] -> Code
 912 emitRetUT args = do
 913   tickyUnboxedTupleReturn (length args)  -- TICK
 914   (sp, stmts) <- pushUnboxedTuple 0 args
 915   emitStmts stmts
 916   when (sp /= 0) $ stmtC (CmmAssign spReg (cmmRegOffW spReg (-sp)))
 917   stmtC (CmmJump (entryCode (CmmLoad (cmmRegOffW spReg sp) wordRep)) [])
 918   -- TODO (when using CPS): emitStmt (CmmReturn (map snd args))
 919
 920 -- -----------------------------------------------------------------------------
 921 -- If-then-else and boolean expressions
 922
 923 data BoolExpr
 924   = BoolExpr `BoolAnd` BoolExpr
 925   | BoolExpr `BoolOr`  BoolExpr
 926   | BoolNot BoolExpr
 927   | BoolTest CmmExpr
 928
 929 -- ToDo: smart constructors which simplify the boolean expression.
 930
 931 ifThenElse cond then_part else_part = do
 932      then_id <- code newLabelC
 933      join_id <- code newLabelC
 934      c <- cond
 935      emitCond c then_id
 936      else_part
 937      stmtEC (CmmBranch join_id)
 938      code (labelC then_id)
 939      then_part
 940      -- fall through to join
 941      code (labelC join_id)
 942
 943 -- 'emitCond cond true_id'  emits code to test whether the cond is true,
 944 -- branching to true_id if so, and falling through otherwise.
 945 emitCond (BoolTest e) then_id = do
 946   stmtEC (CmmCondBranch e then_id)
 947 emitCond (BoolNot (BoolTest (CmmMachOp op args))) then_id
 948   | Just op' <- maybeInvertComparison op
 949   = emitCond (BoolTest (CmmMachOp op' args)) then_id
 950 emitCond (BoolNot e) then_id = do
 951   else_id <- code newLabelC
 952   emitCond e else_id
 953   stmtEC (CmmBranch then_id)
 954   code (labelC else_id)
 955 emitCond (e1 `BoolOr` e2) then_id = do
 956   emitCond e1 then_id
 957   emitCond e2 then_id
 958 emitCond (e1 `BoolAnd` e2) then_id = do
 959         -- we'd like to invert one of the conditionals here to avoid an
 960         -- extra branch instruction, but we can't use maybeInvertComparison
 961         -- here because we can't look too closely at the expression since
 962         -- we're in a loop.
 963   and_id <- code newLabelC
 964   else_id <- code newLabelC
 965   emitCond e1 and_id
 966   stmtEC (CmmBranch else_id)
 967   code (labelC and_id)
 968   emitCond e2 then_id
 969   code (labelC else_id)
 970
 971
 972 -- -----------------------------------------------------------------------------
 973 -- Table jumps
 974
 975 -- We use a simplified form of C-- switch statements for now.  A
 976 -- switch statement always compiles to a table jump.  Each arm can
 977 -- specify a list of values (not ranges), and there can be a single
 978 -- default branch.  The range of the table is given either by the
 979 -- optional range on the switch (eg. switch [0..7] {...}), or by
 980 -- the minimum/maximum values from the branches.
 981
 982 doSwitch :: Maybe (Int,Int) -> ExtFCode CmmExpr -> [([Int],ExtCode)]
 983          -> Maybe ExtCode -> ExtCode
 984 doSwitch mb_range scrut arms deflt
 985    = do
 986         -- Compile code for the default branch
 987         dflt_entry <-
 988                 case deflt of
 989                   Nothing -> return Nothing
 990                   Just e  -> do b <- forkLabelledCodeEC e; return (Just b)
 991
 992         -- Compile each case branch
 993         table_entries <- mapM emitArm arms
 994
 995         -- Construct the table
 996         let
 997             all_entries = concat table_entries
 998             ixs = map fst all_entries
 999             (min,max)
1000                 | Just (l,u) <- mb_range = (l,u)
1001                 | otherwise              = (minimum ixs, maximum ixs)
1002
1003             entries = elems (accumArray (\_ a -> Just a) dflt_entry (min,max)
1004                                 all_entries)
1005         expr <- scrut
1006         -- ToDo: check for out of range and jump to default if necessary
1007         stmtEC (CmmSwitch expr entries)
1008    where
1009         emitArm :: ([Int],ExtCode) -> ExtFCode [(Int,BlockId)]
1010         emitArm (ints,code) = do
1011            blockid <- forkLabelledCodeEC code
1012            return [ (i,blockid) | i <- ints ]
1013
1014
1015 -- -----------------------------------------------------------------------------
1016 -- Putting it all together
1017
1018 -- The initial environment: we define some constants that the compiler
1019 -- knows about here.
1020 initEnv :: Env
1021 initEnv = listToUFM [
1022   ( FSLIT("SIZEOF_StgHeader"),
1023     Var (CmmLit (CmmInt (fromIntegral (fixedHdrSize * wORD_SIZE)) wordRep) )),
1024   ( FSLIT("SIZEOF_StgInfoTable"),
1025     Var (CmmLit (CmmInt (fromIntegral stdInfoTableSizeB) wordRep) ))
1026   ]
1027
1028 parseCmmFile :: DynFlags -> FilePath -> IO (Maybe Cmm)
1029 parseCmmFile dflags filename = do
1030   showPass dflags "ParseCmm"
1031   buf <- hGetStringBuffer filename
1032   let
1033         init_loc = mkSrcLoc (mkFastString filename) 1 0
1034         init_state = (mkPState buf init_loc dflags) { lex_state = [0] }
1035                 -- reset the lex_state: the Lexer monad leaves some stuff
1036                 -- in there we don't want.
1037   case unP cmmParse init_state of
1038     PFailed span err -> do printError span err; return Nothing
1039     POk pst code -> do
1040         cmm <- initC dflags no_module (getCmm (unEC code initEnv [] >> return ()))
1041         let ms = getMessages pst
1042         printErrorsAndWarnings dflags ms
1043         when (errorsFound dflags ms) $ exitWith (ExitFailure 1)
1044         dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (pprCmms [cmm])
1045         return (Just cmm)
1046   where
1047         no_module = panic "parseCmmFile: no module"
1048 }