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