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