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