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