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