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