compiler/cmm/CmmParse.y

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