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