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