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