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