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