compiler/cmm/CmmParse.y

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