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