compiler/cmm/CmmParse.y

   1 -----------------------------------------------------------------------------
   2 --
   3 -- (c) The University of Glasgow, 2004-2006
   4 --
   5 -- Parser for concrete Cmm.
   6 -- This doesn't just parse the Cmm file, we also do some code generation
   7 -- along the way for switches and foreign calls etc.
   8 --
   9 -----------------------------------------------------------------------------
  10
  11 -- TODO: Add support for interruptible/uninterruptible foreign call specification
  12
  13 {
  14 {-# LANGUAGE BangPatterns #-} -- required for versions of Happy before 1.18.6
  15 {-# OPTIONS -Wwarn -w #-}
  16 -- The above warning supression flag is a temporary kludge.
  17 -- While working on this module you are encouraged to remove it and fix
  18 -- any warnings in the module. See
  19 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
  20 -- for details
  21
  22 module CmmParse ( parseCmmFile ) where
  23
  24 import CgMonad          hiding (getDynFlags)
  25 import CgExtCode
  26 import CgHeapery
  27 import CgUtils
  28 import CgProf
  29 import CgTicky
  30 import CgInfoTbls
  31 import CgForeignCall
  32 import CgTailCall
  33 import CgStackery
  34 import ClosureInfo
  35 import CgCallConv
  36 import CgClosure
  37 import CostCentre
  38
  39 import BlockId
  40 import Cmm
  41 import PprCmm
  42 import CmmUtils
  43 import CmmLex
  44 import CLabel
  45 import SMRep
  46 import Lexer
  47
  48 import ForeignCall
  49 import Module
  50 import Literal
  51 import Unique
  52 import UniqFM
  53 import SrcLoc
  54 import DynFlags
  55 import StaticFlags
  56 import ErrUtils
  57 import StringBuffer
  58 import FastString
  59 import Panic
  60 import Constants
  61 import Outputable
  62 import BasicTypes
  63 import Bag              ( emptyBag, unitBag )
  64 import Var
  65
  66 import Control.Monad
  67 import Data.Array
  68 import Data.Char        ( ord )
  69 import System.Exit
  70
  71 #include "HsVersions.h"
  72 }
  73
  74 %expect 0
  75
  76 %token
  77         ':'     { L _ (CmmT_SpecChar ':') }
  78         ';'     { L _ (CmmT_SpecChar ';') }
  79         '{'     { L _ (CmmT_SpecChar '{') }
  80         '}'     { L _ (CmmT_SpecChar '}') }
  81         '['     { L _ (CmmT_SpecChar '[') }
  82         ']'     { L _ (CmmT_SpecChar ']') }
  83         '('     { L _ (CmmT_SpecChar '(') }
  84         ')'     { L _ (CmmT_SpecChar ')') }
  85         '='     { L _ (CmmT_SpecChar '=') }
  86         '`'     { L _ (CmmT_SpecChar '`') }
  87         '~'     { L _ (CmmT_SpecChar '~') }
  88         '/'     { L _ (CmmT_SpecChar '/') }
  89         '*'     { L _ (CmmT_SpecChar '*') }
  90         '%'     { L _ (CmmT_SpecChar '%') }
  91         '-'     { L _ (CmmT_SpecChar '-') }
  92         '+'     { L _ (CmmT_SpecChar '+') }
  93         '&'     { L _ (CmmT_SpecChar '&') }
  94         '^'     { L _ (CmmT_SpecChar '^') }
  95         '|'     { L _ (CmmT_SpecChar '|') }
  96         '>'     { L _ (CmmT_SpecChar '>') }
  97         '<'     { L _ (CmmT_SpecChar '<') }
  98         ','     { L _ (CmmT_SpecChar ',') }
  99         '!'     { L _ (CmmT_SpecChar '!') }
 100
 101         '..'    { L _ (CmmT_DotDot) }
 102         '::'    { L _ (CmmT_DoubleColon) }
 103         '>>'    { L _ (CmmT_Shr) }
 104         '<<'    { L _ (CmmT_Shl) }
 105         '>='    { L _ (CmmT_Ge) }
 106         '<='    { L _ (CmmT_Le) }
 107         '=='    { L _ (CmmT_Eq) }
 108         '!='    { L _ (CmmT_Ne) }
 109         '&&'    { L _ (CmmT_BoolAnd) }
 110         '||'    { L _ (CmmT_BoolOr) }
 111
 112         'CLOSURE'       { L _ (CmmT_CLOSURE) }
 113         'INFO_TABLE'    { L _ (CmmT_INFO_TABLE) }
 114         'INFO_TABLE_RET'{ L _ (CmmT_INFO_TABLE_RET) }
 115         'INFO_TABLE_FUN'{ L _ (CmmT_INFO_TABLE_FUN) }
 116         'INFO_TABLE_CONSTR'{ L _ (CmmT_INFO_TABLE_CONSTR) }
 117         'INFO_TABLE_SELECTOR'{ L _ (CmmT_INFO_TABLE_SELECTOR) }
 118         'else'          { L _ (CmmT_else) }
 119         'export'        { L _ (CmmT_export) }
 120         'section'       { L _ (CmmT_section) }
 121         'align'         { L _ (CmmT_align) }
 122         'goto'          { L _ (CmmT_goto) }
 123         'if'            { L _ (CmmT_if) }
 124         'jump'          { L _ (CmmT_jump) }
 125         'foreign'       { L _ (CmmT_foreign) }
 126         'never'         { L _ (CmmT_never) }
 127         'prim'          { L _ (CmmT_prim) }
 128         'return'        { L _ (CmmT_return) }
 129         'returns'       { L _ (CmmT_returns) }
 130         'import'        { L _ (CmmT_import) }
 131         'switch'        { L _ (CmmT_switch) }
 132         'case'          { L _ (CmmT_case) }
 133         'default'       { L _ (CmmT_default) }
 134         'bits8'         { L _ (CmmT_bits8) }
 135         'bits16'        { L _ (CmmT_bits16) }
 136         'bits32'        { L _ (CmmT_bits32) }
 137         'bits64'        { L _ (CmmT_bits64) }
 138         'float32'       { L _ (CmmT_float32) }
 139         'float64'       { L _ (CmmT_float64) }
 140         'gcptr'         { L _ (CmmT_gcptr) }
 141
 142         GLOBALREG       { L _ (CmmT_GlobalReg   $$) }
 143         NAME            { L _ (CmmT_Name        $$) }
 144         STRING          { L _ (CmmT_String      $$) }
 145         INT             { L _ (CmmT_Int         $$) }
 146         FLOAT           { L _ (CmmT_Float       $$) }
 147
 148 %monad { P } { >>= } { return }
 149 %lexer { cmmlex } { L _ CmmT_EOF }
 150 %name cmmParse cmm
 151 %tokentype { Located CmmToken }
 152
 153 -- C-- operator precedences, taken from the C-- spec
 154 %right '||'     -- non-std extension, called %disjoin in C--
 155 %right '&&'     -- non-std extension, called %conjoin in C--
 156 %right '!'
 157 %nonassoc '>=' '>' '<=' '<' '!=' '=='
 158 %left '|'
 159 %left '^'
 160 %left '&'
 161 %left '>>' '<<'
 162 %left '-' '+'
 163 %left '/' '*' '%'
 164 %right '~'
 165
 166 %%
 167
 168 cmm     :: { ExtCode }
 169         : {- empty -}                   { return () }
 170         | cmmtop cmm                    { do $1; $2 }
 171
 172 cmmtop  :: { ExtCode }
 173         : cmmproc                       { $1 }
 174         | cmmdata                       { $1 }
 175         | decl                          { $1 }
 176         | 'CLOSURE' '(' NAME ',' NAME lits ')' ';'
 177                 {% withThisPackage $ \pkg ->
 178                    do lits <- sequence $6;
 179                       staticClosure pkg $3 $5 (map getLit lits) }
 180
 181 -- The only static closures in the RTS are dummy closures like
 182 -- stg_END_TSO_QUEUE_closure and stg_dummy_ret.  We don't need
 183 -- to provide the full generality of static closures here.
 184 -- In particular:
 185 --      * CCS can always be CCS_DONT_CARE
 186 --      * closure is always extern
 187 --      * payload is always empty
 188 --      * we can derive closure and info table labels from a single NAME
 189
 190 cmmdata :: { ExtCode }
 191         : 'section' STRING '{' statics '}'
 192                 { do ss <- sequence $4;
 193                      code (emitData (section $2) (concat ss)) }
 194
 195 statics :: { [ExtFCode [CmmStatic]] }
 196         : {- empty -}                   { [] }
 197         | static statics                { $1 : $2 }
 198
 199 -- Strings aren't used much in the RTS HC code, so it doesn't seem
 200 -- worth allowing inline strings.  C-- doesn't allow them anyway.
 201 static  :: { ExtFCode [CmmStatic] }
 202         : NAME ':'
 203                 {% withThisPackage $ \pkg ->
 204                    return [CmmDataLabel (mkCmmDataLabel pkg $1)] }
 205
 206         | type expr ';' { do e <- $2;
 207                              return [CmmStaticLit (getLit e)] }
 208         | type ';'                      { return [CmmUninitialised
 209                                                         (widthInBytes (typeWidth $1))] }
 210         | 'bits8' '[' ']' STRING ';'    { return [mkString $4] }
 211         | 'bits8' '[' INT ']' ';'       { return [CmmUninitialised
 212                                                         (fromIntegral $3)] }
 213         | typenot8 '[' INT ']' ';'      { return [CmmUninitialised
 214                                                 (widthInBytes (typeWidth $1) *
 215                                                         fromIntegral $3)] }
 216         | 'align' INT ';'               { return [CmmAlign (fromIntegral $2)] }
 217         | 'CLOSURE' '(' NAME lits ')'
 218                 { do lits <- sequence $4;
 219                      return $ map CmmStaticLit $
 220                        mkStaticClosure (mkForeignLabel $3 Nothing ForeignLabelInExternalPackage IsData)
 221                          -- mkForeignLabel because these are only used
 222                          -- for CHARLIKE and INTLIKE closures in the RTS.
 223                          dontCareCCS (map getLit lits) [] [] [] }
 224         -- arrays of closures required for the CHARLIKE & INTLIKE arrays
 225
 226 lits    :: { [ExtFCode CmmExpr] }
 227         : {- empty -}           { [] }
 228         | ',' expr lits         { $2 : $3 }
 229
 230 cmmproc :: { ExtCode }
 231 -- TODO: add real SRT/info tables to parsed Cmm
 232         : info maybe_formals_without_hints maybe_gc_block maybe_frame '{' body '}'
 233                 { do ((entry_ret_label, info, live, formals, gc_block, frame), stmts) <-
 234                        getCgStmtsEC' $ loopDecls $ do {
 235                          (entry_ret_label, info, live) <- $1;
 236                          formals <- sequence $2;
 237                          gc_block <- $3;
 238                          frame <- $4;
 239                          $6;
 240                          return (entry_ret_label, info, live, formals, gc_block, frame) }
 241                      blks <- code (cgStmtsToBlocks stmts)
 242                      code (emitInfoTableAndCode entry_ret_label (CmmInfo gc_block frame info) formals blks) }
 243
 244         | info maybe_formals_without_hints ';'
 245                 { do (entry_ret_label, info, live) <- $1;
 246                      formals <- sequence $2;
 247                      code (emitInfoTableAndCode entry_ret_label (CmmInfo Nothing Nothing info) formals []) }
 248
 249         | NAME maybe_formals_without_hints maybe_gc_block maybe_frame '{' body '}'
 250                 {% withThisPackage $ \pkg ->
 251                    do   newFunctionName $1 pkg
 252                         ((formals, gc_block, frame), stmts) <-
 253                                 getCgStmtsEC' $ loopDecls $ do {
 254                                         formals <- sequence $2;
 255                                         gc_block <- $3;
 256                                         frame <- $4;
 257                                         $6;
 258                                         return (formals, gc_block, frame) }
 259                         blks <- code (cgStmtsToBlocks stmts)
 260                         code (emitProc (CmmInfo gc_block frame CmmNonInfoTable) (mkCmmCodeLabel pkg $1) formals blks) }
 261
 262 info    :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) }
 263         : 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
 264                 -- ptrs, nptrs, closure type, description, type
 265                 {% withThisPackage $ \pkg ->
 266                    do prof <- profilingInfo $11 $13
 267                       return (mkCmmEntryLabel pkg $3,
 268                         CmmInfoTable False prof (fromIntegral $9)
 269                                      (ThunkInfo (fromIntegral $5, fromIntegral $7) NoC_SRT),
 270                         []) }
 271
 272         | 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ')'
 273                 -- ptrs, nptrs, closure type, description, type, fun type
 274                 {% withThisPackage $ \pkg ->
 275                    do prof <- profilingInfo $11 $13
 276                       return (mkCmmEntryLabel pkg $3,
 277                         CmmInfoTable False prof (fromIntegral $9)
 278                                      (FunInfo (fromIntegral $5, fromIntegral $7) NoC_SRT
 279                                       0  -- Arity zero
 280                                       (ArgSpec (fromIntegral $15))
 281                                       zeroCLit),
 282                         []) }
 283                 -- we leave most of the fields zero here.  This is only used
 284                 -- to generate the BCO info table in the RTS at the moment.
 285
 286         -- A variant with a non-zero arity (needed to write Main_main in Cmm)
 287         | 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ',' INT ')'
 288                 -- ptrs, nptrs, closure type, description, type, fun type, arity
 289                 {% withThisPackage $ \pkg ->
 290                    do prof <- profilingInfo $11 $13
 291                       return (mkCmmEntryLabel pkg $3,
 292                         CmmInfoTable False prof (fromIntegral $9)
 293                                      (FunInfo (fromIntegral $5, fromIntegral $7) NoC_SRT (fromIntegral $17)
 294                                       (ArgSpec (fromIntegral $15))
 295                                       zeroCLit),
 296                         []) }
 297                 -- we leave most of the fields zero here.  This is only used
 298                 -- to generate the BCO info table in the RTS at the moment.
 299
 300         | 'INFO_TABLE_CONSTR' '(' NAME ',' INT ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
 301                 -- ptrs, nptrs, tag, closure type, description, type
 302                 {% withThisPackage $ \pkg ->
 303                    do prof <- profilingInfo $13 $15
 304                      -- If profiling is on, this string gets duplicated,
 305                      -- but that's the way the old code did it we can fix it some other time.
 306                       desc_lit <- code $ mkStringCLit $13
 307                       return (mkCmmEntryLabel pkg $3,
 308                         CmmInfoTable False prof (fromIntegral $11)
 309                                      (ConstrInfo (fromIntegral $5, fromIntegral $7) (fromIntegral $9) desc_lit),
 310                         []) }
 311
 312         | 'INFO_TABLE_SELECTOR' '(' NAME ',' INT ',' INT ',' STRING ',' STRING ')'
 313                 -- selector, closure type, description, type
 314                 {% withThisPackage $ \pkg ->
 315                    do prof <- profilingInfo $9 $11
 316                       return (mkCmmEntryLabel pkg $3,
 317                         CmmInfoTable False prof (fromIntegral $7)
 318                                      (ThunkSelectorInfo (fromIntegral $5) NoC_SRT),
 319                         []) }
 320
 321         | 'INFO_TABLE_RET' '(' NAME ',' INT ')'
 322                 -- closure type (no live regs)
 323                 {% withThisPackage $ \pkg ->
 324                    do let infoLabel = mkCmmInfoLabel pkg $3
 325                       return (mkCmmRetLabel pkg $3,
 326                         CmmInfoTable False (ProfilingInfo zeroCLit zeroCLit) (fromIntegral $5)
 327                                      (ContInfo [] NoC_SRT),
 328                         []) }
 329
 330         | 'INFO_TABLE_RET' '(' NAME ',' INT ',' formals_without_hints0 ')'
 331                 -- closure type, live regs
 332                 {% withThisPackage $ \pkg ->
 333                    do live <- sequence (map (liftM Just) $7)
 334                       return (mkCmmRetLabel pkg $3,
 335                         CmmInfoTable False (ProfilingInfo zeroCLit zeroCLit) (fromIntegral $5)
 336                                      (ContInfo live NoC_SRT),
 337                         live) }
 338
 339 body    :: { ExtCode }
 340         : {- empty -}                   { return () }
 341         | decl body                     { do $1; $2 }
 342         | stmt body                     { do $1; $2 }
 343
 344 decl    :: { ExtCode }
 345         : type names ';'                { mapM_ (newLocal $1) $2 }
 346         | 'import' importNames ';'      { mapM_ newImport $2 }
 347         | 'export' names ';'            { return () }  -- ignore exports
 348
 349
 350 -- an imported function name, with optional packageId
 351 importNames
 352         :: { [(FastString, CLabel)] }
 353         : importName                    { [$1] }
 354         | importName ',' importNames    { $1 : $3 }
 355
 356 importName
 357         :: { (FastString,  CLabel) }
 358
 359         -- A label imported without an explicit packageId.
 360         --      These are taken to come frome some foreign, unnamed package.
 361         : NAME
 362         { ($1, mkForeignLabel $1 Nothing ForeignLabelInExternalPackage IsFunction) }
 363
 364         -- A label imported with an explicit packageId.
 365         | STRING NAME
 366         { ($2, mkCmmCodeLabel (fsToPackageId (mkFastString $1)) $2) }
 367
 368
 369 names   :: { [FastString] }
 370         : NAME                          { [$1] }
 371         | NAME ',' names                { $1 : $3 }
 372
 373 stmt    :: { ExtCode }
 374         : ';'                                   { nopEC }
 375
 376         | NAME ':'
 377                 { do l <- newLabel $1; code (labelC l) }
 378
 379         | lreg '=' expr ';'
 380                 { do reg <- $1; e <- $3; stmtEC (CmmAssign reg e) }
 381         | type '[' expr ']' '=' expr ';'
 382                 { doStore $1 $3 $6 }
 383
 384         -- Gah! We really want to say "maybe_results" but that causes
 385         -- a shift/reduce conflict with assignment.  We either
 386         -- we expand out the no-result and single result cases or
 387         -- we tweak the syntax to avoid the conflict.  The later
 388         -- option is taken here because the other way would require
 389         -- multiple levels of expanding and get unwieldy.
 390         | maybe_results 'foreign' STRING expr '(' cmm_hint_exprs0 ')' safety vols opt_never_returns ';'
 391                 {% foreignCall $3 $1 $4 $6 $9 $8 $10 }
 392         | maybe_results 'prim' '%' NAME '(' cmm_hint_exprs0 ')' safety vols ';'
 393                 {% primCall $1 $4 $6 $9 $8 }
 394         -- stmt-level macros, stealing syntax from ordinary C-- function calls.
 395         -- Perhaps we ought to use the %%-form?
 396         | NAME '(' exprs0 ')' ';'
 397                 {% stmtMacro $1 $3  }
 398         | 'switch' maybe_range expr '{' arms default '}'
 399                 { doSwitch $2 $3 $5 $6 }
 400         | 'goto' NAME ';'
 401                 { do l <- lookupLabel $2; stmtEC (CmmBranch l) }
 402         | 'jump' expr maybe_actuals ';'
 403                 { do e1 <- $2; e2 <- sequence $3; stmtEC (CmmJump e1 e2) }
 404         | 'return' maybe_actuals ';'
 405                 { do e <- sequence $2; stmtEC (CmmReturn e) }
 406         | 'if' bool_expr '{' body '}' else
 407                 { cmmIfThenElse $2 $4 $6 }
 408
 409 opt_never_returns :: { CmmReturnInfo }
 410         :                               { CmmMayReturn }
 411         | 'never' 'returns'             { CmmNeverReturns }
 412
 413 bool_expr :: { ExtFCode BoolExpr }
 414         : bool_op                       { $1 }
 415         | expr                          { do e <- $1; return (BoolTest e) }
 416
 417 bool_op :: { ExtFCode BoolExpr }
 418         : bool_expr '&&' bool_expr      { do e1 <- $1; e2 <- $3;
 419                                           return (BoolAnd e1 e2) }
 420         | bool_expr '||' bool_expr      { do e1 <- $1; e2 <- $3;
 421                                           return (BoolOr e1 e2)  }
 422         | '!' bool_expr                 { do e <- $2; return (BoolNot e) }
 423         | '(' bool_op ')'               { $2 }
 424
 425 -- This is not C-- syntax.  What to do?
 426 safety  :: { CmmSafety }
 427         : {- empty -}                   { CmmUnsafe } -- Default may change soon
 428         | STRING                        {% parseSafety $1 }
 429
 430 -- This is not C-- syntax.  What to do?
 431 vols    :: { Maybe [GlobalReg] }
 432         : {- empty -}                   { Nothing }
 433         | '[' ']'                       { Just [] }
 434         | '[' globals ']'               { Just $2 }
 435
 436 globals :: { [GlobalReg] }
 437         : GLOBALREG                     { [$1] }
 438         | GLOBALREG ',' globals         { $1 : $3 }
 439
 440 maybe_range :: { Maybe (Int,Int) }
 441         : '[' INT '..' INT ']'  { Just (fromIntegral $2, fromIntegral $4) }
 442         | {- empty -}           { Nothing }
 443
 444 arms    :: { [([Int],ExtCode)] }
 445         : {- empty -}                   { [] }
 446         | arm arms                      { $1 : $2 }
 447
 448 arm     :: { ([Int],ExtCode) }
 449         : 'case' ints ':' '{' body '}'  { ($2, $5) }
 450
 451 ints    :: { [Int] }
 452         : INT                           { [ fromIntegral $1 ] }
 453         | INT ',' ints                  { fromIntegral $1 : $3 }
 454
 455 default :: { Maybe ExtCode }
 456         : 'default' ':' '{' body '}'    { Just $4 }
 457         -- taking a few liberties with the C-- syntax here; C-- doesn't have
 458         -- 'default' branches
 459         | {- empty -}                   { Nothing }
 460
 461 else    :: { ExtCode }
 462         : {- empty -}                   { nopEC }
 463         | 'else' '{' body '}'           { $3 }
 464
 465 -- we have to write this out longhand so that Happy's precedence rules
 466 -- can kick in.
 467 expr    :: { ExtFCode CmmExpr }
 468         : expr '/' expr                 { mkMachOp MO_U_Quot [$1,$3] }
 469         | expr '*' expr                 { mkMachOp MO_Mul [$1,$3] }
 470         | expr '%' expr                 { mkMachOp MO_U_Rem [$1,$3] }
 471         | expr '-' expr                 { mkMachOp MO_Sub [$1,$3] }
 472         | expr '+' expr                 { mkMachOp MO_Add [$1,$3] }
 473         | expr '>>' expr                { mkMachOp MO_U_Shr [$1,$3] }
 474         | expr '<<' expr                { mkMachOp MO_Shl [$1,$3] }
 475         | expr '&' expr                 { mkMachOp MO_And [$1,$3] }
 476         | expr '^' expr                 { mkMachOp MO_Xor [$1,$3] }
 477         | expr '|' expr                 { mkMachOp MO_Or [$1,$3] }
 478         | expr '>=' expr                { mkMachOp MO_U_Ge [$1,$3] }
 479         | expr '>' expr                 { mkMachOp MO_U_Gt [$1,$3] }
 480         | expr '<=' expr                { mkMachOp MO_U_Le [$1,$3] }
 481         | expr '<' expr                 { mkMachOp MO_U_Lt [$1,$3] }
 482         | expr '!=' expr                { mkMachOp MO_Ne [$1,$3] }
 483         | expr '==' expr                { mkMachOp MO_Eq [$1,$3] }
 484         | '~' expr                      { mkMachOp MO_Not [$2] }
 485         | '-' expr                      { mkMachOp MO_S_Neg [$2] }
 486         | expr0 '`' NAME '`' expr0      {% do { mo <- nameToMachOp $3 ;
 487                                                 return (mkMachOp mo [$1,$5]) } }
 488         | expr0                         { $1 }
 489
 490 expr0   :: { ExtFCode CmmExpr }
 491         : INT   maybe_ty         { return (CmmLit (CmmInt $1 (typeWidth $2))) }
 492         | FLOAT maybe_ty         { return (CmmLit (CmmFloat $1 (typeWidth $2))) }
 493         | STRING                 { do s <- code (mkStringCLit $1);
 494                                       return (CmmLit s) }
 495         | reg                    { $1 }
 496         | type '[' expr ']'      { do e <- $3; return (CmmLoad e $1) }
 497         | '%' NAME '(' exprs0 ')' {% exprOp $2 $4 }
 498         | '(' expr ')'           { $2 }
 499
 500
 501 -- leaving out the type of a literal gives you the native word size in C--
 502 maybe_ty :: { CmmType }
 503         : {- empty -}                   { bWord }
 504         | '::' type                     { $2 }
 505
 506 maybe_actuals :: { [ExtFCode HintedCmmActual] }
 507         : {- empty -}           { [] }
 508         | '(' cmm_hint_exprs0 ')'       { $2 }
 509
 510 cmm_hint_exprs0 :: { [ExtFCode HintedCmmActual] }
 511         : {- empty -}                   { [] }
 512         | cmm_hint_exprs                        { $1 }
 513
 514 cmm_hint_exprs :: { [ExtFCode HintedCmmActual] }
 515         : cmm_hint_expr                 { [$1] }
 516         | cmm_hint_expr ',' cmm_hint_exprs      { $1 : $3 }
 517
 518 cmm_hint_expr :: { ExtFCode HintedCmmActual }
 519         : expr                          { do e <- $1; return (CmmHinted e (inferCmmHint e)) }
 520         | expr STRING                   {% do h <- parseCmmHint $2;
 521                                               return $ do
 522                                                 e <- $1; return (CmmHinted e h) }
 523
 524 exprs0  :: { [ExtFCode CmmExpr] }
 525         : {- empty -}                   { [] }
 526         | exprs                         { $1 }
 527
 528 exprs   :: { [ExtFCode CmmExpr] }
 529         : expr                          { [ $1 ] }
 530         | expr ',' exprs                { $1 : $3 }
 531
 532 reg     :: { ExtFCode CmmExpr }
 533         : NAME                  { lookupName $1 }
 534         | GLOBALREG             { return (CmmReg (CmmGlobal $1)) }
 535
 536 maybe_results :: { [ExtFCode HintedCmmFormal] }
 537         : {- empty -}           { [] }
 538         | '(' cmm_formals ')' '='       { $2 }
 539
 540 cmm_formals :: { [ExtFCode HintedCmmFormal] }
 541         : cmm_formal                    { [$1] }
 542         | cmm_formal ','                        { [$1] }
 543         | cmm_formal ',' cmm_formals    { $1 : $3 }
 544
 545 cmm_formal :: { ExtFCode HintedCmmFormal }
 546         : local_lreg                    { do e <- $1; return (CmmHinted e (inferCmmHint (CmmReg (CmmLocal e)))) }
 547         | STRING local_lreg             {% do h <- parseCmmHint $1;
 548                                               return $ do
 549                                                 e <- $2; return (CmmHinted e h) }
 550
 551 local_lreg :: { ExtFCode LocalReg }
 552         : NAME                  { do e <- lookupName $1;
 553                                      return $
 554                                        case e of
 555                                         CmmReg (CmmLocal r) -> r
 556                                         other -> pprPanic "CmmParse:" (ftext $1 <> text " not a local register") }
 557
 558 lreg    :: { ExtFCode CmmReg }
 559         : NAME                  { do e <- lookupName $1;
 560                                      return $
 561                                        case e of
 562                                         CmmReg r -> r
 563                                         other -> pprPanic "CmmParse:" (ftext $1 <> text " not a register") }
 564         | GLOBALREG             { return (CmmGlobal $1) }
 565
 566 maybe_formals_without_hints :: { [ExtFCode LocalReg] }
 567         : {- empty -}           { [] }
 568         | '(' formals_without_hints0 ')'        { $2 }
 569
 570 formals_without_hints0 :: { [ExtFCode LocalReg] }
 571         : {- empty -}           { [] }
 572         | formals_without_hints         { $1 }
 573
 574 formals_without_hints :: { [ExtFCode LocalReg] }
 575         : formal_without_hint ','               { [$1] }
 576         | formal_without_hint           { [$1] }
 577         | formal_without_hint ',' formals_without_hints { $1 : $3 }
 578
 579 formal_without_hint :: { ExtFCode LocalReg }
 580         : type NAME             { newLocal $1 $2 }
 581
 582 maybe_frame :: { ExtFCode (Maybe UpdateFrame) }
 583         : {- empty -}                   { return Nothing }
 584         | 'jump' expr '(' exprs0 ')'    { do { target <- $2;
 585                                                args <- sequence $4;
 586                                                return $ Just (UpdateFrame target args) } }
 587
 588 maybe_gc_block :: { ExtFCode (Maybe BlockId) }
 589         : {- empty -}                   { return Nothing }
 590         | 'goto' NAME
 591                 { do l <- lookupLabel $2; return (Just l) }
 592
 593 type    :: { CmmType }
 594         : 'bits8'               { b8 }
 595         | typenot8              { $1 }
 596
 597 typenot8 :: { CmmType }
 598         : 'bits16'              { b16 }
 599         | 'bits32'              { b32 }
 600         | 'bits64'              { b64 }
 601         | 'float32'             { f32 }
 602         | 'float64'             { f64 }
 603         | 'gcptr'               { gcWord }
 604 {
 605 section :: String -> Section
 606 section "text"   = Text
 607 section "data"   = Data
 608 section "rodata" = ReadOnlyData
 609 section "relrodata" = RelocatableReadOnlyData
 610 section "bss"    = UninitialisedData
 611 section s        = OtherSection s
 612
 613 mkString :: String -> CmmStatic
 614 mkString s = CmmString (map (fromIntegral.ord) s)
 615
 616 -- mkMachOp infers the type of the MachOp from the type of its first
 617 -- argument.  We assume that this is correct: for MachOps that don't have
 618 -- symmetrical args (e.g. shift ops), the first arg determines the type of
 619 -- the op.
 620 mkMachOp :: (Width -> MachOp) -> [ExtFCode CmmExpr] -> ExtFCode CmmExpr
 621 mkMachOp fn args = do
 622   arg_exprs <- sequence args
 623   return (CmmMachOp (fn (typeWidth (cmmExprType (head arg_exprs)))) arg_exprs)
 624
 625 getLit :: CmmExpr -> CmmLit
 626 getLit (CmmLit l) = l
 627 getLit (CmmMachOp (MO_S_Neg _) [CmmLit (CmmInt i r)])  = CmmInt (negate i) r
 628 getLit _ = panic "invalid literal" -- TODO messy failure
 629
 630 nameToMachOp :: FastString -> P (Width -> MachOp)
 631 nameToMachOp name =
 632   case lookupUFM machOps name of
 633         Nothing -> fail ("unknown primitive " ++ unpackFS name)
 634         Just m  -> return m
 635
 636 exprOp :: FastString -> [ExtFCode CmmExpr] -> P (ExtFCode CmmExpr)
 637 exprOp name args_code =
 638   case lookupUFM exprMacros name of
 639      Just f  -> return $ do
 640         args <- sequence args_code
 641         return (f args)
 642      Nothing -> do
 643         mo <- nameToMachOp name
 644         return $ mkMachOp mo args_code
 645
 646 exprMacros :: UniqFM ([CmmExpr] -> CmmExpr)
 647 exprMacros = listToUFM [
 648   ( fsLit "ENTRY_CODE",   \ [x] -> entryCode x ),
 649   ( fsLit "INFO_PTR",     \ [x] -> closureInfoPtr x ),
 650   ( fsLit "STD_INFO",     \ [x] -> infoTable x ),
 651   ( fsLit "FUN_INFO",     \ [x] -> funInfoTable x ),
 652   ( fsLit "GET_ENTRY",    \ [x] -> entryCode (closureInfoPtr x) ),
 653   ( fsLit "GET_STD_INFO", \ [x] -> infoTable (closureInfoPtr x) ),
 654   ( fsLit "GET_FUN_INFO", \ [x] -> funInfoTable (closureInfoPtr x) ),
 655   ( fsLit "INFO_TYPE",    \ [x] -> infoTableClosureType x ),
 656   ( fsLit "INFO_PTRS",    \ [x] -> infoTablePtrs x ),
 657   ( fsLit "INFO_NPTRS",   \ [x] -> infoTableNonPtrs x )
 658   ]
 659
 660 -- we understand a subset of C-- primitives:
 661 machOps = listToUFM $
 662         map (\(x, y) -> (mkFastString x, y)) [
 663         ( "add",        MO_Add ),
 664         ( "sub",        MO_Sub ),
 665         ( "eq",         MO_Eq ),
 666         ( "ne",         MO_Ne ),
 667         ( "mul",        MO_Mul ),
 668         ( "neg",        MO_S_Neg ),
 669         ( "quot",       MO_S_Quot ),
 670         ( "rem",        MO_S_Rem ),
 671         ( "divu",       MO_U_Quot ),
 672         ( "modu",       MO_U_Rem ),
 673
 674         ( "ge",         MO_S_Ge ),
 675         ( "le",         MO_S_Le ),
 676         ( "gt",         MO_S_Gt ),
 677         ( "lt",         MO_S_Lt ),
 678
 679         ( "geu",        MO_U_Ge ),
 680         ( "leu",        MO_U_Le ),
 681         ( "gtu",        MO_U_Gt ),
 682         ( "ltu",        MO_U_Lt ),
 683
 684         ( "flt",        MO_S_Lt ),
 685         ( "fle",        MO_S_Le ),
 686         ( "feq",        MO_Eq ),
 687         ( "fne",        MO_Ne ),
 688         ( "fgt",        MO_S_Gt ),
 689         ( "fge",        MO_S_Ge ),
 690         ( "fneg",       MO_S_Neg ),
 691
 692         ( "and",        MO_And ),
 693         ( "or",         MO_Or ),
 694         ( "xor",        MO_Xor ),
 695         ( "com",        MO_Not ),
 696         ( "shl",        MO_Shl ),
 697         ( "shrl",       MO_U_Shr ),
 698         ( "shra",       MO_S_Shr ),
 699
 700         ( "lobits8",  flip MO_UU_Conv W8  ),
 701         ( "lobits16", flip MO_UU_Conv W16 ),
 702         ( "lobits32", flip MO_UU_Conv W32 ),
 703         ( "lobits64", flip MO_UU_Conv W64 ),
 704
 705         ( "zx16",     flip MO_UU_Conv W16 ),
 706         ( "zx32",     flip MO_UU_Conv W32 ),
 707         ( "zx64",     flip MO_UU_Conv W64 ),
 708
 709         ( "sx16",     flip MO_SS_Conv W16 ),
 710         ( "sx32",     flip MO_SS_Conv W32 ),
 711         ( "sx64",     flip MO_SS_Conv W64 ),
 712
 713         ( "f2f32",    flip MO_FF_Conv W32 ),  -- TODO; rounding mode
 714         ( "f2f64",    flip MO_FF_Conv W64 ),  -- TODO; rounding mode
 715         ( "f2i8",     flip MO_FS_Conv W8 ),
 716         ( "f2i16",    flip MO_FS_Conv W16 ),
 717         ( "f2i32",    flip MO_FS_Conv W32 ),
 718         ( "f2i64",    flip MO_FS_Conv W64 ),
 719         ( "i2f32",    flip MO_SF_Conv W32 ),
 720         ( "i2f64",    flip MO_SF_Conv W64 )
 721         ]
 722
 723 callishMachOps = listToUFM $
 724         map (\(x, y) -> (mkFastString x, y)) [
 725         ( "write_barrier", MO_WriteBarrier )
 726         -- ToDo: the rest, maybe
 727     ]
 728
 729 parseSafety :: String -> P CmmSafety
 730 parseSafety "safe"   = return (CmmSafe NoC_SRT)
 731 parseSafety "unsafe" = return CmmUnsafe
 732 parseSafety "interruptible" = return CmmInterruptible
 733 parseSafety str      = fail ("unrecognised safety: " ++ str)
 734
 735 parseCmmHint :: String -> P ForeignHint
 736 parseCmmHint "ptr"    = return AddrHint
 737 parseCmmHint "signed" = return SignedHint
 738 parseCmmHint str      = fail ("unrecognised hint: " ++ str)
 739
 740 -- labels are always pointers, so we might as well infer the hint
 741 inferCmmHint :: CmmExpr -> ForeignHint
 742 inferCmmHint (CmmLit (CmmLabel _)) = AddrHint
 743 inferCmmHint (CmmReg (CmmGlobal g)) | isPtrGlobalReg g = AddrHint
 744 inferCmmHint _ = NoHint
 745
 746 isPtrGlobalReg Sp                    = True
 747 isPtrGlobalReg SpLim                 = True
 748 isPtrGlobalReg Hp                    = True
 749 isPtrGlobalReg HpLim                 = True
 750 isPtrGlobalReg CurrentTSO            = True
 751 isPtrGlobalReg CurrentNursery        = True
 752 isPtrGlobalReg (VanillaReg _ VGcPtr) = True
 753 isPtrGlobalReg _                     = False
 754
 755 happyError :: P a
 756 happyError = srcParseFail
 757
 758 -- -----------------------------------------------------------------------------
 759 -- Statement-level macros
 760
 761 stmtMacro :: FastString -> [ExtFCode CmmExpr] -> P ExtCode
 762 stmtMacro fun args_code = do
 763   case lookupUFM stmtMacros fun of
 764     Nothing -> fail ("unknown macro: " ++ unpackFS fun)
 765     Just fcode -> return $ do
 766         args <- sequence args_code
 767         code (fcode args)
 768
 769 stmtMacros :: UniqFM ([CmmExpr] -> Code)
 770 stmtMacros = listToUFM [
 771   ( fsLit "CCS_ALLOC",             \[words,ccs]  -> profAlloc words ccs ),
 772   ( fsLit "CLOSE_NURSERY",         \[]  -> emitCloseNursery ),
 773   ( fsLit "ENTER_CCS_PAP_CL",     \[e] -> enterCostCentrePAP e ),
 774   ( fsLit "ENTER_CCS_THUNK",      \[e] -> enterCostCentreThunk e ),
 775   ( fsLit "HP_CHK_GEN",           \[words,liveness,reentry] ->
 776                                       hpChkGen words liveness reentry ),
 777   ( fsLit "HP_CHK_NP_ASSIGN_SP0", \[e,f] -> hpChkNodePointsAssignSp0 e f ),
 778   ( fsLit "LOAD_THREAD_STATE",    \[] -> emitLoadThreadState ),
 779   ( fsLit "LDV_ENTER",            \[e] -> ldvEnter e ),
 780   ( fsLit "LDV_RECORD_CREATE",    \[e] -> ldvRecordCreate e ),
 781   ( fsLit "OPEN_NURSERY",          \[]  -> emitOpenNursery ),
 782   ( fsLit "PUSH_UPD_FRAME",        \[sp,e] -> emitPushUpdateFrame sp e ),
 783   ( fsLit "SAVE_THREAD_STATE",    \[] -> emitSaveThreadState ),
 784   ( fsLit "SET_HDR",               \[ptr,info,ccs] ->
 785                                         emitSetDynHdr ptr info ccs ),
 786   ( fsLit "STK_CHK_GEN",          \[words,liveness,reentry] ->
 787                                       stkChkGen words liveness reentry ),
 788   ( fsLit "STK_CHK_NP",    \[e] -> stkChkNodePoints e ),
 789   ( fsLit "TICK_ALLOC_PRIM",       \[hdr,goods,slop] ->
 790                                         tickyAllocPrim hdr goods slop ),
 791   ( fsLit "TICK_ALLOC_PAP",       \[goods,slop] ->
 792                                         tickyAllocPAP goods slop ),
 793   ( fsLit "TICK_ALLOC_UP_THK",    \[goods,slop] ->
 794                                         tickyAllocThunk goods slop ),
 795   ( fsLit "UPD_BH_UPDATABLE",       \[] -> emitBlackHoleCode False ),
 796   ( fsLit "UPD_BH_SINGLE_ENTRY",    \[] -> emitBlackHoleCode True ),
 797
 798   ( fsLit "RET_P",      \[a] ->       emitRetUT [(PtrArg,a)]),
 799   ( fsLit "RET_N",      \[a] ->       emitRetUT [(NonPtrArg,a)]),
 800   ( fsLit "RET_PP",     \[a,b] ->     emitRetUT [(PtrArg,a),(PtrArg,b)]),
 801   ( fsLit "RET_NN",     \[a,b] ->     emitRetUT [(NonPtrArg,a),(NonPtrArg,b)]),
 802   ( fsLit "RET_NP",     \[a,b] ->     emitRetUT [(NonPtrArg,a),(PtrArg,b)]),
 803   ( fsLit "RET_PPP",    \[a,b,c] ->   emitRetUT [(PtrArg,a),(PtrArg,b),(PtrArg,c)]),
 804   ( fsLit "RET_NPP",    \[a,b,c] ->   emitRetUT [(NonPtrArg,a),(PtrArg,b),(PtrArg,c)]),
 805   ( fsLit "RET_NNP",    \[a,b,c] ->   emitRetUT [(NonPtrArg,a),(NonPtrArg,b),(PtrArg,c)]),
 806   ( fsLit "RET_NNN",  \[a,b,c] -> emitRetUT [(NonPtrArg,a),(NonPtrArg,b),(NonPtrArg,c)]),
 807   ( fsLit "RET_NNNN",  \[a,b,c,d] -> emitRetUT [(NonPtrArg,a),(NonPtrArg,b),(NonPtrArg,c),(NonPtrArg,d)]),
 808   ( fsLit "RET_NNNP",   \[a,b,c,d] -> emitRetUT [(NonPtrArg,a),(NonPtrArg,b),(NonPtrArg,c),(PtrArg,d)]),
 809   ( fsLit "RET_NPNP",   \[a,b,c,d] -> emitRetUT [(NonPtrArg,a),(PtrArg,b),(NonPtrArg,c),(PtrArg,d)])
 810
 811  ]
 812
 813
 814
 815 profilingInfo desc_str ty_str = do
 816   lit1 <- if opt_SccProfilingOn
 817                    then code $ mkStringCLit desc_str
 818                    else return (mkIntCLit 0)
 819   lit2 <- if opt_SccProfilingOn
 820                    then code $ mkStringCLit ty_str
 821                    else return (mkIntCLit 0)
 822   return (ProfilingInfo lit1 lit2)
 823
 824
 825 staticClosure :: PackageId -> FastString -> FastString -> [CmmLit] -> ExtCode
 826 staticClosure pkg cl_label info payload
 827   = code $ emitDataLits (mkCmmDataLabel pkg cl_label) lits
 828   where  lits = mkStaticClosure (mkCmmInfoLabel pkg info) dontCareCCS payload [] [] []
 829
 830 foreignCall
 831         :: String
 832         -> [ExtFCode HintedCmmFormal]
 833         -> ExtFCode CmmExpr
 834         -> [ExtFCode HintedCmmActual]
 835         -> Maybe [GlobalReg]
 836         -> CmmSafety
 837         -> CmmReturnInfo
 838         -> P ExtCode
 839 foreignCall conv_string results_code expr_code args_code vols safety ret
 840   = do  convention <- case conv_string of
 841           "C" -> return CCallConv
 842           "stdcall" -> return StdCallConv
 843           "C--" -> return CmmCallConv
 844           _ -> fail ("unknown calling convention: " ++ conv_string)
 845         return $ do
 846           results <- sequence results_code
 847           expr <- expr_code
 848           args <- sequence args_code
 849           --code (stmtC (CmmCall (CmmCallee expr convention) results args safety))
 850           case convention of
 851             -- Temporary hack so at least some functions are CmmSafe
 852             CmmCallConv -> code (stmtC (CmmCall (CmmCallee expr convention) results args safety ret))
 853             _ ->
 854               let expr' = adjCallTarget convention expr args in
 855               case safety of
 856               CmmUnsafe ->
 857                 code (emitForeignCall' PlayRisky results
 858                    (CmmCallee expr' convention) args vols NoC_SRT ret)
 859               CmmSafe srt ->
 860                 code (emitForeignCall' (PlaySafe unused) results
 861                    (CmmCallee expr' convention) args vols NoC_SRT ret) where
 862                 unused = panic "not used by emitForeignCall'"
 863               CmmInterruptible ->
 864                 code (emitForeignCall' PlayInterruptible results
 865                    (CmmCallee expr' convention) args vols NoC_SRT ret)
 866
 867 adjCallTarget :: CCallConv -> CmmExpr -> [CmmHinted CmmExpr] -> CmmExpr
 868 #ifdef mingw32_TARGET_OS
 869 -- On Windows, we have to add the '@N' suffix to the label when making
 870 -- a call with the stdcall calling convention.
 871 adjCallTarget StdCallConv (CmmLit (CmmLabel lbl)) args
 872   = CmmLit (CmmLabel (addLabelSize lbl (sum (map size args))))
 873   where size (CmmHinted e _) = max wORD_SIZE (widthInBytes (typeWidth (cmmExprType e)))
 874                  -- c.f. CgForeignCall.emitForeignCall
 875 #endif
 876 adjCallTarget _ expr _
 877   = expr
 878
 879 primCall
 880         :: [ExtFCode HintedCmmFormal]
 881         -> FastString
 882         -> [ExtFCode HintedCmmActual]
 883         -> Maybe [GlobalReg]
 884         -> CmmSafety
 885         -> P ExtCode
 886 primCall results_code name args_code vols safety
 887   = case lookupUFM callishMachOps name of
 888         Nothing -> fail ("unknown primitive " ++ unpackFS name)
 889         Just p  -> return $ do
 890                 results <- sequence results_code
 891                 args <- sequence args_code
 892                 case safety of
 893                   CmmUnsafe ->
 894                     code (emitForeignCall' PlayRisky results
 895                       (CmmPrim p) args vols NoC_SRT CmmMayReturn)
 896                   CmmSafe srt ->
 897                     code (emitForeignCall' (PlaySafe unused) results
 898                       (CmmPrim p) args vols NoC_SRT CmmMayReturn) where
 899                     unused = panic "not used by emitForeignCall'"
 900                   CmmInterruptible ->
 901                     code (emitForeignCall' PlayInterruptible results
 902                       (CmmPrim p) args vols NoC_SRT CmmMayReturn)
 903
 904 doStore :: CmmType -> ExtFCode CmmExpr  -> ExtFCode CmmExpr -> ExtCode
 905 doStore rep addr_code val_code
 906   = do addr <- addr_code
 907        val <- val_code
 908         -- if the specified store type does not match the type of the expr
 909         -- on the rhs, then we insert a coercion that will cause the type
 910         -- mismatch to be flagged by cmm-lint.  If we don't do this, then
 911         -- the store will happen at the wrong type, and the error will not
 912         -- be noticed.
 913        let val_width = typeWidth (cmmExprType val)
 914            rep_width = typeWidth rep
 915        let coerce_val
 916                 | val_width /= rep_width = CmmMachOp (MO_UU_Conv val_width rep_width) [val]
 917                 | otherwise              = val
 918        stmtEC (CmmStore addr coerce_val)
 919
 920 -- Return an unboxed tuple.
 921 emitRetUT :: [(CgRep,CmmExpr)] -> Code
 922 emitRetUT args = do
 923   tickyUnboxedTupleReturn (length args)  -- TICK
 924   (sp, stmts) <- pushUnboxedTuple 0 args
 925   emitSimultaneously stmts -- NB. the args might overlap with the stack slots
 926                            -- or regs that we assign to, so better use
 927                            -- simultaneous assignments here (#3546)
 928   when (sp /= 0) $ stmtC (CmmAssign spReg (cmmRegOffW spReg (-sp)))
 929   stmtC (CmmJump (entryCode (CmmLoad (cmmRegOffW spReg sp) bWord)) [])
 930   -- TODO (when using CPS): emitStmt (CmmReturn (map snd args))
 931
 932 -- -----------------------------------------------------------------------------
 933 -- If-then-else and boolean expressions
 934
 935 data BoolExpr
 936   = BoolExpr `BoolAnd` BoolExpr
 937   | BoolExpr `BoolOr`  BoolExpr
 938   | BoolNot BoolExpr
 939   | BoolTest CmmExpr
 940
 941 -- ToDo: smart constructors which simplify the boolean expression.
 942
 943 cmmIfThenElse cond then_part else_part = do
 944      then_id <- code newLabelC
 945      join_id <- code newLabelC
 946      c <- cond
 947      emitCond c then_id
 948      else_part
 949      stmtEC (CmmBranch join_id)
 950      code (labelC then_id)
 951      then_part
 952      -- fall through to join
 953      code (labelC join_id)
 954
 955 -- 'emitCond cond true_id'  emits code to test whether the cond is true,
 956 -- branching to true_id if so, and falling through otherwise.
 957 emitCond (BoolTest e) then_id = do
 958   stmtEC (CmmCondBranch e then_id)
 959 emitCond (BoolNot (BoolTest (CmmMachOp op args))) then_id
 960   | Just op' <- maybeInvertComparison op
 961   = emitCond (BoolTest (CmmMachOp op' args)) then_id
 962 emitCond (BoolNot e) then_id = do
 963   else_id <- code newLabelC
 964   emitCond e else_id
 965   stmtEC (CmmBranch then_id)
 966   code (labelC else_id)
 967 emitCond (e1 `BoolOr` e2) then_id = do
 968   emitCond e1 then_id
 969   emitCond e2 then_id
 970 emitCond (e1 `BoolAnd` e2) then_id = do
 971         -- we'd like to invert one of the conditionals here to avoid an
 972         -- extra branch instruction, but we can't use maybeInvertComparison
 973         -- here because we can't look too closely at the expression since
 974         -- we're in a loop.
 975   and_id <- code newLabelC
 976   else_id <- code newLabelC
 977   emitCond e1 and_id
 978   stmtEC (CmmBranch else_id)
 979   code (labelC and_id)
 980   emitCond e2 then_id
 981   code (labelC else_id)
 982
 983
 984 -- -----------------------------------------------------------------------------
 985 -- Table jumps
 986
 987 -- We use a simplified form of C-- switch statements for now.  A
 988 -- switch statement always compiles to a table jump.  Each arm can
 989 -- specify a list of values (not ranges), and there can be a single
 990 -- default branch.  The range of the table is given either by the
 991 -- optional range on the switch (eg. switch [0..7] {...}), or by
 992 -- the minimum/maximum values from the branches.
 993
 994 doSwitch :: Maybe (Int,Int) -> ExtFCode CmmExpr -> [([Int],ExtCode)]
 995          -> Maybe ExtCode -> ExtCode
 996 doSwitch mb_range scrut arms deflt
 997    = do
 998         -- Compile code for the default branch
 999         dflt_entry <-
1000                 case deflt of
1001                   Nothing -> return Nothing
1002                   Just e  -> do b <- forkLabelledCodeEC e; return (Just b)
1003
1004         -- Compile each case branch
1005         table_entries <- mapM emitArm arms
1006
1007         -- Construct the table
1008         let
1009             all_entries = concat table_entries
1010             ixs = map fst all_entries
1011             (min,max)
1012                 | Just (l,u) <- mb_range = (l,u)
1013                 | otherwise              = (minimum ixs, maximum ixs)
1014
1015             entries = elems (accumArray (\_ a -> Just a) dflt_entry (min,max)
1016                                 all_entries)
1017         expr <- scrut
1018         -- ToDo: check for out of range and jump to default if necessary
1019         stmtEC (CmmSwitch expr entries)
1020    where
1021         emitArm :: ([Int],ExtCode) -> ExtFCode [(Int,BlockId)]
1022         emitArm (ints,code) = do
1023            blockid <- forkLabelledCodeEC code
1024            return [ (i,blockid) | i <- ints ]
1025
1026
1027 -- -----------------------------------------------------------------------------
1028 -- Putting it all together
1029
1030 -- The initial environment: we define some constants that the compiler
1031 -- knows about here.
1032 initEnv :: Env
1033 initEnv = listToUFM [
1034   ( fsLit "SIZEOF_StgHeader",
1035     Var (CmmLit (CmmInt (fromIntegral (fixedHdrSize * wORD_SIZE)) wordWidth) )),
1036   ( fsLit "SIZEOF_StgInfoTable",
1037     Var (CmmLit (CmmInt (fromIntegral stdInfoTableSizeB) wordWidth) ))
1038   ]
1039
1040 parseCmmFile :: DynFlags -> FilePath -> IO (Messages, Maybe Cmm)
1041 parseCmmFile dflags filename = do
1042   showPass dflags "ParseCmm"
1043   buf <- hGetStringBuffer filename
1044   let
1045         init_loc = mkSrcLoc (mkFastString filename) 1 1
1046         init_state = (mkPState dflags buf init_loc) { lex_state = [0] }
1047                 -- reset the lex_state: the Lexer monad leaves some stuff
1048                 -- in there we don't want.
1049   case unP cmmParse init_state of
1050     PFailed span err -> do
1051         let msg = mkPlainErrMsg span err
1052         return ((emptyBag, unitBag msg), Nothing)
1053     POk pst code -> do
1054         cmm <- initC dflags no_module (getCmm (unEC code initEnv [] >> return ()))
1055         let ms = getMessages pst
1056         if (errorsFound dflags ms)
1057          then return (ms, Nothing)
1058          else do
1059            dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (ppr cmm)
1060            return (ms, Just cmm)
1061   where
1062         no_module = panic "parseCmmFile: no module"
1063 }