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 '{' body '}'
 204                 { do (info_lbl, info) <- $1;
 205                      formals <- sequence $2;
 206                      stmts <- getCgStmtsEC (loopDecls $4)
 207                      blks <- code (cgStmtsToBlocks stmts)
 208                      code (emitInfoTableAndCode info_lbl info formals blks) }
 209
 210         | info maybe_formals ';'
 211                 { do (info_lbl, info) <- $1;
 212                      formals <- sequence $2;
 213                      code (emitInfoTableAndCode info_lbl info formals []) }
 214
 215         | NAME maybe_formals '{' body '}'
 216                 { do formals <- sequence $2;
 217                      stmts <- getCgStmtsEC (loopDecls $4);
 218                      blks <- code (cgStmtsToBlocks stmts);
 219                      code (emitProc (CmmNonInfo Nothing) (mkRtsCodeLabelFS $1) formals blks) }
 220
 221 info    :: { ExtFCode (CLabel, CmmInfo) }
 222         : 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
 223                 -- ptrs, nptrs, closure type, description, type
 224                 { do prof <- profilingInfo $11 $13
 225                      return (mkRtsInfoLabelFS $3,
 226                         CmmInfo prof Nothing (fromIntegral $9)
 227                                 (ThunkInfo (fromIntegral $5, fromIntegral $7) NoC_SRT)) }
 228
 229         | 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ')'
 230                 -- ptrs, nptrs, closure type, description, type, fun type
 231                 { do prof <- profilingInfo $11 $13
 232                      return (mkRtsInfoLabelFS $3,
 233                         CmmInfo prof Nothing (fromIntegral $9)
 234                                 (FunInfo (fromIntegral $5, fromIntegral $7) NoC_SRT (fromIntegral $15) 0 (panic "INFO_TABLE_FUN:ArgDesr") (panic "INFO_TABLE_FUN:SlowEntry"))) }
 235                 -- we leave most of the fields zero here.  This is only used
 236                 -- to generate the BCO info table in the RTS at the moment.
 237
 238         | 'INFO_TABLE_CONSTR' '(' NAME ',' INT ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
 239                 -- ptrs, nptrs, tag, closure type, description, type
 240                 { do prof <- profilingInfo $13 $15
 241                      -- If profiling is on, this string gets duplicated,
 242                      -- but that's the way the old code did it we can fix it some other time.
 243                      desc_lit <- code $ mkStringCLit $13
 244                      return (mkRtsInfoLabelFS $3,
 245                         CmmInfo prof Nothing (fromIntegral $11)
 246                                 (ConstrInfo (fromIntegral $5, fromIntegral $7) (fromIntegral $9) desc_lit)) }
 247
 248         | 'INFO_TABLE_SELECTOR' '(' NAME ',' INT ',' INT ',' STRING ',' STRING ')'
 249                 -- selector, closure type, description, type
 250                 { do prof <- profilingInfo $9 $11
 251                      return (mkRtsInfoLabelFS $3,
 252                         CmmInfo prof Nothing (fromIntegral $7)
 253                                 (ThunkSelectorInfo (fromIntegral $5) NoC_SRT)) }
 254
 255         | 'INFO_TABLE_RET' '(' NAME ',' INT ')'
 256                 -- closure type (no live regs)
 257                 { return (mkRtsInfoLabelFS $3,
 258                         CmmInfo (ProfilingInfo zeroCLit zeroCLit) Nothing (fromIntegral $5)
 259                                 (ContInfo [] NoC_SRT)) }
 260
 261         | 'INFO_TABLE_RET' '(' NAME ',' INT ',' formals ')'
 262                 -- closure type, live regs
 263                 { do live <- sequence (map (liftM Just) $7)
 264                      return (mkRtsInfoLabelFS $3,
 265                         CmmInfo (ProfilingInfo zeroCLit zeroCLit) Nothing (fromIntegral $5)
 266                         (ContInfo live NoC_SRT)) }
 267
 268 body    :: { ExtCode }
 269         : {- empty -}                   { return () }
 270         | decl body                     { do $1; $2 }
 271         | stmt body                     { do $1; $2 }
 272
 273 decl    :: { ExtCode }
 274         : type names ';'                { mapM_ (newLocal defaultKind $1) $2 }
 275         | STRING type names ';'         {% do k <- parseKind $1;
 276                                               return $ mapM_ (newLocal k $2) $3 }
 277
 278         | 'import' names ';'            { return () }  -- ignore imports
 279         | 'export' names ';'            { return () }  -- ignore exports
 280
 281 names   :: { [FastString] }
 282         : NAME                  { [$1] }
 283         | NAME ',' names        { $1 : $3 }
 284
 285 stmt    :: { ExtCode }
 286         : ';'                                   { nopEC }
 287
 288         | NAME ':'
 289                 { do l <- newLabel $1; code (labelC l) }
 290
 291         | lreg '=' expr ';'
 292                 { do reg <- $1; e <- $3; stmtEC (CmmAssign reg e) }
 293         | type '[' expr ']' '=' expr ';'
 294                 { doStore $1 $3 $6 }
 295
 296         -- Gah! We really want to say "maybe_results" but that causes
 297         -- a shift/reduce conflict with assignment.  We either
 298         -- we expand out the no-result and single result cases or
 299         -- we tweak the syntax to avoid the conflict.  The later
 300         -- option is taken here because the other way would require
 301         -- multiple levels of expanding and get unwieldy.
 302         | maybe_results 'foreign' STRING expr '(' hint_exprs0 ')' vols ';'
 303                 {% foreignCall $3 $1 $4 $6 $8 NoC_SRT }
 304         | maybe_results 'prim' '%' NAME '(' hint_exprs0 ')' vols ';'
 305                 {% primCall $1 $4 $6 $8 NoC_SRT }
 306         -- stmt-level macros, stealing syntax from ordinary C-- function calls.
 307         -- Perhaps we ought to use the %%-form?
 308         | NAME '(' exprs0 ')' ';'
 309                 {% stmtMacro $1 $3  }
 310         | 'switch' maybe_range expr '{' arms default '}'
 311                 { doSwitch $2 $3 $5 $6 }
 312         | 'goto' NAME ';'
 313                 { do l <- lookupLabel $2; stmtEC (CmmBranch l) }
 314         | 'jump' expr maybe_actuals ';'
 315                 { do e1 <- $2; e2 <- sequence $3; stmtEC (CmmJump e1 e2) }
 316         | 'return' maybe_actuals ';'
 317                 { do e <- sequence $2; stmtEC (CmmReturn e) }
 318         | 'if' bool_expr '{' body '}' else
 319                 { ifThenElse $2 $4 $6 }
 320
 321 bool_expr :: { ExtFCode BoolExpr }
 322         : bool_op                       { $1 }
 323         | expr                          { do e <- $1; return (BoolTest e) }
 324
 325 bool_op :: { ExtFCode BoolExpr }
 326         : bool_expr '&&' bool_expr      { do e1 <- $1; e2 <- $3;
 327                                           return (BoolAnd e1 e2) }
 328         | bool_expr '||' bool_expr      { do e1 <- $1; e2 <- $3;
 329                                           return (BoolOr e1 e2)  }
 330         | '!' bool_expr                 { do e <- $2; return (BoolNot e) }
 331         | '(' bool_op ')'               { $2 }
 332
 333 -- This is not C-- syntax.  What to do?
 334 vols    :: { Maybe [GlobalReg] }
 335         : {- empty -}                   { Nothing }
 336         | '[' ']'                       { Just [] }
 337         | '[' globals ']'               { Just $2 }
 338
 339 globals :: { [GlobalReg] }
 340         : GLOBALREG                     { [$1] }
 341         | GLOBALREG ',' globals         { $1 : $3 }
 342
 343 maybe_range :: { Maybe (Int,Int) }
 344         : '[' INT '..' INT ']'  { Just (fromIntegral $2, fromIntegral $4) }
 345         | {- empty -}           { Nothing }
 346
 347 arms    :: { [([Int],ExtCode)] }
 348         : {- empty -}                   { [] }
 349         | arm arms                      { $1 : $2 }
 350
 351 arm     :: { ([Int],ExtCode) }
 352         : 'case' ints ':' '{' body '}'  { ($2, $5) }
 353
 354 ints    :: { [Int] }
 355         : INT                           { [ fromIntegral $1 ] }
 356         | INT ',' ints                  { fromIntegral $1 : $3 }
 357
 358 default :: { Maybe ExtCode }
 359         : 'default' ':' '{' body '}'    { Just $4 }
 360         -- taking a few liberties with the C-- syntax here; C-- doesn't have
 361         -- 'default' branches
 362         | {- empty -}                   { Nothing }
 363
 364 else    :: { ExtCode }
 365         : {- empty -}                   { nopEC }
 366         | 'else' '{' body '}'           { $3 }
 367
 368 -- we have to write this out longhand so that Happy's precedence rules
 369 -- can kick in.
 370 expr    :: { ExtFCode CmmExpr }
 371         : expr '/' expr                 { mkMachOp MO_U_Quot [$1,$3] }
 372         | expr '*' expr                 { mkMachOp MO_Mul [$1,$3] }
 373         | expr '%' expr                 { mkMachOp MO_U_Rem [$1,$3] }
 374         | expr '-' expr                 { mkMachOp MO_Sub [$1,$3] }
 375         | expr '+' expr                 { mkMachOp MO_Add [$1,$3] }
 376         | expr '>>' expr                { mkMachOp MO_U_Shr [$1,$3] }
 377         | expr '<<' expr                { mkMachOp MO_Shl [$1,$3] }
 378         | expr '&' expr                 { mkMachOp MO_And [$1,$3] }
 379         | expr '^' expr                 { mkMachOp MO_Xor [$1,$3] }
 380         | expr '|' expr                 { mkMachOp MO_Or [$1,$3] }
 381         | expr '>=' expr                { mkMachOp MO_U_Ge [$1,$3] }
 382         | expr '>' expr                 { mkMachOp MO_U_Gt [$1,$3] }
 383         | expr '<=' expr                { mkMachOp MO_U_Le [$1,$3] }
 384         | expr '<' expr                 { mkMachOp MO_U_Lt [$1,$3] }
 385         | expr '!=' expr                { mkMachOp MO_Ne [$1,$3] }
 386         | expr '==' expr                { mkMachOp MO_Eq [$1,$3] }
 387         | '~' expr                      { mkMachOp MO_Not [$2] }
 388         | '-' expr                      { mkMachOp MO_S_Neg [$2] }
 389         | expr0 '`' NAME '`' expr0      {% do { mo <- nameToMachOp $3 ;
 390                                                 return (mkMachOp mo [$1,$5]) } }
 391         | expr0                         { $1 }
 392
 393 expr0   :: { ExtFCode CmmExpr }
 394         : INT   maybe_ty         { return (CmmLit (CmmInt $1 $2)) }
 395         | FLOAT maybe_ty         { return (CmmLit (CmmFloat $1 $2)) }
 396         | STRING                 { do s <- code (mkStringCLit $1);
 397                                       return (CmmLit s) }
 398         | reg                    { $1 }
 399         | type '[' expr ']'      { do e <- $3; return (CmmLoad e $1) }
 400         | '%' NAME '(' exprs0 ')' {% exprOp $2 $4 }
 401         | '(' expr ')'           { $2 }
 402
 403
 404 -- leaving out the type of a literal gives you the native word size in C--
 405 maybe_ty :: { MachRep }
 406         : {- empty -}                   { wordRep }
 407         | '::' type                     { $2 }
 408
 409 maybe_actuals :: { [ExtFCode (CmmExpr, MachHint)] }
 410         : {- empty -}           { [] }
 411         | '(' hint_exprs0 ')'   { $2 }
 412
 413 hint_exprs0 :: { [ExtFCode (CmmExpr, MachHint)] }
 414         : {- empty -}                   { [] }
 415         | hint_exprs                    { $1 }
 416
 417 hint_exprs :: { [ExtFCode (CmmExpr, MachHint)] }
 418         : hint_expr                     { [$1] }
 419         | hint_expr ',' hint_exprs      { $1 : $3 }
 420
 421 hint_expr :: { ExtFCode (CmmExpr, MachHint) }
 422         : expr                          { do e <- $1; return (e, inferHint e) }
 423         | expr STRING                   {% do h <- parseHint $2;
 424                                               return $ do
 425                                                 e <- $1; return (e,h) }
 426
 427 exprs0  :: { [ExtFCode CmmExpr] }
 428         : {- empty -}                   { [] }
 429         | exprs                         { $1 }
 430
 431 exprs   :: { [ExtFCode CmmExpr] }
 432         : expr                          { [ $1 ] }
 433         | expr ',' exprs                { $1 : $3 }
 434
 435 reg     :: { ExtFCode CmmExpr }
 436         : NAME                  { lookupName $1 }
 437         | GLOBALREG             { return (CmmReg (CmmGlobal $1)) }
 438
 439 maybe_results :: { [ExtFCode (CmmFormal, MachHint)] }
 440         : {- empty -}           { [] }
 441         | '(' hint_lregs ')' '='        { $2 }
 442
 443 hint_lregs :: { [ExtFCode (CmmFormal, MachHint)] }
 444         : hint_lreg                     { [$1] }
 445         | hint_lreg ','                 { [$1] }
 446         | hint_lreg ',' hint_lregs      { $1 : $3 }
 447
 448 hint_lreg :: { ExtFCode (CmmFormal, MachHint) }
 449         : local_lreg                    { do e <- $1; return (e, inferHint (CmmReg (CmmLocal e))) }
 450         | STRING local_lreg             {% do h <- parseHint $1;
 451                                               return $ do
 452                                                 e <- $2; return (e,h) }
 453
 454 local_lreg :: { ExtFCode LocalReg }
 455         : NAME                  { do e <- lookupName $1;
 456                                      return $
 457                                        case e of
 458                                         CmmReg (CmmLocal r) -> r
 459                                         other -> pprPanic "CmmParse:" (ftext $1 <> text " not a local register") }
 460
 461 lreg    :: { ExtFCode CmmReg }
 462         : NAME                  { do e <- lookupName $1;
 463                                      return $
 464                                        case e of
 465                                         CmmReg r -> r
 466                                         other -> pprPanic "CmmParse:" (ftext $1 <> text " not a register") }
 467         | GLOBALREG             { return (CmmGlobal $1) }
 468
 469 maybe_formals :: { [ExtFCode LocalReg] }
 470         : {- empty -}           { [] }
 471         | '(' formals0 ')'      { $2 }
 472
 473 formals0 :: { [ExtFCode LocalReg] }
 474         : {- empty -}           { [] }
 475         | formals               { $1 }
 476
 477 formals :: { [ExtFCode LocalReg] }
 478         : formal ','            { [$1] }
 479         | formal                { [$1] }
 480         | formal ',' formals    { $1 : $3 }
 481
 482 formal :: { ExtFCode LocalReg }
 483         : type NAME             { newLocal defaultKind $1 $2 }
 484         | STRING type NAME      {% do k <- parseKind $1;
 485                                      return $ newLocal k $2 $3 }
 486
 487 type    :: { MachRep }
 488         : 'bits8'               { I8 }
 489         | typenot8              { $1 }
 490
 491 typenot8 :: { MachRep }
 492         : 'bits16'              { I16 }
 493         | 'bits32'              { I32 }
 494         | 'bits64'              { I64 }
 495         | 'float32'             { F32 }
 496         | 'float64'             { F64 }
 497 {
 498 section :: String -> Section
 499 section "text"   = Text
 500 section "data"   = Data
 501 section "rodata" = ReadOnlyData
 502 section "relrodata" = RelocatableReadOnlyData
 503 section "bss"    = UninitialisedData
 504 section s        = OtherSection s
 505
 506 mkString :: String -> CmmStatic
 507 mkString s = CmmString (map (fromIntegral.ord) s)
 508
 509 -- mkMachOp infers the type of the MachOp from the type of its first
 510 -- argument.  We assume that this is correct: for MachOps that don't have
 511 -- symmetrical args (e.g. shift ops), the first arg determines the type of
 512 -- the op.
 513 mkMachOp :: (MachRep -> MachOp) -> [ExtFCode CmmExpr] -> ExtFCode CmmExpr
 514 mkMachOp fn args = do
 515   arg_exprs <- sequence args
 516   return (CmmMachOp (fn (cmmExprRep (head arg_exprs))) arg_exprs)
 517
 518 getLit :: CmmExpr -> CmmLit
 519 getLit (CmmLit l) = l
 520 getLit (CmmMachOp (MO_S_Neg _) [CmmLit (CmmInt i r)])  = CmmInt (negate i) r
 521 getLit _ = panic "invalid literal" -- TODO messy failure
 522
 523 nameToMachOp :: FastString -> P (MachRep -> MachOp)
 524 nameToMachOp name =
 525   case lookupUFM machOps name of
 526         Nothing -> fail ("unknown primitive " ++ unpackFS name)
 527         Just m  -> return m
 528
 529 exprOp :: FastString -> [ExtFCode CmmExpr] -> P (ExtFCode CmmExpr)
 530 exprOp name args_code =
 531   case lookupUFM exprMacros name of
 532      Just f  -> return $ do
 533         args <- sequence args_code
 534         return (f args)
 535      Nothing -> do
 536         mo <- nameToMachOp name
 537         return $ mkMachOp mo args_code
 538
 539 exprMacros :: UniqFM ([CmmExpr] -> CmmExpr)
 540 exprMacros = listToUFM [
 541   ( FSLIT("ENTRY_CODE"),   \ [x] -> entryCode x ),
 542   ( FSLIT("INFO_PTR"),     \ [x] -> closureInfoPtr x ),
 543   ( FSLIT("STD_INFO"),     \ [x] -> infoTable x ),
 544   ( FSLIT("FUN_INFO"),     \ [x] -> funInfoTable x ),
 545   ( FSLIT("GET_ENTRY"),    \ [x] -> entryCode (closureInfoPtr x) ),
 546   ( FSLIT("GET_STD_INFO"), \ [x] -> infoTable (closureInfoPtr x) ),
 547   ( FSLIT("GET_FUN_INFO"), \ [x] -> funInfoTable (closureInfoPtr x) ),
 548   ( FSLIT("INFO_TYPE"),    \ [x] -> infoTableClosureType x ),
 549   ( FSLIT("INFO_PTRS"),    \ [x] -> infoTablePtrs x ),
 550   ( FSLIT("INFO_NPTRS"),   \ [x] -> infoTableNonPtrs x )
 551   ]
 552
 553 -- we understand a subset of C-- primitives:
 554 machOps = listToUFM $
 555         map (\(x, y) -> (mkFastString x, y)) [
 556         ( "add",        MO_Add ),
 557         ( "sub",        MO_Sub ),
 558         ( "eq",         MO_Eq ),
 559         ( "ne",         MO_Ne ),
 560         ( "mul",        MO_Mul ),
 561         ( "neg",        MO_S_Neg ),
 562         ( "quot",       MO_S_Quot ),
 563         ( "rem",        MO_S_Rem ),
 564         ( "divu",       MO_U_Quot ),
 565         ( "modu",       MO_U_Rem ),
 566
 567         ( "ge",         MO_S_Ge ),
 568         ( "le",         MO_S_Le ),
 569         ( "gt",         MO_S_Gt ),
 570         ( "lt",         MO_S_Lt ),
 571
 572         ( "geu",        MO_U_Ge ),
 573         ( "leu",        MO_U_Le ),
 574         ( "gtu",        MO_U_Gt ),
 575         ( "ltu",        MO_U_Lt ),
 576
 577         ( "flt",        MO_S_Lt ),
 578         ( "fle",        MO_S_Le ),
 579         ( "feq",        MO_Eq ),
 580         ( "fne",        MO_Ne ),
 581         ( "fgt",        MO_S_Gt ),
 582         ( "fge",        MO_S_Ge ),
 583         ( "fneg",       MO_S_Neg ),
 584
 585         ( "and",        MO_And ),
 586         ( "or",         MO_Or ),
 587         ( "xor",        MO_Xor ),
 588         ( "com",        MO_Not ),
 589         ( "shl",        MO_Shl ),
 590         ( "shrl",       MO_U_Shr ),
 591         ( "shra",       MO_S_Shr ),
 592
 593         ( "lobits8",  flip MO_U_Conv I8  ),
 594         ( "lobits16", flip MO_U_Conv I16 ),
 595         ( "lobits32", flip MO_U_Conv I32 ),
 596         ( "lobits64", flip MO_U_Conv I64 ),
 597         ( "sx16",     flip MO_S_Conv I16 ),
 598         ( "sx32",     flip MO_S_Conv I32 ),
 599         ( "sx64",     flip MO_S_Conv I64 ),
 600         ( "zx16",     flip MO_U_Conv I16 ),
 601         ( "zx32",     flip MO_U_Conv I32 ),
 602         ( "zx64",     flip MO_U_Conv I64 ),
 603         ( "f2f32",    flip MO_S_Conv F32 ),  -- TODO; rounding mode
 604         ( "f2f64",    flip MO_S_Conv F64 ),  -- TODO; rounding mode
 605         ( "f2i8",     flip MO_S_Conv I8 ),
 606         ( "f2i16",    flip MO_S_Conv I16 ),
 607         ( "f2i32",    flip MO_S_Conv I32 ),
 608         ( "f2i64",    flip MO_S_Conv I64 ),
 609         ( "i2f32",    flip MO_S_Conv F32 ),
 610         ( "i2f64",    flip MO_S_Conv F64 )
 611         ]
 612
 613 callishMachOps = listToUFM $
 614         map (\(x, y) -> (mkFastString x, y)) [
 615         ( "write_barrier", MO_WriteBarrier )
 616         -- ToDo: the rest, maybe
 617     ]
 618
 619 parseHint :: String -> P MachHint
 620 parseHint "ptr"    = return PtrHint
 621 parseHint "signed" = return SignedHint
 622 parseHint "float"  = return FloatHint
 623 parseHint str      = fail ("unrecognised hint: " ++ str)
 624
 625 parseKind :: String -> P Kind
 626 parseKind "ptr"    = return KindPtr
 627 parseKind str      = fail ("unrecognized kin: " ++ str)
 628
 629 defaultKind :: Kind
 630 defaultKind = KindNonPtr
 631
 632 -- labels are always pointers, so we might as well infer the hint
 633 inferHint :: CmmExpr -> MachHint
 634 inferHint (CmmLit (CmmLabel _)) = PtrHint
 635 inferHint (CmmReg (CmmGlobal g)) | isPtrGlobalReg g = PtrHint
 636 inferHint _ = NoHint
 637
 638 isPtrGlobalReg Sp               = True
 639 isPtrGlobalReg SpLim            = True
 640 isPtrGlobalReg Hp               = True
 641 isPtrGlobalReg HpLim            = True
 642 isPtrGlobalReg CurrentTSO       = True
 643 isPtrGlobalReg CurrentNursery   = True
 644 isPtrGlobalReg _                = False
 645
 646 happyError :: P a
 647 happyError = srcParseFail
 648
 649 -- -----------------------------------------------------------------------------
 650 -- Statement-level macros
 651
 652 stmtMacro :: FastString -> [ExtFCode CmmExpr] -> P ExtCode
 653 stmtMacro fun args_code = do
 654   case lookupUFM stmtMacros fun of
 655     Nothing -> fail ("unknown macro: " ++ unpackFS fun)
 656     Just fcode -> return $ do
 657         args <- sequence args_code
 658         code (fcode args)
 659
 660 stmtMacros :: UniqFM ([CmmExpr] -> Code)
 661 stmtMacros = listToUFM [
 662   ( FSLIT("CCS_ALLOC"),            \[words,ccs]  -> profAlloc words ccs ),
 663   ( FSLIT("CLOSE_NURSERY"),        \[]  -> emitCloseNursery ),
 664   ( FSLIT("ENTER_CCS_PAP_CL"),     \[e] -> enterCostCentrePAP e ),
 665   ( FSLIT("ENTER_CCS_THUNK"),      \[e] -> enterCostCentreThunk e ),
 666   ( FSLIT("HP_CHK_GEN"),           \[words,liveness,reentry] ->
 667                                       hpChkGen words liveness reentry ),
 668   ( FSLIT("HP_CHK_NP_ASSIGN_SP0"), \[e,f] -> hpChkNodePointsAssignSp0 e f ),
 669   ( FSLIT("LOAD_THREAD_STATE"),    \[] -> emitLoadThreadState ),
 670   ( FSLIT("LDV_ENTER"),            \[e] -> ldvEnter e ),
 671   ( FSLIT("LDV_RECORD_CREATE"),    \[e] -> ldvRecordCreate e ),
 672   ( FSLIT("OPEN_NURSERY"),         \[]  -> emitOpenNursery ),
 673   ( FSLIT("PUSH_UPD_FRAME"),       \[sp,e] -> emitPushUpdateFrame sp e ),
 674   ( FSLIT("SAVE_THREAD_STATE"),    \[] -> emitSaveThreadState ),
 675   ( FSLIT("SET_HDR"),              \[ptr,info,ccs] ->
 676                                         emitSetDynHdr ptr info ccs ),
 677   ( FSLIT("STK_CHK_GEN"),          \[words,liveness,reentry] ->
 678                                       stkChkGen words liveness reentry ),
 679   ( FSLIT("STK_CHK_NP"),           \[e] -> stkChkNodePoints e ),
 680   ( FSLIT("TICK_ALLOC_PRIM"),      \[hdr,goods,slop] ->
 681                                         tickyAllocPrim hdr goods slop ),
 682   ( FSLIT("TICK_ALLOC_PAP"),       \[goods,slop] ->
 683                                         tickyAllocPAP goods slop ),
 684   ( FSLIT("TICK_ALLOC_UP_THK"),    \[goods,slop] ->
 685                                         tickyAllocThunk goods slop ),
 686   ( FSLIT("UPD_BH_UPDATABLE"),       \[] -> emitBlackHoleCode False ),
 687   ( FSLIT("UPD_BH_SINGLE_ENTRY"),    \[] -> emitBlackHoleCode True ),
 688
 689   ( FSLIT("RET_P"),     \[a] ->       emitRetUT [(PtrArg,a)]),
 690   ( FSLIT("RET_N"),     \[a] ->       emitRetUT [(NonPtrArg,a)]),
 691   ( FSLIT("RET_PP"),    \[a,b] ->     emitRetUT [(PtrArg,a),(PtrArg,b)]),
 692   ( FSLIT("RET_NN"),    \[a,b] ->     emitRetUT [(NonPtrArg,a),(NonPtrArg,b)]),
 693   ( FSLIT("RET_NP"),    \[a,b] ->     emitRetUT [(NonPtrArg,a),(PtrArg,b)]),
 694   ( FSLIT("RET_PPP"),   \[a,b,c] ->   emitRetUT [(PtrArg,a),(PtrArg,b),(PtrArg,c)]),
 695   ( FSLIT("RET_NPP"),   \[a,b,c] ->   emitRetUT [(NonPtrArg,a),(PtrArg,b),(PtrArg,c)]),
 696   ( FSLIT("RET_NNP"),   \[a,b,c] ->   emitRetUT [(NonPtrArg,a),(NonPtrArg,b),(PtrArg,c)]),
 697   ( FSLIT("RET_NNNP"),  \[a,b,c,d] -> emitRetUT [(NonPtrArg,a),(NonPtrArg,b),(NonPtrArg,c),(PtrArg,d)]),
 698   ( FSLIT("RET_NPNP"),  \[a,b,c,d] -> emitRetUT [(NonPtrArg,a),(PtrArg,b),(NonPtrArg,c),(PtrArg,d)])
 699
 700  ]
 701
 702 -- -----------------------------------------------------------------------------
 703 -- Our extended FCode monad.
 704
 705 -- We add a mapping from names to CmmExpr, to support local variable names in
 706 -- the concrete C-- code.  The unique supply of the underlying FCode monad
 707 -- is used to grab a new unique for each local variable.
 708
 709 -- In C--, a local variable can be declared anywhere within a proc,
 710 -- and it scopes from the beginning of the proc to the end.  Hence, we have
 711 -- to collect declarations as we parse the proc, and feed the environment
 712 -- back in circularly (to avoid a two-pass algorithm).
 713
 714 data Named = Var CmmExpr | Label BlockId
 715 type Decls = [(FastString,Named)]
 716 type Env   = UniqFM Named
 717
 718 newtype ExtFCode a = EC { unEC :: Env -> Decls -> FCode (Decls, a) }
 719
 720 type ExtCode = ExtFCode ()
 721
 722 returnExtFC a = EC $ \e s -> return (s, a)
 723 thenExtFC (EC m) k = EC $ \e s -> do (s',r) <- m e s; unEC (k r) e s'
 724
 725 instance Monad ExtFCode where
 726   (>>=) = thenExtFC
 727   return = returnExtFC
 728
 729 -- This function takes the variable decarations and imports and makes
 730 -- an environment, which is looped back into the computation.  In this
 731 -- way, we can have embedded declarations that scope over the whole
 732 -- procedure, and imports that scope over the entire module.
 733 loopDecls :: ExtFCode a -> ExtFCode a
 734 loopDecls (EC fcode) =
 735    EC $ \e s -> fixC (\ ~(decls,a) -> fcode (addListToUFM e decls) [])
 736
 737 getEnv :: ExtFCode Env
 738 getEnv = EC $ \e s -> return (s, e)
 739
 740 addVarDecl :: FastString -> CmmExpr -> ExtCode
 741 addVarDecl var expr = EC $ \e s -> return ((var, Var expr):s, ())
 742
 743 addLabel :: FastString -> BlockId -> ExtCode
 744 addLabel name block_id = EC $ \e s -> return ((name, Label block_id):s, ())
 745
 746 newLocal :: Kind -> MachRep -> FastString -> ExtFCode LocalReg
 747 newLocal kind ty name = do
 748    u <- code newUnique
 749    let reg = LocalReg u ty kind
 750    addVarDecl name (CmmReg (CmmLocal reg))
 751    return reg
 752
 753 newLabel :: FastString -> ExtFCode BlockId
 754 newLabel name = do
 755    u <- code newUnique
 756    addLabel name (BlockId u)
 757    return (BlockId u)
 758
 759 lookupLabel :: FastString -> ExtFCode BlockId
 760 lookupLabel name = do
 761   env <- getEnv
 762   return $
 763      case lookupUFM env name of
 764         Just (Label l) -> l
 765         _other -> BlockId (newTagUnique (getUnique name) 'L')
 766
 767 -- Unknown names are treated as if they had been 'import'ed.
 768 -- This saves us a lot of bother in the RTS sources, at the expense of
 769 -- deferring some errors to link time.
 770 lookupName :: FastString -> ExtFCode CmmExpr
 771 lookupName name = do
 772   env <- getEnv
 773   return $
 774      case lookupUFM env name of
 775         Just (Var e) -> e
 776         _other -> CmmLit (CmmLabel (mkRtsCodeLabelFS name))
 777
 778 -- Lifting FCode computations into the ExtFCode monad:
 779 code :: FCode a -> ExtFCode a
 780 code fc = EC $ \e s -> do r <- fc; return (s, r)
 781
 782 code2 :: (FCode (Decls,b) -> FCode ((Decls,b),c))
 783          -> ExtFCode b -> ExtFCode c
 784 code2 f (EC ec) = EC $ \e s -> do ((s',b),c) <- f (ec e s); return (s',c)
 785
 786 nopEC = code nopC
 787 stmtEC stmt = code (stmtC stmt)
 788 stmtsEC stmts = code (stmtsC stmts)
 789 getCgStmtsEC = code2 getCgStmts'
 790
 791 forkLabelledCodeEC ec = do
 792   stmts <- getCgStmtsEC ec
 793   code (forkCgStmts stmts)
 794
 795 retInfo name size live_bits cl_type = do
 796   let liveness = smallLiveness (fromIntegral size) (fromIntegral live_bits)
 797       info_lbl = mkRtsRetInfoLabelFS name
 798       (info1,info2) = mkRetInfoTable info_lbl liveness NoC_SRT
 799                                 (fromIntegral cl_type)
 800   return (info_lbl, info1, info2)
 801
 802 stdInfo name ptrs nptrs srt_bitmap cl_type desc_str ty_str =
 803   basicInfo name (packHalfWordsCLit ptrs nptrs)
 804         srt_bitmap cl_type desc_str ty_str
 805
 806 conInfo name ptrs nptrs srt_bitmap cl_type desc_str ty_str = do
 807   (lbl, info1, _) <- basicInfo name (packHalfWordsCLit ptrs nptrs)
 808                         srt_bitmap cl_type desc_str ty_str
 809   desc_lit <- code $ mkStringCLit desc_str
 810   let desc_field = makeRelativeRefTo lbl desc_lit
 811   return (lbl, info1, [desc_field])
 812
 813 basicInfo name layout srt_bitmap cl_type desc_str ty_str = do
 814   let info_lbl = mkRtsInfoLabelFS name
 815   lit1 <- if opt_SccProfilingOn
 816                    then code $ do lit <- mkStringCLit desc_str
 817                                   return (makeRelativeRefTo info_lbl lit)
 818                    else return (mkIntCLit 0)
 819   lit2 <- if opt_SccProfilingOn
 820                    then code $ do lit <- mkStringCLit ty_str
 821                                   return (makeRelativeRefTo info_lbl lit)
 822                    else return (mkIntCLit 0)
 823   let info1 = mkStdInfoTable lit1 lit2 (fromIntegral cl_type)
 824                         (fromIntegral srt_bitmap)
 825                         layout
 826   return (info_lbl, info1, [])
 827
 828 funInfo name ptrs nptrs cl_type desc_str ty_str fun_type = do
 829   (label,info1,_) <- stdInfo name ptrs nptrs 0{-srt_bitmap-}
 830                          cl_type desc_str ty_str
 831   let info2 = mkFunGenInfoExtraBits (fromIntegral fun_type) 0 zero zero zero
 832                 -- we leave most of the fields zero here.  This is only used
 833                 -- to generate the BCO info table in the RTS at the moment.
 834   return (label,info1,info2)
 835  where
 836    zero = mkIntCLit 0
 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         -> C_SRT
 860         -> P ExtCode
 861 foreignCall conv_string results_code expr_code args_code vols srt
 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 (emitForeignCall' PlayRisky results
 871                  (CmmForeignCall expr convention) args vols srt) where
 872
 873 primCall
 874         :: [ExtFCode (CmmFormal,MachHint)]
 875         -> FastString
 876         -> [ExtFCode (CmmExpr,MachHint)]
 877         -> Maybe [GlobalReg]
 878         -> C_SRT
 879         -> P ExtCode
 880 primCall results_code name args_code vols srt
 881   = case lookupUFM callishMachOps name of
 882         Nothing -> fail ("unknown primitive " ++ unpackFS name)
 883         Just p  -> return $ do
 884                 results <- sequence results_code
 885                 args <- sequence args_code
 886                 code (emitForeignCall' PlayRisky results (CmmPrim p) args vols srt)
 887
 888 doStore :: MachRep -> ExtFCode CmmExpr  -> ExtFCode CmmExpr -> ExtCode
 889 doStore rep addr_code val_code
 890   = do addr <- addr_code
 891        val <- val_code
 892         -- if the specified store type does not match the type of the expr
 893         -- on the rhs, then we insert a coercion that will cause the type
 894         -- mismatch to be flagged by cmm-lint.  If we don't do this, then
 895         -- the store will happen at the wrong type, and the error will not
 896         -- be noticed.
 897        let coerce_val
 898                 | cmmExprRep val /= rep = CmmMachOp (MO_U_Conv rep rep) [val]
 899                 | otherwise             = val
 900        stmtEC (CmmStore addr coerce_val)
 901
 902 -- Return an unboxed tuple.
 903 emitRetUT :: [(CgRep,CmmExpr)] -> Code
 904 emitRetUT args = do
 905   tickyUnboxedTupleReturn (length args)  -- TICK
 906   (sp, stmts) <- pushUnboxedTuple 0 args
 907   emitStmts stmts
 908   when (sp /= 0) $ stmtC (CmmAssign spReg (cmmRegOffW spReg (-sp)))
 909   stmtC (CmmJump (entryCode (CmmLoad (cmmRegOffW spReg sp) wordRep)) [])
 910
 911 -- -----------------------------------------------------------------------------
 912 -- If-then-else and boolean expressions
 913
 914 data BoolExpr
 915   = BoolExpr `BoolAnd` BoolExpr
 916   | BoolExpr `BoolOr`  BoolExpr
 917   | BoolNot BoolExpr
 918   | BoolTest CmmExpr
 919
 920 -- ToDo: smart constructors which simplify the boolean expression.
 921
 922 ifThenElse cond then_part else_part = do
 923      then_id <- code newLabelC
 924      join_id <- code newLabelC
 925      c <- cond
 926      emitCond c then_id
 927      else_part
 928      stmtEC (CmmBranch join_id)
 929      code (labelC then_id)
 930      then_part
 931      -- fall through to join
 932      code (labelC join_id)
 933
 934 -- 'emitCond cond true_id'  emits code to test whether the cond is true,
 935 -- branching to true_id if so, and falling through otherwise.
 936 emitCond (BoolTest e) then_id = do
 937   stmtEC (CmmCondBranch e then_id)
 938 emitCond (BoolNot (BoolTest (CmmMachOp op args))) then_id
 939   | Just op' <- maybeInvertComparison op
 940   = emitCond (BoolTest (CmmMachOp op' args)) then_id
 941 emitCond (BoolNot e) then_id = do
 942   else_id <- code newLabelC
 943   emitCond e else_id
 944   stmtEC (CmmBranch then_id)
 945   code (labelC else_id)
 946 emitCond (e1 `BoolOr` e2) then_id = do
 947   emitCond e1 then_id
 948   emitCond e2 then_id
 949 emitCond (e1 `BoolAnd` e2) then_id = do
 950         -- we'd like to invert one of the conditionals here to avoid an
 951         -- extra branch instruction, but we can't use maybeInvertComparison
 952         -- here because we can't look too closely at the expression since
 953         -- we're in a loop.
 954   and_id <- code newLabelC
 955   else_id <- code newLabelC
 956   emitCond e1 and_id
 957   stmtEC (CmmBranch else_id)
 958   code (labelC and_id)
 959   emitCond e2 then_id
 960   code (labelC else_id)
 961
 962
 963 -- -----------------------------------------------------------------------------
 964 -- Table jumps
 965
 966 -- We use a simplified form of C-- switch statements for now.  A
 967 -- switch statement always compiles to a table jump.  Each arm can
 968 -- specify a list of values (not ranges), and there can be a single
 969 -- default branch.  The range of the table is given either by the
 970 -- optional range on the switch (eg. switch [0..7] {...}), or by
 971 -- the minimum/maximum values from the branches.
 972
 973 doSwitch :: Maybe (Int,Int) -> ExtFCode CmmExpr -> [([Int],ExtCode)]
 974          -> Maybe ExtCode -> ExtCode
 975 doSwitch mb_range scrut arms deflt
 976    = do
 977         -- Compile code for the default branch
 978         dflt_entry <-
 979                 case deflt of
 980                   Nothing -> return Nothing
 981                   Just e  -> do b <- forkLabelledCodeEC e; return (Just b)
 982
 983         -- Compile each case branch
 984         table_entries <- mapM emitArm arms
 985
 986         -- Construct the table
 987         let
 988             all_entries = concat table_entries
 989             ixs = map fst all_entries
 990             (min,max)
 991                 | Just (l,u) <- mb_range = (l,u)
 992                 | otherwise              = (minimum ixs, maximum ixs)
 993
 994             entries = elems (accumArray (\_ a -> Just a) dflt_entry (min,max)
 995                                 all_entries)
 996         expr <- scrut
 997         -- ToDo: check for out of range and jump to default if necessary
 998         stmtEC (CmmSwitch expr entries)
 999    where
1000         emitArm :: ([Int],ExtCode) -> ExtFCode [(Int,BlockId)]
1001         emitArm (ints,code) = do
1002            blockid <- forkLabelledCodeEC code
1003            return [ (i,blockid) | i <- ints ]
1004
1005
1006 -- -----------------------------------------------------------------------------
1007 -- Putting it all together
1008
1009 -- The initial environment: we define some constants that the compiler
1010 -- knows about here.
1011 initEnv :: Env
1012 initEnv = listToUFM [
1013   ( FSLIT("SIZEOF_StgHeader"),
1014     Var (CmmLit (CmmInt (fromIntegral (fixedHdrSize * wORD_SIZE)) wordRep) )),
1015   ( FSLIT("SIZEOF_StgInfoTable"),
1016     Var (CmmLit (CmmInt (fromIntegral stdInfoTableSizeB) wordRep) ))
1017   ]
1018
1019 parseCmmFile :: DynFlags -> FilePath -> IO (Maybe Cmm)
1020 parseCmmFile dflags filename = do
1021   showPass dflags "ParseCmm"
1022   buf <- hGetStringBuffer filename
1023   let
1024         init_loc = mkSrcLoc (mkFastString filename) 1 0
1025         init_state = (mkPState buf init_loc dflags) { lex_state = [0] }
1026                 -- reset the lex_state: the Lexer monad leaves some stuff
1027                 -- in there we don't want.
1028   case unP cmmParse init_state of
1029     PFailed span err -> do printError span err; return Nothing
1030     POk pst code -> do
1031         cmm <- initC dflags no_module (getCmm (unEC code initEnv [] >> return ()))
1032         let ms = getMessages pst
1033         printErrorsAndWarnings dflags ms
1034         when (errorsFound dflags ms) $ exitWith (ExitFailure 1)
1035         dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (pprCmms [cmm])
1036         return (Just cmm)
1037   where
1038         no_module = panic "parseCmmFile: no module"
1039 }