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