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