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