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 ';'            { mapM_ newImport $2 }
 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 -- Creates a foreign label in the import. CLabel's labelDynamic
 797 -- classifies these labels as dynamic, hence the code generator emits the
 798 -- PIC code for them.
 799 newImport :: FastString -> ExtFCode ()
 800 newImport name =
 801        addVarDecl name (CmmLit (CmmLabel (mkForeignLabel name Nothing True)))
 802
 803 newLabel :: FastString -> ExtFCode BlockId
 804 newLabel name = do
 805    u <- code newUnique
 806    addLabel name (BlockId u)
 807    return (BlockId u)
 808
 809 lookupLabel :: FastString -> ExtFCode BlockId
 810 lookupLabel name = do
 811   env <- getEnv
 812   return $
 813      case lookupUFM env name of
 814         Just (Label l) -> l
 815         _other -> BlockId (newTagUnique (getUnique name) 'L')
 816
 817 -- Unknown names are treated as if they had been 'import'ed.
 818 -- This saves us a lot of bother in the RTS sources, at the expense of
 819 -- deferring some errors to link time.
 820 lookupName :: FastString -> ExtFCode CmmExpr
 821 lookupName name = do
 822   env <- getEnv
 823   return $
 824      case lookupUFM env name of
 825         Just (Var e) -> e
 826         _other -> CmmLit (CmmLabel (mkRtsCodeLabelFS name))
 827
 828 -- Lifting FCode computations into the ExtFCode monad:
 829 code :: FCode a -> ExtFCode a
 830 code fc = EC $ \e s -> do r <- fc; return (s, r)
 831
 832 code2 :: (FCode (Decls,b) -> FCode ((Decls,b),c))
 833          -> ExtFCode b -> ExtFCode c
 834 code2 f (EC ec) = EC $ \e s -> do ((s',b),c) <- f (ec e s); return (s',c)
 835
 836 nopEC = code nopC
 837 stmtEC stmt = code (stmtC stmt)
 838 stmtsEC stmts = code (stmtsC stmts)
 839 getCgStmtsEC = code2 getCgStmts'
 840 getCgStmtsEC' = code2 (\m -> getCgStmts' m >>= f)
 841   where f ((decl, b), c) = return ((decl, b), (b, c))
 842
 843 forkLabelledCodeEC ec = do
 844   stmts <- getCgStmtsEC ec
 845   code (forkCgStmts stmts)
 846
 847
 848 profilingInfo desc_str ty_str = do
 849   lit1 <- if opt_SccProfilingOn
 850                    then code $ mkStringCLit desc_str
 851                    else return (mkIntCLit 0)
 852   lit2 <- if opt_SccProfilingOn
 853                    then code $ mkStringCLit ty_str
 854                    else return (mkIntCLit 0)
 855   return (ProfilingInfo lit1 lit2)
 856
 857
 858 staticClosure :: FastString -> FastString -> [CmmLit] -> ExtCode
 859 staticClosure cl_label info payload
 860   = code $ emitDataLits (mkRtsDataLabelFS cl_label) lits
 861   where  lits = mkStaticClosure (mkRtsInfoLabelFS info) dontCareCCS payload [] [] []
 862
 863 foreignCall
 864         :: String
 865         -> [ExtFCode (CmmFormal,MachHint)]
 866         -> ExtFCode CmmExpr
 867         -> [ExtFCode (CmmExpr,MachHint)]
 868         -> Maybe [GlobalReg]
 869         -> CmmSafety
 870         -> P ExtCode
 871 foreignCall conv_string results_code expr_code args_code vols safety
 872   = do  convention <- case conv_string of
 873           "C" -> return CCallConv
 874           "C--" -> return CmmCallConv
 875           _ -> fail ("unknown calling convention: " ++ conv_string)
 876         return $ do
 877           results <- sequence results_code
 878           expr <- expr_code
 879           args <- sequence args_code
 880           --code (stmtC (CmmCall (CmmCallee expr convention) results args safety))
 881           case convention of
 882             -- Temporary hack so at least some functions are CmmSafe
 883             CmmCallConv -> code (stmtC (CmmCall (CmmCallee expr convention) results args safety))
 884             _ -> case safety of
 885               CmmUnsafe ->
 886                 code (emitForeignCall' PlayRisky results
 887                    (CmmCallee expr convention) args vols NoC_SRT)
 888               CmmSafe srt ->
 889                 code (emitForeignCall' (PlaySafe unused) results
 890                    (CmmCallee expr convention) args vols NoC_SRT) where
 891                 unused = panic "not used by emitForeignCall'"
 892
 893 primCall
 894         :: [ExtFCode (CmmFormal,MachHint)]
 895         -> FastString
 896         -> [ExtFCode (CmmExpr,MachHint)]
 897         -> Maybe [GlobalReg]
 898         -> CmmSafety
 899         -> P ExtCode
 900 primCall results_code name args_code vols safety
 901   = case lookupUFM callishMachOps name of
 902         Nothing -> fail ("unknown primitive " ++ unpackFS name)
 903         Just p  -> return $ do
 904                 results <- sequence results_code
 905                 args <- sequence args_code
 906                 case safety of
 907                   CmmUnsafe ->
 908                     code (emitForeignCall' PlayRisky results
 909                       (CmmPrim p) args vols NoC_SRT)
 910                   CmmSafe srt ->
 911                     code (emitForeignCall' (PlaySafe unused) results
 912                       (CmmPrim p) args vols NoC_SRT) where
 913                     unused = panic "not used by emitForeignCall'"
 914
 915 doStore :: MachRep -> ExtFCode CmmExpr  -> ExtFCode CmmExpr -> ExtCode
 916 doStore rep addr_code val_code
 917   = do addr <- addr_code
 918        val <- val_code
 919         -- if the specified store type does not match the type of the expr
 920         -- on the rhs, then we insert a coercion that will cause the type
 921         -- mismatch to be flagged by cmm-lint.  If we don't do this, then
 922         -- the store will happen at the wrong type, and the error will not
 923         -- be noticed.
 924        let coerce_val
 925                 | cmmExprRep val /= rep = CmmMachOp (MO_U_Conv rep rep) [val]
 926                 | otherwise             = val
 927        stmtEC (CmmStore addr coerce_val)
 928
 929 -- Return an unboxed tuple.
 930 emitRetUT :: [(CgRep,CmmExpr)] -> Code
 931 emitRetUT args = do
 932   tickyUnboxedTupleReturn (length args)  -- TICK
 933   (sp, stmts) <- pushUnboxedTuple 0 args
 934   emitStmts stmts
 935   when (sp /= 0) $ stmtC (CmmAssign spReg (cmmRegOffW spReg (-sp)))
 936   stmtC (CmmJump (entryCode (CmmLoad (cmmRegOffW spReg sp) wordRep)) [])
 937   -- TODO (when using CPS): emitStmt (CmmReturn (map snd args))
 938
 939 -- -----------------------------------------------------------------------------
 940 -- If-then-else and boolean expressions
 941
 942 data BoolExpr
 943   = BoolExpr `BoolAnd` BoolExpr
 944   | BoolExpr `BoolOr`  BoolExpr
 945   | BoolNot BoolExpr
 946   | BoolTest CmmExpr
 947
 948 -- ToDo: smart constructors which simplify the boolean expression.
 949
 950 ifThenElse cond then_part else_part = do
 951      then_id <- code newLabelC
 952      join_id <- code newLabelC
 953      c <- cond
 954      emitCond c then_id
 955      else_part
 956      stmtEC (CmmBranch join_id)
 957      code (labelC then_id)
 958      then_part
 959      -- fall through to join
 960      code (labelC join_id)
 961
 962 -- 'emitCond cond true_id'  emits code to test whether the cond is true,
 963 -- branching to true_id if so, and falling through otherwise.
 964 emitCond (BoolTest e) then_id = do
 965   stmtEC (CmmCondBranch e then_id)
 966 emitCond (BoolNot (BoolTest (CmmMachOp op args))) then_id
 967   | Just op' <- maybeInvertComparison op
 968   = emitCond (BoolTest (CmmMachOp op' args)) then_id
 969 emitCond (BoolNot e) then_id = do
 970   else_id <- code newLabelC
 971   emitCond e else_id
 972   stmtEC (CmmBranch then_id)
 973   code (labelC else_id)
 974 emitCond (e1 `BoolOr` e2) then_id = do
 975   emitCond e1 then_id
 976   emitCond e2 then_id
 977 emitCond (e1 `BoolAnd` e2) then_id = do
 978         -- we'd like to invert one of the conditionals here to avoid an
 979         -- extra branch instruction, but we can't use maybeInvertComparison
 980         -- here because we can't look too closely at the expression since
 981         -- we're in a loop.
 982   and_id <- code newLabelC
 983   else_id <- code newLabelC
 984   emitCond e1 and_id
 985   stmtEC (CmmBranch else_id)
 986   code (labelC and_id)
 987   emitCond e2 then_id
 988   code (labelC else_id)
 989
 990
 991 -- -----------------------------------------------------------------------------
 992 -- Table jumps
 993
 994 -- We use a simplified form of C-- switch statements for now.  A
 995 -- switch statement always compiles to a table jump.  Each arm can
 996 -- specify a list of values (not ranges), and there can be a single
 997 -- default branch.  The range of the table is given either by the
 998 -- optional range on the switch (eg. switch [0..7] {...}), or by
 999 -- the minimum/maximum values from the branches.
1000
1001 doSwitch :: Maybe (Int,Int) -> ExtFCode CmmExpr -> [([Int],ExtCode)]
1002          -> Maybe ExtCode -> ExtCode
1003 doSwitch mb_range scrut arms deflt
1004    = do
1005         -- Compile code for the default branch
1006         dflt_entry <-
1007                 case deflt of
1008                   Nothing -> return Nothing
1009                   Just e  -> do b <- forkLabelledCodeEC e; return (Just b)
1010
1011         -- Compile each case branch
1012         table_entries <- mapM emitArm arms
1013
1014         -- Construct the table
1015         let
1016             all_entries = concat table_entries
1017             ixs = map fst all_entries
1018             (min,max)
1019                 | Just (l,u) <- mb_range = (l,u)
1020                 | otherwise              = (minimum ixs, maximum ixs)
1021
1022             entries = elems (accumArray (\_ a -> Just a) dflt_entry (min,max)
1023                                 all_entries)
1024         expr <- scrut
1025         -- ToDo: check for out of range and jump to default if necessary
1026         stmtEC (CmmSwitch expr entries)
1027    where
1028         emitArm :: ([Int],ExtCode) -> ExtFCode [(Int,BlockId)]
1029         emitArm (ints,code) = do
1030            blockid <- forkLabelledCodeEC code
1031            return [ (i,blockid) | i <- ints ]
1032
1033
1034 -- -----------------------------------------------------------------------------
1035 -- Putting it all together
1036
1037 -- The initial environment: we define some constants that the compiler
1038 -- knows about here.
1039 initEnv :: Env
1040 initEnv = listToUFM [
1041   ( FSLIT("SIZEOF_StgHeader"),
1042     Var (CmmLit (CmmInt (fromIntegral (fixedHdrSize * wORD_SIZE)) wordRep) )),
1043   ( FSLIT("SIZEOF_StgInfoTable"),
1044     Var (CmmLit (CmmInt (fromIntegral stdInfoTableSizeB) wordRep) ))
1045   ]
1046
1047 parseCmmFile :: DynFlags -> FilePath -> IO (Maybe Cmm)
1048 parseCmmFile dflags filename = do
1049   showPass dflags "ParseCmm"
1050   buf <- hGetStringBuffer filename
1051   let
1052         init_loc = mkSrcLoc (mkFastString filename) 1 0
1053         init_state = (mkPState buf init_loc dflags) { lex_state = [0] }
1054                 -- reset the lex_state: the Lexer monad leaves some stuff
1055                 -- in there we don't want.
1056   case unP cmmParse init_state of
1057     PFailed span err -> do printError span err; return Nothing
1058     POk pst code -> do
1059         cmm <- initC dflags no_module (getCmm (unEC code initEnv [] >> return ()))
1060         let ms = getMessages pst
1061         printErrorsAndWarnings dflags ms
1062         when (errorsFound dflags ms) $ exitWith (ExitFailure 1)
1063         dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (pprCmms [cmm])
1064         return (Just cmm)
1065   where
1066         no_module = panic "parseCmmFile: no module"
1067 }