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