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