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