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 OldCmm
  41 import OldPprCmm()
  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                 { do as <- sequence $5; doSwitch $2 $3 as $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 'goto' NAME
 407                 { do l <- lookupLabel $4; cmmRawIf $2 l }
 408         | 'if' bool_expr '{' body '}' else
 409                 { cmmIfThenElse $2 $4 $6 }
 410
 411 opt_never_returns :: { CmmReturnInfo }
 412         :                               { CmmMayReturn }
 413         | 'never' 'returns'             { CmmNeverReturns }
 414
 415 bool_expr :: { ExtFCode BoolExpr }
 416         : bool_op                       { $1 }
 417         | expr                          { do e <- $1; return (BoolTest e) }
 418
 419 bool_op :: { ExtFCode BoolExpr }
 420         : bool_expr '&&' bool_expr      { do e1 <- $1; e2 <- $3;
 421                                           return (BoolAnd e1 e2) }
 422         | bool_expr '||' bool_expr      { do e1 <- $1; e2 <- $3;
 423                                           return (BoolOr e1 e2)  }
 424         | '!' bool_expr                 { do e <- $2; return (BoolNot e) }
 425         | '(' bool_op ')'               { $2 }
 426
 427 -- This is not C-- syntax.  What to do?
 428 safety  :: { CmmSafety }
 429         : {- empty -}                   { CmmUnsafe } -- Default may change soon
 430         | STRING                        {% parseSafety $1 }
 431
 432 -- This is not C-- syntax.  What to do?
 433 vols    :: { Maybe [GlobalReg] }
 434         : {- empty -}                   { Nothing }
 435         | '[' ']'                       { Just [] }
 436         | '[' globals ']'               { Just $2 }
 437
 438 globals :: { [GlobalReg] }
 439         : GLOBALREG                     { [$1] }
 440         | GLOBALREG ',' globals         { $1 : $3 }
 441
 442 maybe_range :: { Maybe (Int,Int) }
 443         : '[' INT '..' INT ']'  { Just (fromIntegral $2, fromIntegral $4) }
 444         | {- empty -}           { Nothing }
 445
 446 arms    :: { [ExtFCode ([Int],Either BlockId ExtCode)] }
 447         : {- empty -}                   { [] }
 448         | arm arms                      { $1 : $2 }
 449
 450 arm     :: { ExtFCode ([Int],Either BlockId ExtCode) }
 451         : 'case' ints ':' arm_body      { do b <- $4; return ($2, b) }
 452
 453 arm_body :: { ExtFCode (Either BlockId ExtCode) }
 454         : '{' body '}'                  { return (Right $2) }
 455         | 'goto' NAME ';'               { do l <- lookupLabel $2; return (Left l) }
 456
 457 ints    :: { [Int] }
 458         : INT                           { [ fromIntegral $1 ] }
 459         | INT ',' ints                  { fromIntegral $1 : $3 }
 460
 461 default :: { Maybe ExtCode }
 462         : 'default' ':' '{' body '}'    { Just $4 }
 463         -- taking a few liberties with the C-- syntax here; C-- doesn't have
 464         -- 'default' branches
 465         | {- empty -}                   { Nothing }
 466
 467 -- Note: OldCmm doesn't support a first class 'else' statement, though
 468 -- CmmNode does.
 469 else    :: { ExtCode }
 470         : {- empty -}                   { nopEC }
 471         | 'else' '{' body '}'           { $3 }
 472
 473 -- we have to write this out longhand so that Happy's precedence rules
 474 -- can kick in.
 475 expr    :: { ExtFCode CmmExpr }
 476         : expr '/' expr                 { mkMachOp MO_U_Quot [$1,$3] }
 477         | expr '*' expr                 { mkMachOp MO_Mul [$1,$3] }
 478         | expr '%' expr                 { mkMachOp MO_U_Rem [$1,$3] }
 479         | expr '-' expr                 { mkMachOp MO_Sub [$1,$3] }
 480         | expr '+' expr                 { mkMachOp MO_Add [$1,$3] }
 481         | expr '>>' expr                { mkMachOp MO_U_Shr [$1,$3] }
 482         | expr '<<' expr                { mkMachOp MO_Shl [$1,$3] }
 483         | expr '&' expr                 { mkMachOp MO_And [$1,$3] }
 484         | expr '^' expr                 { mkMachOp MO_Xor [$1,$3] }
 485         | expr '|' expr                 { mkMachOp MO_Or [$1,$3] }
 486         | expr '>=' expr                { mkMachOp MO_U_Ge [$1,$3] }
 487         | expr '>' expr                 { mkMachOp MO_U_Gt [$1,$3] }
 488         | expr '<=' expr                { mkMachOp MO_U_Le [$1,$3] }
 489         | expr '<' expr                 { mkMachOp MO_U_Lt [$1,$3] }
 490         | expr '!=' expr                { mkMachOp MO_Ne [$1,$3] }
 491         | expr '==' expr                { mkMachOp MO_Eq [$1,$3] }
 492         | '~' expr                      { mkMachOp MO_Not [$2] }
 493         | '-' expr                      { mkMachOp MO_S_Neg [$2] }
 494         | expr0 '`' NAME '`' expr0      {% do { mo <- nameToMachOp $3 ;
 495                                                 return (mkMachOp mo [$1,$5]) } }
 496         | expr0                         { $1 }
 497
 498 expr0   :: { ExtFCode CmmExpr }
 499         : INT   maybe_ty         { return (CmmLit (CmmInt $1 (typeWidth $2))) }
 500         | FLOAT maybe_ty         { return (CmmLit (CmmFloat $1 (typeWidth $2))) }
 501         | STRING                 { do s <- code (mkStringCLit $1);
 502                                       return (CmmLit s) }
 503         | reg                    { $1 }
 504         | type '[' expr ']'      { do e <- $3; return (CmmLoad e $1) }
 505         | '%' NAME '(' exprs0 ')' {% exprOp $2 $4 }
 506         | '(' expr ')'           { $2 }
 507
 508
 509 -- leaving out the type of a literal gives you the native word size in C--
 510 maybe_ty :: { CmmType }
 511         : {- empty -}                   { bWord }
 512         | '::' type                     { $2 }
 513
 514 maybe_actuals :: { [ExtFCode HintedCmmActual] }
 515         : {- empty -}           { [] }
 516         | '(' cmm_hint_exprs0 ')'       { $2 }
 517
 518 cmm_hint_exprs0 :: { [ExtFCode HintedCmmActual] }
 519         : {- empty -}                   { [] }
 520         | cmm_hint_exprs                        { $1 }
 521
 522 cmm_hint_exprs :: { [ExtFCode HintedCmmActual] }
 523         : cmm_hint_expr                 { [$1] }
 524         | cmm_hint_expr ',' cmm_hint_exprs      { $1 : $3 }
 525
 526 cmm_hint_expr :: { ExtFCode HintedCmmActual }
 527         : expr                          { do e <- $1; return (CmmHinted e (inferCmmHint e)) }
 528         | expr STRING                   {% do h <- parseCmmHint $2;
 529                                               return $ do
 530                                                 e <- $1; return (CmmHinted e h) }
 531
 532 exprs0  :: { [ExtFCode CmmExpr] }
 533         : {- empty -}                   { [] }
 534         | exprs                         { $1 }
 535
 536 exprs   :: { [ExtFCode CmmExpr] }
 537         : expr                          { [ $1 ] }
 538         | expr ',' exprs                { $1 : $3 }
 539
 540 reg     :: { ExtFCode CmmExpr }
 541         : NAME                  { lookupName $1 }
 542         | GLOBALREG             { return (CmmReg (CmmGlobal $1)) }
 543
 544 maybe_results :: { [ExtFCode HintedCmmFormal] }
 545         : {- empty -}           { [] }
 546         | '(' cmm_formals ')' '='       { $2 }
 547
 548 cmm_formals :: { [ExtFCode HintedCmmFormal] }
 549         : cmm_formal                    { [$1] }
 550         | cmm_formal ','                        { [$1] }
 551         | cmm_formal ',' cmm_formals    { $1 : $3 }
 552
 553 cmm_formal :: { ExtFCode HintedCmmFormal }
 554         : local_lreg                    { do e <- $1; return (CmmHinted e (inferCmmHint (CmmReg (CmmLocal e)))) }
 555         | STRING local_lreg             {% do h <- parseCmmHint $1;
 556                                               return $ do
 557                                                 e <- $2; return (CmmHinted e h) }
 558
 559 local_lreg :: { ExtFCode LocalReg }
 560         : NAME                  { do e <- lookupName $1;
 561                                      return $
 562                                        case e of
 563                                         CmmReg (CmmLocal r) -> r
 564                                         other -> pprPanic "CmmParse:" (ftext $1 <> text " not a local register") }
 565
 566 lreg    :: { ExtFCode CmmReg }
 567         : NAME                  { do e <- lookupName $1;
 568                                      return $
 569                                        case e of
 570                                         CmmReg r -> r
 571                                         other -> pprPanic "CmmParse:" (ftext $1 <> text " not a register") }
 572         | GLOBALREG             { return (CmmGlobal $1) }
 573
 574 maybe_formals_without_hints :: { [ExtFCode LocalReg] }
 575         : {- empty -}           { [] }
 576         | '(' formals_without_hints0 ')'        { $2 }
 577
 578 formals_without_hints0 :: { [ExtFCode LocalReg] }
 579         : {- empty -}           { [] }
 580         | formals_without_hints         { $1 }
 581
 582 formals_without_hints :: { [ExtFCode LocalReg] }
 583         : formal_without_hint ','               { [$1] }
 584         | formal_without_hint           { [$1] }
 585         | formal_without_hint ',' formals_without_hints { $1 : $3 }
 586
 587 formal_without_hint :: { ExtFCode LocalReg }
 588         : type NAME             { newLocal $1 $2 }
 589
 590 maybe_frame :: { ExtFCode (Maybe UpdateFrame) }
 591         : {- empty -}                   { return Nothing }
 592         | 'jump' expr '(' exprs0 ')'    { do { target <- $2;
 593                                                args <- sequence $4;
 594                                                return $ Just (UpdateFrame target args) } }
 595
 596 maybe_gc_block :: { ExtFCode (Maybe BlockId) }
 597         : {- empty -}                   { return Nothing }
 598         | 'goto' NAME
 599                 { do l <- lookupLabel $2; return (Just l) }
 600
 601 type    :: { CmmType }
 602         : 'bits8'               { b8 }
 603         | typenot8              { $1 }
 604
 605 typenot8 :: { CmmType }
 606         : 'bits16'              { b16 }
 607         | 'bits32'              { b32 }
 608         | 'bits64'              { b64 }
 609         | 'float32'             { f32 }
 610         | 'float64'             { f64 }
 611         | 'gcptr'               { gcWord }
 612 {
 613 section :: String -> Section
 614 section "text"   = Text
 615 section "data"   = Data
 616 section "rodata" = ReadOnlyData
 617 section "relrodata" = RelocatableReadOnlyData
 618 section "bss"    = UninitialisedData
 619 section s        = OtherSection s
 620
 621 mkString :: String -> CmmStatic
 622 mkString s = CmmString (map (fromIntegral.ord) s)
 623
 624 -- mkMachOp infers the type of the MachOp from the type of its first
 625 -- argument.  We assume that this is correct: for MachOps that don't have
 626 -- symmetrical args (e.g. shift ops), the first arg determines the type of
 627 -- the op.
 628 mkMachOp :: (Width -> MachOp) -> [ExtFCode CmmExpr] -> ExtFCode CmmExpr
 629 mkMachOp fn args = do
 630   arg_exprs <- sequence args
 631   return (CmmMachOp (fn (typeWidth (cmmExprType (head arg_exprs)))) arg_exprs)
 632
 633 getLit :: CmmExpr -> CmmLit
 634 getLit (CmmLit l) = l
 635 getLit (CmmMachOp (MO_S_Neg _) [CmmLit (CmmInt i r)])  = CmmInt (negate i) r
 636 getLit _ = panic "invalid literal" -- TODO messy failure
 637
 638 nameToMachOp :: FastString -> P (Width -> MachOp)
 639 nameToMachOp name =
 640   case lookupUFM machOps name of
 641         Nothing -> fail ("unknown primitive " ++ unpackFS name)
 642         Just m  -> return m
 643
 644 exprOp :: FastString -> [ExtFCode CmmExpr] -> P (ExtFCode CmmExpr)
 645 exprOp name args_code =
 646   case lookupUFM exprMacros name of
 647      Just f  -> return $ do
 648         args <- sequence args_code
 649         return (f args)
 650      Nothing -> do
 651         mo <- nameToMachOp name
 652         return $ mkMachOp mo args_code
 653
 654 exprMacros :: UniqFM ([CmmExpr] -> CmmExpr)
 655 exprMacros = listToUFM [
 656   ( fsLit "ENTRY_CODE",   \ [x] -> entryCode x ),
 657   ( fsLit "INFO_PTR",     \ [x] -> closureInfoPtr x ),
 658   ( fsLit "STD_INFO",     \ [x] -> infoTable x ),
 659   ( fsLit "FUN_INFO",     \ [x] -> funInfoTable x ),
 660   ( fsLit "GET_ENTRY",    \ [x] -> entryCode (closureInfoPtr x) ),
 661   ( fsLit "GET_STD_INFO", \ [x] -> infoTable (closureInfoPtr x) ),
 662   ( fsLit "GET_FUN_INFO", \ [x] -> funInfoTable (closureInfoPtr x) ),
 663   ( fsLit "INFO_TYPE",    \ [x] -> infoTableClosureType x ),
 664   ( fsLit "INFO_PTRS",    \ [x] -> infoTablePtrs x ),
 665   ( fsLit "INFO_NPTRS",   \ [x] -> infoTableNonPtrs x )
 666   ]
 667
 668 -- we understand a subset of C-- primitives:
 669 machOps = listToUFM $
 670         map (\(x, y) -> (mkFastString x, y)) [
 671         ( "add",        MO_Add ),
 672         ( "sub",        MO_Sub ),
 673         ( "eq",         MO_Eq ),
 674         ( "ne",         MO_Ne ),
 675         ( "mul",        MO_Mul ),
 676         ( "neg",        MO_S_Neg ),
 677         ( "quot",       MO_S_Quot ),
 678         ( "rem",        MO_S_Rem ),
 679         ( "divu",       MO_U_Quot ),
 680         ( "modu",       MO_U_Rem ),
 681
 682         ( "ge",         MO_S_Ge ),
 683         ( "le",         MO_S_Le ),
 684         ( "gt",         MO_S_Gt ),
 685         ( "lt",         MO_S_Lt ),
 686
 687         ( "geu",        MO_U_Ge ),
 688         ( "leu",        MO_U_Le ),
 689         ( "gtu",        MO_U_Gt ),
 690         ( "ltu",        MO_U_Lt ),
 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         ( "fadd",       MO_F_Add ),
 701         ( "fsub",       MO_F_Sub ),
 702         ( "fneg",       MO_F_Neg ),
 703         ( "fmul",       MO_F_Mul ),
 704         ( "fquot",      MO_F_Quot ),
 705
 706         ( "feq",        MO_F_Eq ),
 707         ( "fne",        MO_F_Ne ),
 708         ( "fge",        MO_F_Ge ),
 709         ( "fle",        MO_F_Le ),
 710         ( "fgt",        MO_F_Gt ),
 711         ( "flt",        MO_F_Lt ),
 712
 713         ( "lobits8",  flip MO_UU_Conv W8  ),
 714         ( "lobits16", flip MO_UU_Conv W16 ),
 715         ( "lobits32", flip MO_UU_Conv W32 ),
 716         ( "lobits64", flip MO_UU_Conv W64 ),
 717
 718         ( "zx16",     flip MO_UU_Conv W16 ),
 719         ( "zx32",     flip MO_UU_Conv W32 ),
 720         ( "zx64",     flip MO_UU_Conv W64 ),
 721
 722         ( "sx16",     flip MO_SS_Conv W16 ),
 723         ( "sx32",     flip MO_SS_Conv W32 ),
 724         ( "sx64",     flip MO_SS_Conv W64 ),
 725
 726         ( "f2f32",    flip MO_FF_Conv W32 ),  -- TODO; rounding mode
 727         ( "f2f64",    flip MO_FF_Conv W64 ),  -- TODO; rounding mode
 728         ( "f2i8",     flip MO_FS_Conv W8 ),
 729         ( "f2i16",    flip MO_FS_Conv W16 ),
 730         ( "f2i32",    flip MO_FS_Conv W32 ),
 731         ( "f2i64",    flip MO_FS_Conv W64 ),
 732         ( "i2f32",    flip MO_SF_Conv W32 ),
 733         ( "i2f64",    flip MO_SF_Conv W64 )
 734         ]
 735
 736 callishMachOps = listToUFM $
 737         map (\(x, y) -> (mkFastString x, y)) [
 738         ( "write_barrier", MO_WriteBarrier ),
 739         ( "memcpy", MO_Memcpy ),
 740         ( "memset", MO_Memset ),
 741         ( "memmove", MO_Memmove )
 742         -- ToDo: the rest, maybe
 743     ]
 744
 745 parseSafety :: String -> P CmmSafety
 746 parseSafety "safe"   = return (CmmSafe NoC_SRT)
 747 parseSafety "unsafe" = return CmmUnsafe
 748 parseSafety "interruptible" = return CmmInterruptible
 749 parseSafety str      = fail ("unrecognised safety: " ++ str)
 750
 751 parseCmmHint :: String -> P ForeignHint
 752 parseCmmHint "ptr"    = return AddrHint
 753 parseCmmHint "signed" = return SignedHint
 754 parseCmmHint str      = fail ("unrecognised hint: " ++ str)
 755
 756 -- labels are always pointers, so we might as well infer the hint
 757 inferCmmHint :: CmmExpr -> ForeignHint
 758 inferCmmHint (CmmLit (CmmLabel _)) = AddrHint
 759 inferCmmHint (CmmReg (CmmGlobal g)) | isPtrGlobalReg g = AddrHint
 760 inferCmmHint _ = NoHint
 761
 762 isPtrGlobalReg Sp                    = True
 763 isPtrGlobalReg SpLim                 = True
 764 isPtrGlobalReg Hp                    = True
 765 isPtrGlobalReg HpLim                 = True
 766 isPtrGlobalReg CurrentTSO            = True
 767 isPtrGlobalReg CurrentNursery        = True
 768 isPtrGlobalReg (VanillaReg _ VGcPtr) = True
 769 isPtrGlobalReg _                     = False
 770
 771 happyError :: P a
 772 happyError = srcParseFail
 773
 774 -- -----------------------------------------------------------------------------
 775 -- Statement-level macros
 776
 777 stmtMacro :: FastString -> [ExtFCode CmmExpr] -> P ExtCode
 778 stmtMacro fun args_code = do
 779   case lookupUFM stmtMacros fun of
 780     Nothing -> fail ("unknown macro: " ++ unpackFS fun)
 781     Just fcode -> return $ do
 782         args <- sequence args_code
 783         code (fcode args)
 784
 785 stmtMacros :: UniqFM ([CmmExpr] -> Code)
 786 stmtMacros = listToUFM [
 787   ( fsLit "CCS_ALLOC",             \[words,ccs]  -> profAlloc words ccs ),
 788   ( fsLit "CLOSE_NURSERY",         \[]  -> emitCloseNursery ),
 789   ( fsLit "ENTER_CCS_PAP_CL",     \[e] -> enterCostCentrePAP e ),
 790   ( fsLit "ENTER_CCS_THUNK",      \[e] -> enterCostCentreThunk e ),
 791   ( fsLit "HP_CHK_GEN",           \[words,liveness,reentry] ->
 792                                       hpChkGen words liveness reentry ),
 793   ( fsLit "HP_CHK_NP_ASSIGN_SP0", \[e,f] -> hpChkNodePointsAssignSp0 e f ),
 794   ( fsLit "LOAD_THREAD_STATE",    \[] -> emitLoadThreadState ),
 795   ( fsLit "LDV_ENTER",            \[e] -> ldvEnter e ),
 796   ( fsLit "LDV_RECORD_CREATE",    \[e] -> ldvRecordCreate e ),
 797   ( fsLit "OPEN_NURSERY",          \[]  -> emitOpenNursery ),
 798   ( fsLit "PUSH_UPD_FRAME",        \[sp,e] -> emitPushUpdateFrame sp e ),
 799   ( fsLit "SAVE_THREAD_STATE",    \[] -> emitSaveThreadState ),
 800   ( fsLit "SET_HDR",               \[ptr,info,ccs] ->
 801                                         emitSetDynHdr ptr info ccs ),
 802   ( fsLit "STK_CHK_GEN",          \[words,liveness,reentry] ->
 803                                       stkChkGen words liveness reentry ),
 804   ( fsLit "STK_CHK_NP",    \[e] -> stkChkNodePoints e ),
 805   ( fsLit "TICK_ALLOC_PRIM",       \[hdr,goods,slop] ->
 806                                         tickyAllocPrim hdr goods slop ),
 807   ( fsLit "TICK_ALLOC_PAP",       \[goods,slop] ->
 808                                         tickyAllocPAP goods slop ),
 809   ( fsLit "TICK_ALLOC_UP_THK",    \[goods,slop] ->
 810                                         tickyAllocThunk goods slop ),
 811   ( fsLit "UPD_BH_UPDATABLE",       \[] -> emitBlackHoleCode False ),
 812   ( fsLit "UPD_BH_SINGLE_ENTRY",    \[] -> emitBlackHoleCode True ),
 813
 814   ( fsLit "RET_P",      \[a] ->       emitRetUT [(PtrArg,a)]),
 815   ( fsLit "RET_N",      \[a] ->       emitRetUT [(NonPtrArg,a)]),
 816   ( fsLit "RET_PP",     \[a,b] ->     emitRetUT [(PtrArg,a),(PtrArg,b)]),
 817   ( fsLit "RET_NN",     \[a,b] ->     emitRetUT [(NonPtrArg,a),(NonPtrArg,b)]),
 818   ( fsLit "RET_NP",     \[a,b] ->     emitRetUT [(NonPtrArg,a),(PtrArg,b)]),
 819   ( fsLit "RET_PPP",    \[a,b,c] ->   emitRetUT [(PtrArg,a),(PtrArg,b),(PtrArg,c)]),
 820   ( fsLit "RET_NPP",    \[a,b,c] ->   emitRetUT [(NonPtrArg,a),(PtrArg,b),(PtrArg,c)]),
 821   ( fsLit "RET_NNP",    \[a,b,c] ->   emitRetUT [(NonPtrArg,a),(NonPtrArg,b),(PtrArg,c)]),
 822   ( fsLit "RET_NNN",  \[a,b,c] -> emitRetUT [(NonPtrArg,a),(NonPtrArg,b),(NonPtrArg,c)]),
 823   ( fsLit "RET_NNNN",  \[a,b,c,d] -> emitRetUT [(NonPtrArg,a),(NonPtrArg,b),(NonPtrArg,c),(NonPtrArg,d)]),
 824   ( fsLit "RET_NNNP",   \[a,b,c,d] -> emitRetUT [(NonPtrArg,a),(NonPtrArg,b),(NonPtrArg,c),(PtrArg,d)]),
 825   ( fsLit "RET_NPNP",   \[a,b,c,d] -> emitRetUT [(NonPtrArg,a),(PtrArg,b),(NonPtrArg,c),(PtrArg,d)])
 826
 827  ]
 828
 829
 830
 831 profilingInfo desc_str ty_str = do
 832   lit1 <- if opt_SccProfilingOn
 833                    then code $ mkStringCLit desc_str
 834                    else return (mkIntCLit 0)
 835   lit2 <- if opt_SccProfilingOn
 836                    then code $ mkStringCLit ty_str
 837                    else return (mkIntCLit 0)
 838   return (ProfilingInfo lit1 lit2)
 839
 840
 841 staticClosure :: PackageId -> FastString -> FastString -> [CmmLit] -> ExtCode
 842 staticClosure pkg cl_label info payload
 843   = code $ emitDataLits (mkCmmDataLabel pkg cl_label) lits
 844   where  lits = mkStaticClosure (mkCmmInfoLabel pkg info) dontCareCCS payload [] [] []
 845
 846 foreignCall
 847         :: String
 848         -> [ExtFCode HintedCmmFormal]
 849         -> ExtFCode CmmExpr
 850         -> [ExtFCode HintedCmmActual]
 851         -> Maybe [GlobalReg]
 852         -> CmmSafety
 853         -> CmmReturnInfo
 854         -> P ExtCode
 855 foreignCall conv_string results_code expr_code args_code vols safety ret
 856   = do  convention <- case conv_string of
 857           "C" -> return CCallConv
 858           "stdcall" -> return StdCallConv
 859           "C--" -> return CmmCallConv
 860           _ -> fail ("unknown calling convention: " ++ conv_string)
 861         return $ do
 862           results <- sequence results_code
 863           expr <- expr_code
 864           args <- sequence args_code
 865           --code (stmtC (CmmCall (CmmCallee expr convention) results args safety))
 866           case convention of
 867             -- Temporary hack so at least some functions are CmmSafe
 868             CmmCallConv -> code (stmtC (CmmCall (CmmCallee expr convention) results args safety ret))
 869             _ ->
 870               let expr' = adjCallTarget convention expr args in
 871               case safety of
 872               CmmUnsafe ->
 873                 code (emitForeignCall' PlayRisky results
 874                    (CmmCallee expr' convention) args vols NoC_SRT ret)
 875               CmmSafe srt ->
 876                 code (emitForeignCall' (PlaySafe unused) results
 877                    (CmmCallee expr' convention) args vols NoC_SRT ret) where
 878                 unused = panic "not used by emitForeignCall'"
 879               CmmInterruptible ->
 880                 code (emitForeignCall' PlayInterruptible results
 881                    (CmmCallee expr' convention) args vols NoC_SRT ret)
 882
 883 adjCallTarget :: CCallConv -> CmmExpr -> [CmmHinted CmmExpr] -> CmmExpr
 884 #ifdef mingw32_TARGET_OS
 885 -- On Windows, we have to add the '@N' suffix to the label when making
 886 -- a call with the stdcall calling convention.
 887 adjCallTarget StdCallConv (CmmLit (CmmLabel lbl)) args
 888   = CmmLit (CmmLabel (addLabelSize lbl (sum (map size args))))
 889   where size (CmmHinted e _) = max wORD_SIZE (widthInBytes (typeWidth (cmmExprType e)))
 890                  -- c.f. CgForeignCall.emitForeignCall
 891 #endif
 892 adjCallTarget _ expr _
 893   = expr
 894
 895 primCall
 896         :: [ExtFCode HintedCmmFormal]
 897         -> FastString
 898         -> [ExtFCode HintedCmmActual]
 899         -> Maybe [GlobalReg]
 900         -> CmmSafety
 901         -> P ExtCode
 902 primCall results_code name args_code vols safety
 903   = case lookupUFM callishMachOps name of
 904         Nothing -> fail ("unknown primitive " ++ unpackFS name)
 905         Just p  -> return $ do
 906                 results <- sequence results_code
 907                 args <- sequence args_code
 908                 case safety of
 909                   CmmUnsafe ->
 910                     code (emitForeignCall' PlayRisky results
 911                       (CmmPrim p) args vols NoC_SRT CmmMayReturn)
 912                   CmmSafe srt ->
 913                     code (emitForeignCall' (PlaySafe unused) results
 914                       (CmmPrim p) args vols NoC_SRT CmmMayReturn) where
 915                     unused = panic "not used by emitForeignCall'"
 916                   CmmInterruptible ->
 917                     code (emitForeignCall' PlayInterruptible results
 918                       (CmmPrim p) args vols NoC_SRT CmmMayReturn)
 919
 920 doStore :: CmmType -> ExtFCode CmmExpr  -> ExtFCode CmmExpr -> ExtCode
 921 doStore rep addr_code val_code
 922   = do addr <- addr_code
 923        val <- val_code
 924         -- if the specified store type does not match the type of the expr
 925         -- on the rhs, then we insert a coercion that will cause the type
 926         -- mismatch to be flagged by cmm-lint.  If we don't do this, then
 927         -- the store will happen at the wrong type, and the error will not
 928         -- be noticed.
 929        let val_width = typeWidth (cmmExprType val)
 930            rep_width = typeWidth rep
 931        let coerce_val
 932                 | val_width /= rep_width = CmmMachOp (MO_UU_Conv val_width rep_width) [val]
 933                 | otherwise              = val
 934        stmtEC (CmmStore addr coerce_val)
 935
 936 -- Return an unboxed tuple.
 937 emitRetUT :: [(CgRep,CmmExpr)] -> Code
 938 emitRetUT args = do
 939   tickyUnboxedTupleReturn (length args)  -- TICK
 940   (sp, stmts) <- pushUnboxedTuple 0 args
 941   emitSimultaneously stmts -- NB. the args might overlap with the stack slots
 942                            -- or regs that we assign to, so better use
 943                            -- simultaneous assignments here (#3546)
 944   when (sp /= 0) $ stmtC (CmmAssign spReg (cmmRegOffW spReg (-sp)))
 945   stmtC (CmmJump (entryCode (CmmLoad (cmmRegOffW spReg sp) bWord)) [])
 946   -- TODO (when using CPS): emitStmt (CmmReturn (map snd args))
 947
 948 -- -----------------------------------------------------------------------------
 949 -- If-then-else and boolean expressions
 950
 951 data BoolExpr
 952   = BoolExpr `BoolAnd` BoolExpr
 953   | BoolExpr `BoolOr`  BoolExpr
 954   | BoolNot BoolExpr
 955   | BoolTest CmmExpr
 956
 957 -- ToDo: smart constructors which simplify the boolean expression.
 958
 959 cmmIfThenElse cond then_part else_part = do
 960      then_id <- code newLabelC
 961      join_id <- code newLabelC
 962      c <- cond
 963      emitCond c then_id
 964      else_part
 965      stmtEC (CmmBranch join_id)
 966      code (labelC then_id)
 967      then_part
 968      -- fall through to join
 969      code (labelC join_id)
 970
 971 cmmRawIf cond then_id = do
 972     c <- cond
 973     emitCond c then_id
 974
 975 -- 'emitCond cond true_id'  emits code to test whether the cond is true,
 976 -- branching to true_id if so, and falling through otherwise.
 977 emitCond (BoolTest e) then_id = do
 978   stmtEC (CmmCondBranch e then_id)
 979 emitCond (BoolNot (BoolTest (CmmMachOp op args))) then_id
 980   | Just op' <- maybeInvertComparison op
 981   = emitCond (BoolTest (CmmMachOp op' args)) then_id
 982 emitCond (BoolNot e) then_id = do
 983   else_id <- code newLabelC
 984   emitCond e else_id
 985   stmtEC (CmmBranch then_id)
 986   code (labelC else_id)
 987 emitCond (e1 `BoolOr` e2) then_id = do
 988   emitCond e1 then_id
 989   emitCond e2 then_id
 990 emitCond (e1 `BoolAnd` e2) then_id = do
 991         -- we'd like to invert one of the conditionals here to avoid an
 992         -- extra branch instruction, but we can't use maybeInvertComparison
 993         -- here because we can't look too closely at the expression since
 994         -- we're in a loop.
 995   and_id <- code newLabelC
 996   else_id <- code newLabelC
 997   emitCond e1 and_id
 998   stmtEC (CmmBranch else_id)
 999   code (labelC and_id)
1000   emitCond e2 then_id
1001   code (labelC else_id)
1002
1003
1004 -- -----------------------------------------------------------------------------
1005 -- Table jumps
1006
1007 -- We use a simplified form of C-- switch statements for now.  A
1008 -- switch statement always compiles to a table jump.  Each arm can
1009 -- specify a list of values (not ranges), and there can be a single
1010 -- default branch.  The range of the table is given either by the
1011 -- optional range on the switch (eg. switch [0..7] {...}), or by
1012 -- the minimum/maximum values from the branches.
1013
1014 doSwitch :: Maybe (Int,Int) -> ExtFCode CmmExpr -> [([Int],Either BlockId ExtCode)]
1015          -> Maybe ExtCode -> ExtCode
1016 doSwitch mb_range scrut arms deflt
1017    = do
1018         -- Compile code for the default branch
1019         dflt_entry <-
1020                 case deflt of
1021                   Nothing -> return Nothing
1022                   Just e  -> do b <- forkLabelledCodeEC e; return (Just b)
1023
1024         -- Compile each case branch
1025         table_entries <- mapM emitArm arms
1026
1027         -- Construct the table
1028         let
1029             all_entries = concat table_entries
1030             ixs = map fst all_entries
1031             (min,max)
1032                 | Just (l,u) <- mb_range = (l,u)
1033                 | otherwise              = (minimum ixs, maximum ixs)
1034
1035             entries = elems (accumArray (\_ a -> Just a) dflt_entry (min,max)
1036                                 all_entries)
1037         expr <- scrut
1038         -- ToDo: check for out of range and jump to default if necessary
1039         stmtEC (CmmSwitch expr entries)
1040    where
1041         emitArm :: ([Int],Either BlockId ExtCode) -> ExtFCode [(Int,BlockId)]
1042         emitArm (ints,Left blockid) = return [ (i,blockid) | i <- ints ]
1043         emitArm (ints,Right code) = do
1044            blockid <- forkLabelledCodeEC code
1045            return [ (i,blockid) | i <- ints ]
1046
1047 -- -----------------------------------------------------------------------------
1048 -- Putting it all together
1049
1050 -- The initial environment: we define some constants that the compiler
1051 -- knows about here.
1052 initEnv :: Env
1053 initEnv = listToUFM [
1054   ( fsLit "SIZEOF_StgHeader",
1055     Var (CmmLit (CmmInt (fromIntegral (fixedHdrSize * wORD_SIZE)) wordWidth) )),
1056   ( fsLit "SIZEOF_StgInfoTable",
1057     Var (CmmLit (CmmInt (fromIntegral stdInfoTableSizeB) wordWidth) ))
1058   ]
1059
1060 parseCmmFile :: DynFlags -> FilePath -> IO (Messages, Maybe Cmm)
1061 parseCmmFile dflags filename = do
1062   showPass dflags "ParseCmm"
1063   buf <- hGetStringBuffer filename
1064   let
1065         init_loc = mkSrcLoc (mkFastString filename) 1 1
1066         init_state = (mkPState dflags buf init_loc) { lex_state = [0] }
1067                 -- reset the lex_state: the Lexer monad leaves some stuff
1068                 -- in there we don't want.
1069   case unP cmmParse init_state of
1070     PFailed span err -> do
1071         let msg = mkPlainErrMsg span err
1072         return ((emptyBag, unitBag msg), Nothing)
1073     POk pst code -> do
1074         cmm <- initC dflags no_module (getCmm (unEC code initEnv [] >> return ()))
1075         let ms = getMessages pst
1076         if (errorsFound dflags ms)
1077          then return (ms, Nothing)
1078          else do
1079            dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (ppr cmm)
1080            return (ms, Just cmm)
1081   where
1082         no_module = panic "parseCmmFile: no module"
1083 }