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