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