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