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