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 -Wwarn -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 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 import BasicTypes
  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 %expect 0
  67
  68 %token
  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         ','     { L _ (CmmT_SpecChar ',') }
  91         '!'     { L _ (CmmT_SpecChar '!') }
  92
  93         '..'    { L _ (CmmT_DotDot) }
  94         '::'    { L _ (CmmT_DoubleColon) }
  95         '>>'    { L _ (CmmT_Shr) }
  96         '<<'    { L _ (CmmT_Shl) }
  97         '>='    { L _ (CmmT_Ge) }
  98         '<='    { L _ (CmmT_Le) }
  99         '=='    { L _ (CmmT_Eq) }
 100         '!='    { L _ (CmmT_Ne) }
 101         '&&'    { L _ (CmmT_BoolAnd) }
 102         '||'    { L _ (CmmT_BoolOr) }
 103
 104         'CLOSURE'       { L _ (CmmT_CLOSURE) }
 105         'INFO_TABLE'    { L _ (CmmT_INFO_TABLE) }
 106         'INFO_TABLE_RET'{ L _ (CmmT_INFO_TABLE_RET) }
 107         'INFO_TABLE_FUN'{ L _ (CmmT_INFO_TABLE_FUN) }
 108         'INFO_TABLE_CONSTR'{ L _ (CmmT_INFO_TABLE_CONSTR) }
 109         'INFO_TABLE_SELECTOR'{ L _ (CmmT_INFO_TABLE_SELECTOR) }
 110         'else'          { L _ (CmmT_else) }
 111         'export'        { L _ (CmmT_export) }
 112         'section'       { L _ (CmmT_section) }
 113         'align'         { L _ (CmmT_align) }
 114         'goto'          { L _ (CmmT_goto) }
 115         'if'            { L _ (CmmT_if) }
 116         'jump'          { L _ (CmmT_jump) }
 117         'foreign'       { L _ (CmmT_foreign) }
 118         'never'         { L _ (CmmT_never) }
 119         'prim'          { L _ (CmmT_prim) }
 120         'return'        { L _ (CmmT_return) }
 121         'returns'       { L _ (CmmT_returns) }
 122         'import'        { L _ (CmmT_import) }
 123         'switch'        { L _ (CmmT_switch) }
 124         'case'          { L _ (CmmT_case) }
 125         'default'       { L _ (CmmT_default) }
 126         'bits8'         { L _ (CmmT_bits8) }
 127         'bits16'        { L _ (CmmT_bits16) }
 128         'bits32'        { L _ (CmmT_bits32) }
 129         'bits64'        { L _ (CmmT_bits64) }
 130         'float32'       { L _ (CmmT_float32) }
 131         'float64'       { L _ (CmmT_float64) }
 132         'gcptr'         { L _ (CmmT_gcptr) }
 133
 134         GLOBALREG       { L _ (CmmT_GlobalReg   $$) }
 135         NAME            { L _ (CmmT_Name        $$) }
 136         STRING          { L _ (CmmT_String      $$) }
 137         INT             { L _ (CmmT_Int         $$) }
 138         FLOAT           { L _ (CmmT_Float       $$) }
 139
 140 %monad { P } { >>= } { return }
 141 %lexer { cmmlex } { L _ CmmT_EOF }
 142 %name cmmParse cmm
 143 %tokentype { Located CmmToken }
 144
 145 -- C-- operator precedences, taken from the C-- spec
 146 %right '||'     -- non-std extension, called %disjoin in C--
 147 %right '&&'     -- non-std extension, called %conjoin in C--
 148 %right '!'
 149 %nonassoc '>=' '>' '<=' '<' '!=' '=='
 150 %left '|'
 151 %left '^'
 152 %left '&'
 153 %left '>>' '<<'
 154 %left '-' '+'
 155 %left '/' '*' '%'
 156 %right '~'
 157
 158 %%
 159
 160 cmm     :: { ExtCode }
 161         : {- empty -}                   { return () }
 162         | cmmtop cmm                    { do $1; $2 }
 163
 164 cmmtop  :: { ExtCode }
 165         : cmmproc                       { $1 }
 166         | cmmdata                       { $1 }
 167         | decl                          { $1 }
 168         | 'CLOSURE' '(' NAME ',' NAME lits ')' ';'
 169                 { do lits <- sequence $6;
 170                      staticClosure $3 $5 (map getLit lits) }
 171
 172 -- The only static closures in the RTS are dummy closures like
 173 -- stg_END_TSO_QUEUE_closure and stg_dummy_ret.  We don't need
 174 -- to provide the full generality of static closures here.
 175 -- In particular:
 176 --      * CCS can always be CCS_DONT_CARE
 177 --      * closure is always extern
 178 --      * payload is always empty
 179 --      * we can derive closure and info table labels from a single NAME
 180
 181 cmmdata :: { ExtCode }
 182         : 'section' STRING '{' statics '}'
 183                 { do ss <- sequence $4;
 184                      code (emitData (section $2) (concat ss)) }
 185
 186 statics :: { [ExtFCode [CmmStatic]] }
 187         : {- empty -}                   { [] }
 188         | static statics                { $1 : $2 }
 189
 190 -- Strings aren't used much in the RTS HC code, so it doesn't seem
 191 -- worth allowing inline strings.  C-- doesn't allow them anyway.
 192 static  :: { ExtFCode [CmmStatic] }
 193         : NAME ':'      { return [CmmDataLabel (mkRtsDataLabel $1)] }
 194         | type expr ';' { do e <- $2;
 195                              return [CmmStaticLit (getLit e)] }
 196         | type ';'                      { return [CmmUninitialised
 197                                                         (widthInBytes (typeWidth $1))] }
 198         | 'bits8' '[' ']' STRING ';'    { return [mkString $4] }
 199         | 'bits8' '[' INT ']' ';'       { return [CmmUninitialised
 200                                                         (fromIntegral $3)] }
 201         | typenot8 '[' INT ']' ';'      { return [CmmUninitialised
 202                                                 (widthInBytes (typeWidth $1) *
 203                                                         fromIntegral $3)] }
 204         | 'align' INT ';'               { return [CmmAlign (fromIntegral $2)] }
 205         | 'CLOSURE' '(' NAME lits ')'
 206                 { do lits <- sequence $4;
 207                      return $ map CmmStaticLit $
 208                        mkStaticClosure (mkForeignLabel $3 Nothing True IsData)
 209                          -- mkForeignLabel because these are only used
 210                          -- for CHARLIKE and INTLIKE closures in the RTS.
 211                          dontCareCCS (map getLit lits) [] [] [] }
 212         -- arrays of closures required for the CHARLIKE & INTLIKE arrays
 213
 214 lits    :: { [ExtFCode CmmExpr] }
 215         : {- empty -}           { [] }
 216         | ',' expr lits         { $2 : $3 }
 217
 218 cmmproc :: { ExtCode }
 219 -- TODO: add real SRT/info tables to parsed Cmm
 220         : info maybe_formals_without_hints maybe_gc_block maybe_frame '{' body '}'
 221                 { do ((entry_ret_label, info, live, formals, gc_block, frame), stmts) <-
 222                        getCgStmtsEC' $ loopDecls $ do {
 223                          (entry_ret_label, info, live) <- $1;
 224                          formals <- sequence $2;
 225                          gc_block <- $3;
 226                          frame <- $4;
 227                          $6;
 228                          return (entry_ret_label, info, live, formals, gc_block, frame) }
 229                      blks <- code (cgStmtsToBlocks stmts)
 230                      code (emitInfoTableAndCode entry_ret_label (CmmInfo gc_block frame info) formals blks) }
 231
 232         | info maybe_formals_without_hints ';'
 233                 { do (entry_ret_label, info, live) <- $1;
 234                      formals <- sequence $2;
 235                      code (emitInfoTableAndCode entry_ret_label (CmmInfo Nothing Nothing info) formals []) }
 236
 237         | NAME maybe_formals_without_hints maybe_gc_block maybe_frame '{' body '}'
 238                 { do ((formals, gc_block, frame), stmts) <-
 239                         getCgStmtsEC' $ loopDecls $ do {
 240                           formals <- sequence $2;
 241                           gc_block <- $3;
 242                           frame <- $4;
 243                           $6;
 244                           return (formals, gc_block, frame) }
 245                      blks <- code (cgStmtsToBlocks stmts)
 246                      code (emitProc (CmmInfo gc_block frame CmmNonInfoTable) (mkRtsCodeLabel $1) formals blks) }
 247
 248 info    :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) }
 249         : 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
 250                 -- ptrs, nptrs, closure type, description, type
 251                 { do prof <- profilingInfo $11 $13
 252                      return (mkRtsEntryLabel $3,
 253                         CmmInfoTable False prof (fromIntegral $9)
 254                                      (ThunkInfo (fromIntegral $5, fromIntegral $7) NoC_SRT),
 255                         []) }
 256
 257         | 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ')'
 258                 -- ptrs, nptrs, closure type, description, type, fun type
 259                 { do prof <- profilingInfo $11 $13
 260                      return (mkRtsEntryLabel $3,
 261                         CmmInfoTable False prof (fromIntegral $9)
 262                                      (FunInfo (fromIntegral $5, fromIntegral $7) NoC_SRT
 263                                       0  -- Arity zero
 264                                       (ArgSpec (fromIntegral $15))
 265                                       zeroCLit),
 266                         []) }
 267                 -- we leave most of the fields zero here.  This is only used
 268                 -- to generate the BCO info table in the RTS at the moment.
 269
 270         -- A variant with a non-zero arity (needed to write Main_main in Cmm)
 271         | 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ',' INT ')'
 272                 -- ptrs, nptrs, closure type, description, type, fun type, arity
 273                 { do prof <- profilingInfo $11 $13
 274                      return (mkRtsEntryLabel $3,
 275                         CmmInfoTable False prof (fromIntegral $9)
 276                                      (FunInfo (fromIntegral $5, fromIntegral $7) NoC_SRT (fromIntegral $17)
 277                                       (ArgSpec (fromIntegral $15))
 278                                       zeroCLit),
 279                         []) }
 280                 -- we leave most of the fields zero here.  This is only used
 281                 -- to generate the BCO info table in the RTS at the moment.
 282
 283         | 'INFO_TABLE_CONSTR' '(' NAME ',' INT ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
 284                 -- ptrs, nptrs, tag, closure type, description, type
 285                 { do prof <- profilingInfo $13 $15
 286                      -- If profiling is on, this string gets duplicated,
 287                      -- but that's the way the old code did it we can fix it some other time.
 288                      desc_lit <- code $ mkStringCLit $13
 289                      return (mkRtsEntryLabel $3,
 290                         CmmInfoTable False prof (fromIntegral $11)
 291                                      (ConstrInfo (fromIntegral $5, fromIntegral $7) (fromIntegral $9) desc_lit),
 292                         []) }
 293
 294         | 'INFO_TABLE_SELECTOR' '(' NAME ',' INT ',' INT ',' STRING ',' STRING ')'
 295                 -- selector, closure type, description, type
 296                 { do prof <- profilingInfo $9 $11
 297                      return (mkRtsEntryLabel $3,
 298                         CmmInfoTable False prof (fromIntegral $7)
 299                                      (ThunkSelectorInfo (fromIntegral $5) NoC_SRT),
 300                         []) }
 301
 302         | 'INFO_TABLE_RET' '(' NAME ',' INT ')'
 303                 -- closure type (no live regs)
 304                 { do let infoLabel = mkRtsInfoLabel $3
 305                      return (mkRtsRetLabel $3,
 306                         CmmInfoTable False (ProfilingInfo zeroCLit zeroCLit) (fromIntegral $5)
 307                                      (ContInfo [] NoC_SRT),
 308                         []) }
 309
 310         | 'INFO_TABLE_RET' '(' NAME ',' INT ',' formals_without_hints0 ')'
 311                 -- closure type, live regs
 312                 { do live <- sequence (map (liftM Just) $7)
 313                      return (mkRtsRetLabel $3,
 314                         CmmInfoTable False (ProfilingInfo zeroCLit zeroCLit) (fromIntegral $5)
 315                                      (ContInfo live NoC_SRT),
 316                         live) }
 317
 318 body    :: { ExtCode }
 319         : {- empty -}                   { return () }
 320         | decl body                     { do $1; $2 }
 321         | stmt body                     { do $1; $2 }
 322
 323 decl    :: { ExtCode }
 324         : type names ';'                { mapM_ (newLocal $1) $2 }
 325         | 'import' names ';'            { mapM_ newImport $2 }
 326         | 'export' names ';'            { return () }  -- ignore exports
 327
 328 names   :: { [FastString] }
 329         : NAME                  { [$1] }
 330         | NAME ',' names        { $1 : $3 }
 331
 332 stmt    :: { ExtCode }
 333         : ';'                                   { nopEC }
 334
 335         | NAME ':'
 336                 { do l <- newLabel $1; code (labelC l) }
 337
 338         | lreg '=' expr ';'
 339                 { do reg <- $1; e <- $3; stmtEC (CmmAssign reg e) }
 340         | type '[' expr ']' '=' expr ';'
 341                 { doStore $1 $3 $6 }
 342
 343         -- Gah! We really want to say "maybe_results" but that causes
 344         -- a shift/reduce conflict with assignment.  We either
 345         -- we expand out the no-result and single result cases or
 346         -- we tweak the syntax to avoid the conflict.  The later
 347         -- option is taken here because the other way would require
 348         -- multiple levels of expanding and get unwieldy.
 349         | maybe_results 'foreign' STRING expr '(' cmm_hint_exprs0 ')' safety vols opt_never_returns ';'
 350                 {% foreignCall $3 $1 $4 $6 $9 $8 $10 }
 351         | maybe_results 'prim' '%' NAME '(' cmm_hint_exprs0 ')' safety vols ';'
 352                 {% primCall $1 $4 $6 $9 $8 }
 353         -- stmt-level macros, stealing syntax from ordinary C-- function calls.
 354         -- Perhaps we ought to use the %%-form?
 355         | NAME '(' exprs0 ')' ';'
 356                 {% stmtMacro $1 $3  }
 357         | 'switch' maybe_range expr '{' arms default '}'
 358                 { doSwitch $2 $3 $5 $6 }
 359         | 'goto' NAME ';'
 360                 { do l <- lookupLabel $2; stmtEC (CmmBranch l) }
 361         | 'jump' expr maybe_actuals ';'
 362                 { do e1 <- $2; e2 <- sequence $3; stmtEC (CmmJump e1 e2) }
 363         | 'return' maybe_actuals ';'
 364                 { do e <- sequence $2; stmtEC (CmmReturn e) }
 365         | 'if' bool_expr '{' body '}' else
 366                 { ifThenElse $2 $4 $6 }
 367
 368 opt_never_returns :: { CmmReturnInfo }
 369         :                               { CmmMayReturn }
 370         | 'never' 'returns'             { CmmNeverReturns }
 371
 372 bool_expr :: { ExtFCode BoolExpr }
 373         : bool_op                       { $1 }
 374         | expr                          { do e <- $1; return (BoolTest e) }
 375
 376 bool_op :: { ExtFCode BoolExpr }
 377         : bool_expr '&&' bool_expr      { do e1 <- $1; e2 <- $3;
 378                                           return (BoolAnd e1 e2) }
 379         | bool_expr '||' bool_expr      { do e1 <- $1; e2 <- $3;
 380                                           return (BoolOr e1 e2)  }
 381         | '!' bool_expr                 { do e <- $2; return (BoolNot e) }
 382         | '(' bool_op ')'               { $2 }
 383
 384 -- This is not C-- syntax.  What to do?
 385 safety  :: { CmmSafety }
 386         : {- empty -}                   { CmmUnsafe } -- Default may change soon
 387         | STRING                        {% parseSafety $1 }
 388
 389 -- This is not C-- syntax.  What to do?
 390 vols    :: { Maybe [GlobalReg] }
 391         : {- empty -}                   { Nothing }
 392         | '[' ']'                       { Just [] }
 393         | '[' globals ']'               { Just $2 }
 394
 395 globals :: { [GlobalReg] }
 396         : GLOBALREG                     { [$1] }
 397         | GLOBALREG ',' globals         { $1 : $3 }
 398
 399 maybe_range :: { Maybe (Int,Int) }
 400         : '[' INT '..' INT ']'  { Just (fromIntegral $2, fromIntegral $4) }
 401         | {- empty -}           { Nothing }
 402
 403 arms    :: { [([Int],ExtCode)] }
 404         : {- empty -}                   { [] }
 405         | arm arms                      { $1 : $2 }
 406
 407 arm     :: { ([Int],ExtCode) }
 408         : 'case' ints ':' '{' body '}'  { ($2, $5) }
 409
 410 ints    :: { [Int] }
 411         : INT                           { [ fromIntegral $1 ] }
 412         | INT ',' ints                  { fromIntegral $1 : $3 }
 413
 414 default :: { Maybe ExtCode }
 415         : 'default' ':' '{' body '}'    { Just $4 }
 416         -- taking a few liberties with the C-- syntax here; C-- doesn't have
 417         -- 'default' branches
 418         | {- empty -}                   { Nothing }
 419
 420 else    :: { ExtCode }
 421         : {- empty -}                   { nopEC }
 422         | 'else' '{' body '}'           { $3 }
 423
 424 -- we have to write this out longhand so that Happy's precedence rules
 425 -- can kick in.
 426 expr    :: { ExtFCode CmmExpr }
 427         : expr '/' expr                 { mkMachOp MO_U_Quot [$1,$3] }
 428         | expr '*' expr                 { mkMachOp MO_Mul [$1,$3] }
 429         | expr '%' expr                 { mkMachOp MO_U_Rem [$1,$3] }
 430         | expr '-' expr                 { mkMachOp MO_Sub [$1,$3] }
 431         | expr '+' expr                 { mkMachOp MO_Add [$1,$3] }
 432         | expr '>>' expr                { mkMachOp MO_U_Shr [$1,$3] }
 433         | expr '<<' expr                { mkMachOp MO_Shl [$1,$3] }
 434         | expr '&' expr                 { mkMachOp MO_And [$1,$3] }
 435         | expr '^' expr                 { mkMachOp MO_Xor [$1,$3] }
 436         | expr '|' expr                 { mkMachOp MO_Or [$1,$3] }
 437         | expr '>=' expr                { mkMachOp MO_U_Ge [$1,$3] }
 438         | expr '>' expr                 { mkMachOp MO_U_Gt [$1,$3] }
 439         | expr '<=' expr                { mkMachOp MO_U_Le [$1,$3] }
 440         | expr '<' expr                 { mkMachOp MO_U_Lt [$1,$3] }
 441         | expr '!=' expr                { mkMachOp MO_Ne [$1,$3] }
 442         | expr '==' expr                { mkMachOp MO_Eq [$1,$3] }
 443         | '~' expr                      { mkMachOp MO_Not [$2] }
 444         | '-' expr                      { mkMachOp MO_S_Neg [$2] }
 445         | expr0 '`' NAME '`' expr0      {% do { mo <- nameToMachOp $3 ;
 446                                                 return (mkMachOp mo [$1,$5]) } }
 447         | expr0                         { $1 }
 448
 449 expr0   :: { ExtFCode CmmExpr }
 450         : INT   maybe_ty         { return (CmmLit (CmmInt $1 (typeWidth $2))) }
 451         | FLOAT maybe_ty         { return (CmmLit (CmmFloat $1 (typeWidth $2))) }
 452         | STRING                 { do s <- code (mkStringCLit $1);
 453                                       return (CmmLit s) }
 454         | reg                    { $1 }
 455         | type '[' expr ']'      { do e <- $3; return (CmmLoad e $1) }
 456         | '%' NAME '(' exprs0 ')' {% exprOp $2 $4 }
 457         | '(' expr ')'           { $2 }
 458
 459
 460 -- leaving out the type of a literal gives you the native word size in C--
 461 maybe_ty :: { CmmType }
 462         : {- empty -}                   { bWord }
 463         | '::' type                     { $2 }
 464
 465 maybe_actuals :: { [ExtFCode HintedCmmActual] }
 466         : {- empty -}           { [] }
 467         | '(' cmm_hint_exprs0 ')'       { $2 }
 468
 469 cmm_hint_exprs0 :: { [ExtFCode HintedCmmActual] }
 470         : {- empty -}                   { [] }
 471         | cmm_hint_exprs                        { $1 }
 472
 473 cmm_hint_exprs :: { [ExtFCode HintedCmmActual] }
 474         : cmm_hint_expr                 { [$1] }
 475         | cmm_hint_expr ',' cmm_hint_exprs      { $1 : $3 }
 476
 477 cmm_hint_expr :: { ExtFCode HintedCmmActual }
 478         : expr                          { do e <- $1; return (CmmHinted e (inferCmmHint e)) }
 479         | expr STRING                   {% do h <- parseCmmHint $2;
 480                                               return $ do
 481                                                 e <- $1; return (CmmHinted e h) }
 482
 483 exprs0  :: { [ExtFCode CmmExpr] }
 484         : {- empty -}                   { [] }
 485         | exprs                         { $1 }
 486
 487 exprs   :: { [ExtFCode CmmExpr] }
 488         : expr                          { [ $1 ] }
 489         | expr ',' exprs                { $1 : $3 }
 490
 491 reg     :: { ExtFCode CmmExpr }
 492         : NAME                  { lookupName $1 }
 493         | GLOBALREG             { return (CmmReg (CmmGlobal $1)) }
 494
 495 maybe_results :: { [ExtFCode HintedCmmFormal] }
 496         : {- empty -}           { [] }
 497         | '(' cmm_formals ')' '='       { $2 }
 498
 499 cmm_formals :: { [ExtFCode HintedCmmFormal] }
 500         : cmm_formal                    { [$1] }
 501         | cmm_formal ','                        { [$1] }
 502         | cmm_formal ',' cmm_formals    { $1 : $3 }
 503
 504 cmm_formal :: { ExtFCode HintedCmmFormal }
 505         : local_lreg                    { do e <- $1; return (CmmHinted e (inferCmmHint (CmmReg (CmmLocal e)))) }
 506         | STRING local_lreg             {% do h <- parseCmmHint $1;
 507                                               return $ do
 508                                                 e <- $2; return (CmmHinted e h) }
 509
 510 local_lreg :: { ExtFCode LocalReg }
 511         : NAME                  { do e <- lookupName $1;
 512                                      return $
 513                                        case e of
 514                                         CmmReg (CmmLocal r) -> r
 515                                         other -> pprPanic "CmmParse:" (ftext $1 <> text " not a local register") }
 516
 517 lreg    :: { ExtFCode CmmReg }
 518         : NAME                  { do e <- lookupName $1;
 519                                      return $
 520                                        case e of
 521                                         CmmReg r -> r
 522                                         other -> pprPanic "CmmParse:" (ftext $1 <> text " not a register") }
 523         | GLOBALREG             { return (CmmGlobal $1) }
 524
 525 maybe_formals_without_hints :: { [ExtFCode LocalReg] }
 526         : {- empty -}           { [] }
 527         | '(' formals_without_hints0 ')'        { $2 }
 528
 529 formals_without_hints0 :: { [ExtFCode LocalReg] }
 530         : {- empty -}           { [] }
 531         | formals_without_hints         { $1 }
 532
 533 formals_without_hints :: { [ExtFCode LocalReg] }
 534         : formal_without_hint ','               { [$1] }
 535         | formal_without_hint           { [$1] }
 536         | formal_without_hint ',' formals_without_hints { $1 : $3 }
 537
 538 formal_without_hint :: { ExtFCode LocalReg }
 539         : type NAME             { newLocal $1 $2 }
 540
 541 maybe_frame :: { ExtFCode (Maybe UpdateFrame) }
 542         : {- empty -}                   { return Nothing }
 543         | 'jump' expr '(' exprs0 ')'    { do { target <- $2;
 544                                                args <- sequence $4;
 545                                                return $ Just (UpdateFrame target args) } }
 546
 547 maybe_gc_block :: { ExtFCode (Maybe BlockId) }
 548         : {- empty -}                   { return Nothing }
 549         | 'goto' NAME
 550                 { do l <- lookupLabel $2; return (Just l) }
 551
 552 type    :: { CmmType }
 553         : 'bits8'               { b8 }
 554         | typenot8              { $1 }
 555
 556 typenot8 :: { CmmType }
 557         : 'bits16'              { b16 }
 558         | 'bits32'              { b32 }
 559         | 'bits64'              { b64 }
 560         | 'float32'             { f32 }
 561         | 'float64'             { f64 }
 562         | 'gcptr'               { gcWord }
 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 :: (Width -> MachOp) -> [ExtFCode CmmExpr] -> ExtFCode CmmExpr
 580 mkMachOp fn args = do
 581   arg_exprs <- sequence args
 582   return (CmmMachOp (fn (typeWidth (cmmExprType (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 (Width -> 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_UU_Conv W8  ),
 660         ( "lobits16", flip MO_UU_Conv W16 ),
 661         ( "lobits32", flip MO_UU_Conv W32 ),
 662         ( "lobits64", flip MO_UU_Conv W64 ),
 663
 664         ( "zx16",     flip MO_UU_Conv W16 ),
 665         ( "zx32",     flip MO_UU_Conv W32 ),
 666         ( "zx64",     flip MO_UU_Conv W64 ),
 667
 668         ( "sx16",     flip MO_SS_Conv W16 ),
 669         ( "sx32",     flip MO_SS_Conv W32 ),
 670         ( "sx64",     flip MO_SS_Conv W64 ),
 671
 672         ( "f2f32",    flip MO_FF_Conv W32 ),  -- TODO; rounding mode
 673         ( "f2f64",    flip MO_FF_Conv W64 ),  -- TODO; rounding mode
 674         ( "f2i8",     flip MO_FS_Conv W8 ),
 675         ( "f2i16",    flip MO_FS_Conv W16 ),
 676         ( "f2i32",    flip MO_FS_Conv W32 ),
 677         ( "f2i64",    flip MO_FS_Conv W64 ),
 678         ( "i2f32",    flip MO_SF_Conv W32 ),
 679         ( "i2f64",    flip MO_SF_Conv W64 )
 680         ]
 681
 682 callishMachOps = listToUFM $
 683         map (\(x, y) -> (mkFastString x, y)) [
 684         ( "write_barrier", MO_WriteBarrier )
 685         -- ToDo: the rest, maybe
 686     ]
 687
 688 parseSafety :: String -> P CmmSafety
 689 parseSafety "safe"   = return (CmmSafe NoC_SRT)
 690 parseSafety "unsafe" = return CmmUnsafe
 691 parseSafety str      = fail ("unrecognised safety: " ++ str)
 692
 693 parseCmmHint :: String -> P ForeignHint
 694 parseCmmHint "ptr"    = return AddrHint
 695 parseCmmHint "signed" = return SignedHint
 696 parseCmmHint str      = fail ("unrecognised hint: " ++ str)
 697
 698 -- labels are always pointers, so we might as well infer the hint
 699 inferCmmHint :: CmmExpr -> ForeignHint
 700 inferCmmHint (CmmLit (CmmLabel _)) = AddrHint
 701 inferCmmHint (CmmReg (CmmGlobal g)) | isPtrGlobalReg g = AddrHint
 702 inferCmmHint _ = NoHint
 703
 704 isPtrGlobalReg Sp                    = True
 705 isPtrGlobalReg SpLim                 = True
 706 isPtrGlobalReg Hp                    = True
 707 isPtrGlobalReg HpLim                 = True
 708 isPtrGlobalReg CurrentTSO            = True
 709 isPtrGlobalReg CurrentNursery        = True
 710 isPtrGlobalReg (VanillaReg _ VGcPtr) = 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_NNNN",  \[a,b,c,d] -> emitRetUT [(NonPtrArg,a),(NonPtrArg,b),(NonPtrArg,c),(NonPtrArg,d)]),
 766   ( fsLit "RET_NNNP",   \[a,b,c,d] -> emitRetUT [(NonPtrArg,a),(NonPtrArg,b),(NonPtrArg,c),(PtrArg,d)]),
 767   ( fsLit "RET_NPNP",   \[a,b,c,d] -> emitRetUT [(NonPtrArg,a),(PtrArg,b),(NonPtrArg,c),(PtrArg,d)])
 768
 769  ]
 770
 771 -- -----------------------------------------------------------------------------
 772 -- Our extended FCode monad.
 773
 774 -- We add a mapping from names to CmmExpr, to support local variable names in
 775 -- the concrete C-- code.  The unique supply of the underlying FCode monad
 776 -- is used to grab a new unique for each local variable.
 777
 778 -- In C--, a local variable can be declared anywhere within a proc,
 779 -- and it scopes from the beginning of the proc to the end.  Hence, we have
 780 -- to collect declarations as we parse the proc, and feed the environment
 781 -- back in circularly (to avoid a two-pass algorithm).
 782
 783 data Named = Var CmmExpr | Label BlockId
 784 type Decls = [(FastString,Named)]
 785 type Env   = UniqFM Named
 786
 787 newtype ExtFCode a = EC { unEC :: Env -> Decls -> FCode (Decls, a) }
 788
 789 type ExtCode = ExtFCode ()
 790
 791 returnExtFC a = EC $ \e s -> return (s, a)
 792 thenExtFC (EC m) k = EC $ \e s -> do (s',r) <- m e s; unEC (k r) e s'
 793
 794 instance Monad ExtFCode where
 795   (>>=) = thenExtFC
 796   return = returnExtFC
 797
 798 -- This function takes the variable decarations and imports and makes
 799 -- an environment, which is looped back into the computation.  In this
 800 -- way, we can have embedded declarations that scope over the whole
 801 -- procedure, and imports that scope over the entire module.
 802 -- Discards the local declaration contained within decl'
 803 loopDecls :: ExtFCode a -> ExtFCode a
 804 loopDecls (EC fcode) =
 805       EC $ \e globalDecls -> do
 806         (decls', a) <- fixC (\ ~(decls,a) -> fcode (addListToUFM e (decls ++ globalDecls)) globalDecls)
 807         return (globalDecls, a)
 808
 809 getEnv :: ExtFCode Env
 810 getEnv = EC $ \e s -> return (s, e)
 811
 812 addVarDecl :: FastString -> CmmExpr -> ExtCode
 813 addVarDecl var expr = EC $ \e s -> return ((var, Var expr):s, ())
 814
 815 addLabel :: FastString -> BlockId -> ExtCode
 816 addLabel name block_id = EC $ \e s -> return ((name, Label block_id):s, ())
 817
 818 newLocal :: CmmType -> FastString -> ExtFCode LocalReg
 819 newLocal ty name = do
 820    u <- code newUnique
 821    let reg = LocalReg u ty
 822    addVarDecl name (CmmReg (CmmLocal reg))
 823    return reg
 824
 825 -- Creates a foreign label in the import. CLabel's labelDynamic
 826 -- classifies these labels as dynamic, hence the code generator emits the
 827 -- PIC code for them.
 828 newImport :: FastString -> ExtFCode ()
 829 newImport name
 830    = addVarDecl name (CmmLit (CmmLabel (mkForeignLabel name Nothing True IsFunction)))
 831
 832 newLabel :: FastString -> ExtFCode BlockId
 833 newLabel name = do
 834    u <- code newUnique
 835    addLabel name (BlockId u)
 836    return (BlockId u)
 837
 838 lookupLabel :: FastString -> ExtFCode BlockId
 839 lookupLabel name = do
 840   env <- getEnv
 841   return $
 842      case lookupUFM env name of
 843         Just (Label l) -> l
 844         _other -> BlockId (newTagUnique (getUnique name) 'L')
 845
 846 -- Unknown names are treated as if they had been 'import'ed.
 847 -- This saves us a lot of bother in the RTS sources, at the expense of
 848 -- deferring some errors to link time.
 849 lookupName :: FastString -> ExtFCode CmmExpr
 850 lookupName name = do
 851   env <- getEnv
 852   return $
 853      case lookupUFM env name of
 854         Just (Var e) -> e
 855         _other -> CmmLit (CmmLabel (mkRtsCodeLabel name))
 856
 857 -- Lifting FCode computations into the ExtFCode monad:
 858 code :: FCode a -> ExtFCode a
 859 code fc = EC $ \e s -> do r <- fc; return (s, r)
 860
 861 code2 :: (FCode (Decls,b) -> FCode ((Decls,b),c))
 862          -> ExtFCode b -> ExtFCode c
 863 code2 f (EC ec) = EC $ \e s -> do ((s',b),c) <- f (ec e s); return (s',c)
 864
 865 nopEC = code nopC
 866 stmtEC stmt = code (stmtC stmt)
 867 stmtsEC stmts = code (stmtsC stmts)
 868 getCgStmtsEC = code2 getCgStmts'
 869 getCgStmtsEC' = code2 (\m -> getCgStmts' m >>= f)
 870   where f ((decl, b), c) = return ((decl, b), (b, c))
 871
 872 forkLabelledCodeEC ec = do
 873   stmts <- getCgStmtsEC ec
 874   code (forkCgStmts stmts)
 875
 876
 877 profilingInfo desc_str ty_str = do
 878   lit1 <- if opt_SccProfilingOn
 879                    then code $ mkStringCLit desc_str
 880                    else return (mkIntCLit 0)
 881   lit2 <- if opt_SccProfilingOn
 882                    then code $ mkStringCLit ty_str
 883                    else return (mkIntCLit 0)
 884   return (ProfilingInfo lit1 lit2)
 885
 886
 887 staticClosure :: FastString -> FastString -> [CmmLit] -> ExtCode
 888 staticClosure cl_label info payload
 889   = code $ emitDataLits (mkRtsDataLabel cl_label) lits
 890   where  lits = mkStaticClosure (mkRtsInfoLabel info) dontCareCCS payload [] [] []
 891
 892 foreignCall
 893         :: String
 894         -> [ExtFCode HintedCmmFormal]
 895         -> ExtFCode CmmExpr
 896         -> [ExtFCode HintedCmmActual]
 897         -> Maybe [GlobalReg]
 898         -> CmmSafety
 899         -> CmmReturnInfo
 900         -> P ExtCode
 901 foreignCall conv_string results_code expr_code args_code vols safety ret
 902   = do  convention <- case conv_string of
 903           "C" -> return CCallConv
 904           "stdcall" -> return StdCallConv
 905           "C--" -> return CmmCallConv
 906           _ -> fail ("unknown calling convention: " ++ conv_string)
 907         return $ do
 908           results <- sequence results_code
 909           expr <- expr_code
 910           args <- sequence args_code
 911           --code (stmtC (CmmCall (CmmCallee expr convention) results args safety))
 912           case convention of
 913             -- Temporary hack so at least some functions are CmmSafe
 914             CmmCallConv -> code (stmtC (CmmCall (CmmCallee expr convention) results args safety ret))
 915             _ ->
 916               let expr' = adjCallTarget convention expr args in
 917               case safety of
 918               CmmUnsafe ->
 919                 code (emitForeignCall' PlayRisky results
 920                    (CmmCallee expr' convention) args vols NoC_SRT ret)
 921               CmmSafe srt ->
 922                 code (emitForeignCall' (PlaySafe unused) results
 923                    (CmmCallee expr' convention) args vols NoC_SRT ret) where
 924                 unused = panic "not used by emitForeignCall'"
 925
 926 adjCallTarget :: CCallConv -> CmmExpr -> [CmmHinted CmmExpr] -> CmmExpr
 927 #ifdef mingw32_TARGET_OS
 928 -- On Windows, we have to add the '@N' suffix to the label when making
 929 -- a call with the stdcall calling convention.
 930 adjCallTarget StdCallConv (CmmLit (CmmLabel lbl)) args
 931   = CmmLit (CmmLabel (addLabelSize lbl (sum (map size args))))
 932   where size (CmmHinted e _) = max wORD_SIZE (widthInBytes (typeWidth (cmmExprType e)))
 933                  -- c.f. CgForeignCall.emitForeignCall
 934 #endif
 935 adjCallTarget _ expr _
 936   = expr
 937
 938 primCall
 939         :: [ExtFCode HintedCmmFormal]
 940         -> FastString
 941         -> [ExtFCode HintedCmmActual]
 942         -> Maybe [GlobalReg]
 943         -> CmmSafety
 944         -> P ExtCode
 945 primCall results_code name args_code vols safety
 946   = case lookupUFM callishMachOps name of
 947         Nothing -> fail ("unknown primitive " ++ unpackFS name)
 948         Just p  -> return $ do
 949                 results <- sequence results_code
 950                 args <- sequence args_code
 951                 case safety of
 952                   CmmUnsafe ->
 953                     code (emitForeignCall' PlayRisky results
 954                       (CmmPrim p) args vols NoC_SRT CmmMayReturn)
 955                   CmmSafe srt ->
 956                     code (emitForeignCall' (PlaySafe unused) results
 957                       (CmmPrim p) args vols NoC_SRT CmmMayReturn) where
 958                     unused = panic "not used by emitForeignCall'"
 959
 960 doStore :: CmmType -> ExtFCode CmmExpr  -> ExtFCode CmmExpr -> ExtCode
 961 doStore rep addr_code val_code
 962   = do addr <- addr_code
 963        val <- val_code
 964         -- if the specified store type does not match the type of the expr
 965         -- on the rhs, then we insert a coercion that will cause the type
 966         -- mismatch to be flagged by cmm-lint.  If we don't do this, then
 967         -- the store will happen at the wrong type, and the error will not
 968         -- be noticed.
 969        let val_width = typeWidth (cmmExprType val)
 970            rep_width = typeWidth rep
 971        let coerce_val
 972                 | val_width /= rep_width = CmmMachOp (MO_UU_Conv val_width rep_width) [val]
 973                 | otherwise              = val
 974        stmtEC (CmmStore addr coerce_val)
 975
 976 -- Return an unboxed tuple.
 977 emitRetUT :: [(CgRep,CmmExpr)] -> Code
 978 emitRetUT args = do
 979   tickyUnboxedTupleReturn (length args)  -- TICK
 980   (sp, stmts) <- pushUnboxedTuple 0 args
 981   emitSimultaneously stmts -- NB. the args might overlap with the stack slots
 982                            -- or regs that we assign to, so better use
 983                            -- simultaneous assignments here (#3546)
 984   when (sp /= 0) $ stmtC (CmmAssign spReg (cmmRegOffW spReg (-sp)))
 985   stmtC (CmmJump (entryCode (CmmLoad (cmmRegOffW spReg sp) bWord)) [])
 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)) wordWidth) )),
1092   ( fsLit "SIZEOF_StgInfoTable",
1093     Var (CmmLit (CmmInt (fromIntegral stdInfoTableSizeB) wordWidth) ))
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 }