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 module CmmParse ( parseCmmFile ) where
  11
  12 import CgMonad
  13 import CgHeapery
  14 import CgUtils
  15 import CgProf
  16 import CgTicky
  17 import CgInfoTbls
  18 import CgForeignCall
  19 import CgTailCall
  20 import CgStackery
  21 import ClosureInfo
  22 import CgCallConv
  23 import CgClosure
  24 import CostCentre
  25
  26 import Cmm
  27 import PprCmm
  28 import CmmUtils
  29 import CmmLex
  30 import CLabel
  31 import MachOp
  32 import SMRep
  33 import Lexer
  34
  35 import ForeignCall
  36 import Literal
  37 import Unique
  38 import UniqFM
  39 import SrcLoc
  40 import DynFlags
  41 import StaticFlags
  42 import ErrUtils
  43 import StringBuffer
  44 import FastString
  45 import Panic
  46 import Constants
  47 import Outputable
  48
  49 import Control.Monad    ( when )
  50 import Data.Char        ( ord )
  51
  52 #include "HsVersions.h"
  53 }
  54
  55 %token
  56         ':'     { L _ (CmmT_SpecChar ':') }
  57         ';'     { L _ (CmmT_SpecChar ';') }
  58         '{'     { L _ (CmmT_SpecChar '{') }
  59         '}'     { L _ (CmmT_SpecChar '}') }
  60         '['     { L _ (CmmT_SpecChar '[') }
  61         ']'     { L _ (CmmT_SpecChar ']') }
  62         '('     { L _ (CmmT_SpecChar '(') }
  63         ')'     { L _ (CmmT_SpecChar ')') }
  64         '='     { L _ (CmmT_SpecChar '=') }
  65         '`'     { L _ (CmmT_SpecChar '`') }
  66         '~'     { L _ (CmmT_SpecChar '~') }
  67         '/'     { L _ (CmmT_SpecChar '/') }
  68         '*'     { L _ (CmmT_SpecChar '*') }
  69         '%'     { L _ (CmmT_SpecChar '%') }
  70         '-'     { L _ (CmmT_SpecChar '-') }
  71         '+'     { L _ (CmmT_SpecChar '+') }
  72         '&'     { L _ (CmmT_SpecChar '&') }
  73         '^'     { L _ (CmmT_SpecChar '^') }
  74         '|'     { L _ (CmmT_SpecChar '|') }
  75         '>'     { L _ (CmmT_SpecChar '>') }
  76         '<'     { L _ (CmmT_SpecChar '<') }
  77         ','     { L _ (CmmT_SpecChar ',') }
  78         '!'     { L _ (CmmT_SpecChar '!') }
  79
  80         '..'    { L _ (CmmT_DotDot) }
  81         '::'    { L _ (CmmT_DoubleColon) }
  82         '>>'    { L _ (CmmT_Shr) }
  83         '<<'    { L _ (CmmT_Shl) }
  84         '>='    { L _ (CmmT_Ge) }
  85         '<='    { L _ (CmmT_Le) }
  86         '=='    { L _ (CmmT_Eq) }
  87         '!='    { L _ (CmmT_Ne) }
  88         '&&'    { L _ (CmmT_BoolAnd) }
  89         '||'    { L _ (CmmT_BoolOr) }
  90
  91         'CLOSURE'       { L _ (CmmT_CLOSURE) }
  92         'INFO_TABLE'    { L _ (CmmT_INFO_TABLE) }
  93         'INFO_TABLE_RET'{ L _ (CmmT_INFO_TABLE_RET) }
  94         'INFO_TABLE_FUN'{ L _ (CmmT_INFO_TABLE_FUN) }
  95         'INFO_TABLE_CONSTR'{ L _ (CmmT_INFO_TABLE_CONSTR) }
  96         'INFO_TABLE_SELECTOR'{ L _ (CmmT_INFO_TABLE_SELECTOR) }
  97         'else'          { L _ (CmmT_else) }
  98         'export'        { L _ (CmmT_export) }
  99         'section'       { L _ (CmmT_section) }
 100         'align'         { L _ (CmmT_align) }
 101         'goto'          { L _ (CmmT_goto) }
 102         'if'            { L _ (CmmT_if) }
 103         'jump'          { L _ (CmmT_jump) }
 104         'foreign'       { L _ (CmmT_foreign) }
 105         'prim'          { L _ (CmmT_prim) }
 106         'import'        { L _ (CmmT_import) }
 107         'switch'        { L _ (CmmT_switch) }
 108         'case'          { L _ (CmmT_case) }
 109         'default'       { L _ (CmmT_default) }
 110         'bits8'         { L _ (CmmT_bits8) }
 111         'bits16'        { L _ (CmmT_bits16) }
 112         'bits32'        { L _ (CmmT_bits32) }
 113         'bits64'        { L _ (CmmT_bits64) }
 114         'float32'       { L _ (CmmT_float32) }
 115         'float64'       { L _ (CmmT_float64) }
 116
 117         GLOBALREG       { L _ (CmmT_GlobalReg   $$) }
 118         NAME            { L _ (CmmT_Name        $$) }
 119         STRING          { L _ (CmmT_String      $$) }
 120         INT             { L _ (CmmT_Int         $$) }
 121         FLOAT           { L _ (CmmT_Float       $$) }
 122
 123 %monad { P } { >>= } { return }
 124 %lexer { cmmlex } { L _ CmmT_EOF }
 125 %name cmmParse cmm
 126 %tokentype { Located CmmToken }
 127
 128 -- C-- operator precedences, taken from the C-- spec
 129 %right '||'     -- non-std extension, called %disjoin in C--
 130 %right '&&'     -- non-std extension, called %conjoin in C--
 131 %right '!'
 132 %nonassoc '>=' '>' '<=' '<' '!=' '=='
 133 %left '|'
 134 %left '^'
 135 %left '&'
 136 %left '>>' '<<'
 137 %left '-' '+'
 138 %left '/' '*' '%'
 139 %right '~'
 140
 141 %%
 142
 143 cmm     :: { ExtCode }
 144         : {- empty -}                   { return () }
 145         | cmmtop cmm                    { do $1; $2 }
 146
 147 cmmtop  :: { ExtCode }
 148         : cmmproc                       { $1 }
 149         | cmmdata                       { $1 }
 150         | decl                          { $1 }
 151         | 'CLOSURE' '(' NAME ',' NAME lits ')' ';'
 152                 { do lits <- sequence $6;
 153                      staticClosure $3 $5 (map getLit lits) }
 154
 155 -- The only static closures in the RTS are dummy closures like
 156 -- stg_END_TSO_QUEUE_closure and stg_dummy_ret.  We don't need
 157 -- to provide the full generality of static closures here.
 158 -- In particular:
 159 --      * CCS can always be CCS_DONT_CARE
 160 --      * closure is always extern
 161 --      * payload is always empty
 162 --      * we can derive closure and info table labels from a single NAME
 163
 164 cmmdata :: { ExtCode }
 165         : 'section' STRING '{' statics '}'
 166                 { do ss <- sequence $4;
 167                      code (emitData (section $2) (concat ss)) }
 168
 169 statics :: { [ExtFCode [CmmStatic]] }
 170         : {- empty -}                   { [] }
 171         | static statics                { $1 : $2 }
 172
 173 -- Strings aren't used much in the RTS HC code, so it doesn't seem
 174 -- worth allowing inline strings.  C-- doesn't allow them anyway.
 175 static  :: { ExtFCode [CmmStatic] }
 176         : NAME ':'      { return [CmmDataLabel (mkRtsDataLabelFS $1)] }
 177         | type expr ';' { do e <- $2;
 178                              return [CmmStaticLit (getLit e)] }
 179         | type ';'                      { return [CmmUninitialised
 180                                                         (machRepByteWidth $1)] }
 181         | 'bits8' '[' ']' STRING ';'    { return [mkString $4] }
 182         | 'bits8' '[' INT ']' ';'       { return [CmmUninitialised
 183                                                         (fromIntegral $3)] }
 184         | typenot8 '[' INT ']' ';'      { return [CmmUninitialised
 185                                                 (machRepByteWidth $1 *
 186                                                         fromIntegral $3)] }
 187         | 'align' INT ';'               { return [CmmAlign (fromIntegral $2)] }
 188         | 'CLOSURE' '(' NAME lits ')'
 189                 { do lits <- sequence $4;
 190                      return $ map CmmStaticLit $
 191                        mkStaticClosure (mkRtsInfoLabelFS $3)
 192                          dontCareCCS (map getLit lits) [] [] [] }
 193         -- arrays of closures required for the CHARLIKE & INTLIKE arrays
 194
 195 lits    :: { [ExtFCode CmmExpr] }
 196         : {- empty -}           { [] }
 197         | ',' expr lits         { $2 : $3 }
 198
 199 cmmproc :: { ExtCode }
 200         : info '{' body '}'
 201                 { do  (info_lbl, info1, info2) <- $1;
 202                       stmts <- getCgStmtsEC (loopDecls $3)
 203                       blks <- code (cgStmtsToBlocks stmts)
 204                       code (emitInfoTableAndCode info_lbl info1 info2 [] blks) }
 205
 206         | info ';'
 207                 { do (info_lbl, info1, info2) <- $1;
 208                      code (emitInfoTableAndCode info_lbl info1 info2 [] []) }
 209
 210         | NAME '{' body '}'
 211                 { do stmts <- getCgStmtsEC (loopDecls $3);
 212                      blks <- code (cgStmtsToBlocks stmts)
 213                      code (emitProc [] (mkRtsCodeLabelFS $1) [] blks) }
 214
 215 info    :: { ExtFCode (CLabel, [CmmLit],[CmmLit]) }
 216         : 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
 217                 -- ptrs, nptrs, closure type, description, type
 218                 { stdInfo $3 $5 $7 0 $9 $11 $13 }
 219
 220         | 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ')'
 221                 -- ptrs, nptrs, closure type, description, type, fun type
 222                 { funInfo $3 $5 $7 $9 $11 $13 $15 }
 223
 224         | 'INFO_TABLE_CONSTR' '(' NAME ',' INT ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
 225                 -- ptrs, nptrs, tag, closure type, description, type
 226                 { stdInfo $3 $5 $7 $9 $11 $13 $15 }
 227
 228         | 'INFO_TABLE_SELECTOR' '(' NAME ',' INT ',' INT ',' STRING ',' STRING ')'
 229                 -- selector, closure type, description, type
 230                 { basicInfo $3 (mkIntCLit (fromIntegral $5)) 0 $7 $9 $11 }
 231
 232         | 'INFO_TABLE_RET' '(' NAME ',' INT ',' INT ',' INT maybe_vec ')'
 233                 { retInfo $3 $5 $7 $9 $10 }
 234
 235 maybe_vec :: { [CmmLit] }
 236         : {- empty -}                   { [] }
 237         | ',' NAME maybe_vec            { CmmLabel (mkRtsCodeLabelFS $2) : $3 }
 238
 239 body    :: { ExtCode }
 240         : {- empty -}                   { return () }
 241         | decl body                     { do $1; $2 }
 242         | stmt body                     { do $1; $2 }
 243
 244 decl    :: { ExtCode }
 245         : type names ';'                { mapM_ (newLocal $1) $2 }
 246         | 'import' names ';'            { return () }  -- ignore imports
 247         | 'export' names ';'            { return () }  -- ignore exports
 248
 249 names   :: { [FastString] }
 250         : NAME                  { [$1] }
 251         | NAME ',' names        { $1 : $3 }
 252
 253 stmt    :: { ExtCode }
 254         : ';'                                   { nopEC }
 255
 256         | NAME ':'
 257                 { do l <- newLabel $1; code (labelC l) }
 258
 259         | lreg '=' expr ';'
 260                 { do reg <- $1; e <- $3; stmtEC (CmmAssign reg e) }
 261         | type '[' expr ']' '=' expr ';'
 262                 { doStore $1 $3 $6 }
 263         | 'foreign' STRING expr '(' hint_exprs0 ')' vols ';'
 264                 {% foreignCall $2 [] $3 $5 $7 }
 265         | lreg '=' 'foreign' STRING expr '(' hint_exprs0 ')' vols ';'
 266                 {% let result = do r <- $1; return (r,NoHint) in
 267                    foreignCall $4 [result] $5 $7 $9 }
 268         | 'prim' '%' NAME '(' hint_exprs0 ')' vols ';'
 269                 {% primCall [] $3 $5 $7 }
 270         | lreg '=' 'prim' '%' NAME '(' hint_exprs0 ')' vols ';'
 271                 {% let result = do r <- $1; return (r,NoHint) in
 272                    primCall [result] $5 $7 $9 }
 273         | STRING lreg '=' 'foreign' STRING expr '(' hint_exprs0 ')' vols ';'
 274                 {% do h <- parseHint $1;
 275                       let result = do r <- $2; return (r,h) in
 276                       foreignCall $5 [result] $6 $8 $10 }
 277         -- stmt-level macros, stealing syntax from ordinary C-- function calls.
 278         -- Perhaps we ought to use the %%-form?
 279         | NAME '(' exprs0 ')' ';'
 280                 {% stmtMacro $1 $3  }
 281         | 'switch' maybe_range expr '{' arms default '}'
 282                 { doSwitch $2 $3 $5 $6 }
 283         | 'goto' NAME ';'
 284                 { do l <- lookupLabel $2; stmtEC (CmmBranch l) }
 285         | 'jump' expr {-maybe_actuals-} ';'
 286                 { do e <- $2; stmtEC (CmmJump e []) }
 287         | 'if' bool_expr '{' body '}' else
 288                 { ifThenElse $2 $4 $6 }
 289
 290 bool_expr :: { ExtFCode BoolExpr }
 291         : bool_op                       { $1 }
 292         | expr                          { do e <- $1; return (BoolTest e) }
 293
 294 bool_op :: { ExtFCode BoolExpr }
 295         : bool_expr '&&' bool_expr      { do e1 <- $1; e2 <- $3;
 296                                           return (BoolAnd e1 e2) }
 297         | bool_expr '||' bool_expr      { do e1 <- $1; e2 <- $3;
 298                                           return (BoolOr e1 e2)  }
 299         | '!' bool_expr                 { do e <- $2; return (BoolNot e) }
 300         | '(' bool_op ')'               { $2 }
 301
 302 -- This is not C-- syntax.  What to do?
 303 vols    :: { Maybe [GlobalReg] }
 304         : {- empty -}                   { Nothing }
 305         | '[' ']'                       { Just [] }
 306         | '[' globals ']'               { Just $2 }
 307
 308 globals :: { [GlobalReg] }
 309         : GLOBALREG                     { [$1] }
 310         | GLOBALREG ',' globals         { $1 : $3 }
 311
 312 maybe_range :: { Maybe (Int,Int) }
 313         : '[' INT '..' INT ']'  { Just (fromIntegral $2, fromIntegral $4) }
 314         | {- empty -}           { Nothing }
 315
 316 arms    :: { [([Int],ExtCode)] }
 317         : {- empty -}                   { [] }
 318         | arm arms                      { $1 : $2 }
 319
 320 arm     :: { ([Int],ExtCode) }
 321         : 'case' ints ':' '{' body '}'  { ($2, $5) }
 322
 323 ints    :: { [Int] }
 324         : INT                           { [ fromIntegral $1 ] }
 325         | INT ',' ints                  { fromIntegral $1 : $3 }
 326
 327 default :: { Maybe ExtCode }
 328         : 'default' ':' '{' body '}'    { Just $4 }
 329         -- taking a few liberties with the C-- syntax here; C-- doesn't have
 330         -- 'default' branches
 331         | {- empty -}                   { Nothing }
 332
 333 else    :: { ExtCode }
 334         : {- empty -}                   { nopEC }
 335         | 'else' '{' body '}'           { $3 }
 336
 337 -- we have to write this out longhand so that Happy's precedence rules
 338 -- can kick in.
 339 expr    :: { ExtFCode CmmExpr }
 340         : expr '/' expr                 { mkMachOp MO_U_Quot [$1,$3] }
 341         | expr '*' expr                 { mkMachOp MO_Mul [$1,$3] }
 342         | expr '%' expr                 { mkMachOp MO_U_Rem [$1,$3] }
 343         | expr '-' expr                 { mkMachOp MO_Sub [$1,$3] }
 344         | expr '+' expr                 { mkMachOp MO_Add [$1,$3] }
 345         | expr '>>' expr                { mkMachOp MO_U_Shr [$1,$3] }
 346         | expr '<<' expr                { mkMachOp MO_Shl [$1,$3] }
 347         | expr '&' expr                 { mkMachOp MO_And [$1,$3] }
 348         | expr '^' expr                 { mkMachOp MO_Xor [$1,$3] }
 349         | expr '|' expr                 { mkMachOp MO_Or [$1,$3] }
 350         | expr '>=' expr                { mkMachOp MO_U_Ge [$1,$3] }
 351         | expr '>' expr                 { mkMachOp MO_U_Gt [$1,$3] }
 352         | expr '<=' expr                { mkMachOp MO_U_Le [$1,$3] }
 353         | expr '<' expr                 { mkMachOp MO_U_Lt [$1,$3] }
 354         | expr '!=' expr                { mkMachOp MO_Ne [$1,$3] }
 355         | expr '==' expr                { mkMachOp MO_Eq [$1,$3] }
 356         | '~' expr                      { mkMachOp MO_Not [$2] }
 357         | '-' expr                      { mkMachOp MO_S_Neg [$2] }
 358         | expr0 '`' NAME '`' expr0      {% do { mo <- nameToMachOp $3 ;
 359                                                 return (mkMachOp mo [$1,$5]) } }
 360         | expr0                         { $1 }
 361
 362 expr0   :: { ExtFCode CmmExpr }
 363         : INT   maybe_ty         { return (CmmLit (CmmInt $1 $2)) }
 364         | FLOAT maybe_ty         { return (CmmLit (CmmFloat $1 $2)) }
 365         | STRING                 { do s <- code (mkStringCLit $1);
 366                                       return (CmmLit s) }
 367         | reg                    { $1 }
 368         | type '[' expr ']'      { do e <- $3; return (CmmLoad e $1) }
 369         | '%' NAME '(' exprs0 ')' {% exprOp $2 $4 }
 370         | '(' expr ')'           { $2 }
 371
 372
 373 -- leaving out the type of a literal gives you the native word size in C--
 374 maybe_ty :: { MachRep }
 375         : {- empty -}                   { wordRep }
 376         | '::' type                     { $2 }
 377
 378 hint_exprs0 :: { [ExtFCode (CmmExpr, MachHint)] }
 379         : {- empty -}                   { [] }
 380         | hint_exprs                    { $1 }
 381
 382 hint_exprs :: { [ExtFCode (CmmExpr, MachHint)] }
 383         : hint_expr                     { [$1] }
 384         | hint_expr ',' hint_exprs      { $1 : $3 }
 385
 386 hint_expr :: { ExtFCode (CmmExpr, MachHint) }
 387         : expr                          { do e <- $1; return (e, inferHint e) }
 388         | expr STRING                   {% do h <- parseHint $2;
 389                                               return $ do
 390                                                 e <- $1; return (e,h) }
 391
 392 exprs0  :: { [ExtFCode CmmExpr] }
 393         : {- empty -}                   { [] }
 394         | exprs                         { $1 }
 395
 396 exprs   :: { [ExtFCode CmmExpr] }
 397         : expr                          { [ $1 ] }
 398         | expr ',' exprs                { $1 : $3 }
 399
 400 reg     :: { ExtFCode CmmExpr }
 401         : NAME                  { lookupName $1 }
 402         | GLOBALREG             { return (CmmReg (CmmGlobal $1)) }
 403
 404 lreg    :: { ExtFCode CmmReg }
 405         : NAME                  { do e <- lookupName $1;
 406                                      return $
 407                                        case e of
 408                                         CmmReg r -> r
 409                                         other -> pprPanic "CmmParse:" (ftext $1 <> text " not a register") }
 410         | GLOBALREG             { return (CmmGlobal $1) }
 411
 412 type    :: { MachRep }
 413         : 'bits8'               { I8 }
 414         | typenot8              { $1 }
 415
 416 typenot8 :: { MachRep }
 417         : 'bits16'              { I16 }
 418         | 'bits32'              { I32 }
 419         | 'bits64'              { I64 }
 420         | 'float32'             { F32 }
 421         | 'float64'             { F64 }
 422 {
 423 section :: String -> Section
 424 section "text"   = Text
 425 section "data"   = Data
 426 section "rodata" = ReadOnlyData
 427 section "bss"    = UninitialisedData
 428 section s        = OtherSection s
 429
 430 mkString :: String -> CmmStatic
 431 mkString s = CmmString (map (fromIntegral.ord) s)
 432
 433 -- mkMachOp infers the type of the MachOp from the type of its first
 434 -- argument.  We assume that this is correct: for MachOps that don't have
 435 -- symmetrical args (e.g. shift ops), the first arg determines the type of
 436 -- the op.
 437 mkMachOp :: (MachRep -> MachOp) -> [ExtFCode CmmExpr] -> ExtFCode CmmExpr
 438 mkMachOp fn args = do
 439   arg_exprs <- sequence args
 440   return (CmmMachOp (fn (cmmExprRep (head arg_exprs))) arg_exprs)
 441
 442 getLit :: CmmExpr -> CmmLit
 443 getLit (CmmLit l) = l
 444 getLit (CmmMachOp (MO_S_Neg _) [CmmLit (CmmInt i r)])  = CmmInt (negate i) r
 445 getLit _ = panic "invalid literal" -- TODO messy failure
 446
 447 nameToMachOp :: FastString -> P (MachRep -> MachOp)
 448 nameToMachOp name =
 449   case lookupUFM machOps name of
 450         Nothing -> fail ("unknown primitive " ++ unpackFS name)
 451         Just m  -> return m
 452
 453 exprOp :: FastString -> [ExtFCode CmmExpr] -> P (ExtFCode CmmExpr)
 454 exprOp name args_code =
 455   case lookupUFM exprMacros name of
 456      Just f  -> return $ do
 457         args <- sequence args_code
 458         return (f args)
 459      Nothing -> do
 460         mo <- nameToMachOp name
 461         return $ mkMachOp mo args_code
 462
 463 exprMacros :: UniqFM ([CmmExpr] -> CmmExpr)
 464 exprMacros = listToUFM [
 465   ( FSLIT("ENTRY_CODE"),   \ [x] -> entryCode x ),
 466   ( FSLIT("INFO_PTR"),     \ [x] -> closureInfoPtr x ),
 467   ( FSLIT("STD_INFO"),     \ [x] -> infoTable x ),
 468   ( FSLIT("FUN_INFO"),     \ [x] -> funInfoTable x ),
 469   ( FSLIT("GET_ENTRY"),    \ [x] -> entryCode (closureInfoPtr x) ),
 470   ( FSLIT("GET_STD_INFO"), \ [x] -> infoTable (closureInfoPtr x) ),
 471   ( FSLIT("GET_FUN_INFO"), \ [x] -> funInfoTable (closureInfoPtr x) ),
 472   ( FSLIT("INFO_TYPE"),    \ [x] -> infoTableClosureType x ),
 473   ( FSLIT("INFO_PTRS"),    \ [x] -> infoTablePtrs x ),
 474   ( FSLIT("INFO_NPTRS"),   \ [x] -> infoTableNonPtrs x ),
 475   ( FSLIT("RET_VEC"),      \ [info, conZ] -> retVec info conZ )
 476   ]
 477
 478 -- we understand a subset of C-- primitives:
 479 machOps = listToUFM $
 480         map (\(x, y) -> (mkFastString x, y)) [
 481         ( "add",        MO_Add ),
 482         ( "sub",        MO_Sub ),
 483         ( "eq",         MO_Eq ),
 484         ( "ne",         MO_Ne ),
 485         ( "mul",        MO_Mul ),
 486         ( "neg",        MO_S_Neg ),
 487         ( "quot",       MO_S_Quot ),
 488         ( "rem",        MO_S_Rem ),
 489         ( "divu",       MO_U_Quot ),
 490         ( "modu",       MO_U_Rem ),
 491
 492         ( "ge",         MO_S_Ge ),
 493         ( "le",         MO_S_Le ),
 494         ( "gt",         MO_S_Gt ),
 495         ( "lt",         MO_S_Lt ),
 496
 497         ( "geu",        MO_U_Ge ),
 498         ( "leu",        MO_U_Le ),
 499         ( "gtu",        MO_U_Gt ),
 500         ( "ltu",        MO_U_Lt ),
 501
 502         ( "flt",        MO_S_Lt ),
 503         ( "fle",        MO_S_Le ),
 504         ( "feq",        MO_Eq ),
 505         ( "fne",        MO_Ne ),
 506         ( "fgt",        MO_S_Gt ),
 507         ( "fge",        MO_S_Ge ),
 508         ( "fneg",       MO_S_Neg ),
 509
 510         ( "and",        MO_And ),
 511         ( "or",         MO_Or ),
 512         ( "xor",        MO_Xor ),
 513         ( "com",        MO_Not ),
 514         ( "shl",        MO_Shl ),
 515         ( "shrl",       MO_U_Shr ),
 516         ( "shra",       MO_S_Shr ),
 517
 518         ( "lobits8",  flip MO_U_Conv I8  ),
 519         ( "lobits16", flip MO_U_Conv I16 ),
 520         ( "lobits32", flip MO_U_Conv I32 ),
 521         ( "lobits64", flip MO_U_Conv I64 ),
 522         ( "sx16",     flip MO_S_Conv I16 ),
 523         ( "sx32",     flip MO_S_Conv I32 ),
 524         ( "sx64",     flip MO_S_Conv I64 ),
 525         ( "zx16",     flip MO_U_Conv I16 ),
 526         ( "zx32",     flip MO_U_Conv I32 ),
 527         ( "zx64",     flip MO_U_Conv I64 ),
 528         ( "f2f32",    flip MO_S_Conv F32 ),  -- TODO; rounding mode
 529         ( "f2f64",    flip MO_S_Conv F64 ),  -- TODO; rounding mode
 530         ( "f2i8",     flip MO_S_Conv I8 ),
 531         ( "f2i16",    flip MO_S_Conv I8 ),
 532         ( "f2i32",    flip MO_S_Conv I8 ),
 533         ( "f2i64",    flip MO_S_Conv I8 ),
 534         ( "i2f32",    flip MO_S_Conv F32 ),
 535         ( "i2f64",    flip MO_S_Conv F64 )
 536         ]
 537
 538 callishMachOps = listToUFM $
 539         map (\(x, y) -> (mkFastString x, y)) [
 540         ( "write_barrier", MO_WriteBarrier )
 541         -- ToDo: the rest, maybe
 542     ]
 543
 544 parseHint :: String -> P MachHint
 545 parseHint "ptr"    = return PtrHint
 546 parseHint "signed" = return SignedHint
 547 parseHint "float"  = return FloatHint
 548 parseHint str      = fail ("unrecognised hint: " ++ str)
 549
 550 -- labels are always pointers, so we might as well infer the hint
 551 inferHint :: CmmExpr -> MachHint
 552 inferHint (CmmLit (CmmLabel _)) = PtrHint
 553 inferHint (CmmReg (CmmGlobal g)) | isPtrGlobalReg g = PtrHint
 554 inferHint _ = NoHint
 555
 556 isPtrGlobalReg Sp               = True
 557 isPtrGlobalReg SpLim            = True
 558 isPtrGlobalReg Hp               = True
 559 isPtrGlobalReg HpLim            = True
 560 isPtrGlobalReg CurrentTSO       = True
 561 isPtrGlobalReg CurrentNursery   = True
 562 isPtrGlobalReg _                = False
 563
 564 happyError :: P a
 565 happyError = srcParseFail
 566
 567 -- -----------------------------------------------------------------------------
 568 -- Statement-level macros
 569
 570 stmtMacro :: FastString -> [ExtFCode CmmExpr] -> P ExtCode
 571 stmtMacro fun args_code = do
 572   case lookupUFM stmtMacros fun of
 573     Nothing -> fail ("unknown macro: " ++ unpackFS fun)
 574     Just fcode -> return $ do
 575         args <- sequence args_code
 576         code (fcode args)
 577
 578 stmtMacros :: UniqFM ([CmmExpr] -> Code)
 579 stmtMacros = listToUFM [
 580   ( FSLIT("CCS_ALLOC"),            \[words,ccs]  -> profAlloc words ccs ),
 581   ( FSLIT("CLOSE_NURSERY"),        \[]  -> emitCloseNursery ),
 582   ( FSLIT("ENTER_CCS_PAP_CL"),     \[e] -> enterCostCentrePAP e ),
 583   ( FSLIT("ENTER_CCS_THUNK"),      \[e] -> enterCostCentreThunk e ),
 584   ( FSLIT("HP_CHK_GEN"),           \[words,liveness,reentry] ->
 585                                       hpChkGen words liveness reentry ),
 586   ( FSLIT("HP_CHK_NP_ASSIGN_SP0"), \[e,f] -> hpChkNodePointsAssignSp0 e f ),
 587   ( FSLIT("LOAD_THREAD_STATE"),    \[] -> emitLoadThreadState ),
 588   ( FSLIT("LDV_ENTER"),            \[e] -> ldvEnter e ),
 589   ( FSLIT("LDV_RECORD_CREATE"),    \[e] -> ldvRecordCreate e ),
 590   ( FSLIT("OPEN_NURSERY"),         \[]  -> emitOpenNursery ),
 591   ( FSLIT("PUSH_UPD_FRAME"),       \[sp,e] -> emitPushUpdateFrame sp e ),
 592   ( FSLIT("SAVE_THREAD_STATE"),    \[] -> emitSaveThreadState ),
 593   ( FSLIT("SET_HDR"),              \[ptr,info,ccs] ->
 594                                         emitSetDynHdr ptr info ccs ),
 595   ( FSLIT("STK_CHK_GEN"),          \[words,liveness,reentry] ->
 596                                       stkChkGen words liveness reentry ),
 597   ( FSLIT("STK_CHK_NP"),           \[e] -> stkChkNodePoints e ),
 598   ( FSLIT("TICK_ALLOC_PRIM"),      \[hdr,goods,slop] ->
 599                                         tickyAllocPrim hdr goods slop ),
 600   ( FSLIT("TICK_ALLOC_PAP"),       \[goods,slop] ->
 601                                         tickyAllocPAP goods slop ),
 602   ( FSLIT("TICK_ALLOC_UP_THK"),    \[goods,slop] ->
 603                                         tickyAllocThunk goods slop ),
 604   ( FSLIT("UPD_BH_UPDATABLE"),       \[] -> emitBlackHoleCode False ),
 605   ( FSLIT("UPD_BH_SINGLE_ENTRY"),    \[] -> emitBlackHoleCode True ),
 606
 607   ( FSLIT("RET_P"),     \[a] ->       emitRetUT [(PtrArg,a)]),
 608   ( FSLIT("RET_N"),     \[a] ->       emitRetUT [(NonPtrArg,a)]),
 609   ( FSLIT("RET_PP"),    \[a,b] ->     emitRetUT [(PtrArg,a),(PtrArg,b)]),
 610   ( FSLIT("RET_NN"),    \[a,b] ->     emitRetUT [(NonPtrArg,a),(NonPtrArg,b)]),
 611   ( FSLIT("RET_NP"),    \[a,b] ->     emitRetUT [(NonPtrArg,a),(PtrArg,b)]),
 612   ( FSLIT("RET_PPP"),   \[a,b,c] ->   emitRetUT [(PtrArg,a),(PtrArg,b),(PtrArg,c)]),
 613   ( FSLIT("RET_NNP"),   \[a,b,c] ->   emitRetUT [(NonPtrArg,a),(NonPtrArg,b),(PtrArg,c)]),
 614   ( FSLIT("RET_NNNP"),  \[a,b,c,d] -> emitRetUT [(NonPtrArg,a),(NonPtrArg,b),(NonPtrArg,c),(PtrArg,d)]),
 615   ( FSLIT("RET_NPNP"),  \[a,b,c,d] -> emitRetUT [(NonPtrArg,a),(PtrArg,b),(NonPtrArg,c),(PtrArg,d)])
 616
 617  ]
 618
 619 -- -----------------------------------------------------------------------------
 620 -- Our extended FCode monad.
 621
 622 -- We add a mapping from names to CmmExpr, to support local variable names in
 623 -- the concrete C-- code.  The unique supply of the underlying FCode monad
 624 -- is used to grab a new unique for each local variable.
 625
 626 -- In C--, a local variable can be declared anywhere within a proc,
 627 -- and it scopes from the beginning of the proc to the end.  Hence, we have
 628 -- to collect declarations as we parse the proc, and feed the environment
 629 -- back in circularly (to avoid a two-pass algorithm).
 630
 631 data Named = Var CmmExpr | Label BlockId
 632 type Decls = [(FastString,Named)]
 633 type Env   = UniqFM Named
 634
 635 newtype ExtFCode a = EC { unEC :: Env -> Decls -> FCode (Decls, a) }
 636
 637 type ExtCode = ExtFCode ()
 638
 639 returnExtFC a = EC $ \e s -> return (s, a)
 640 thenExtFC (EC m) k = EC $ \e s -> do (s',r) <- m e s; unEC (k r) e s'
 641
 642 instance Monad ExtFCode where
 643   (>>=) = thenExtFC
 644   return = returnExtFC
 645
 646 -- This function takes the variable decarations and imports and makes
 647 -- an environment, which is looped back into the computation.  In this
 648 -- way, we can have embedded declarations that scope over the whole
 649 -- procedure, and imports that scope over the entire module.
 650 loopDecls :: ExtFCode a -> ExtFCode a
 651 loopDecls (EC fcode) =
 652    EC $ \e s -> fixC (\ ~(decls,a) -> fcode (addListToUFM e decls) [])
 653
 654 getEnv :: ExtFCode Env
 655 getEnv = EC $ \e s -> return (s, e)
 656
 657 addVarDecl :: FastString -> CmmExpr -> ExtCode
 658 addVarDecl var expr = EC $ \e s -> return ((var, Var expr):s, ())
 659
 660 addLabel :: FastString -> BlockId -> ExtCode
 661 addLabel name block_id = EC $ \e s -> return ((name, Label block_id):s, ())
 662
 663 newLocal :: MachRep -> FastString -> ExtCode
 664 newLocal ty name  = do
 665    u <- code newUnique
 666    addVarDecl name (CmmReg (CmmLocal (LocalReg u ty)))
 667
 668 newLabel :: FastString -> ExtFCode BlockId
 669 newLabel name = do
 670    u <- code newUnique
 671    addLabel name (BlockId u)
 672    return (BlockId u)
 673
 674 lookupLabel :: FastString -> ExtFCode BlockId
 675 lookupLabel name = do
 676   env <- getEnv
 677   return $
 678      case lookupUFM env name of
 679         Just (Label l) -> l
 680         _other -> BlockId (newTagUnique (getUnique name) 'L')
 681
 682 -- Unknown names are treated as if they had been 'import'ed.
 683 -- This saves us a lot of bother in the RTS sources, at the expense of
 684 -- deferring some errors to link time.
 685 lookupName :: FastString -> ExtFCode CmmExpr
 686 lookupName name = do
 687   env <- getEnv
 688   return $
 689      case lookupUFM env name of
 690         Just (Var e) -> e
 691         _other -> CmmLit (CmmLabel (mkRtsCodeLabelFS name))
 692
 693 -- Lifting FCode computations into the ExtFCode monad:
 694 code :: FCode a -> ExtFCode a
 695 code fc = EC $ \e s -> do r <- fc; return (s, r)
 696
 697 code2 :: (FCode (Decls,b) -> FCode ((Decls,b),c))
 698          -> ExtFCode b -> ExtFCode c
 699 code2 f (EC ec) = EC $ \e s -> do ((s',b),c) <- f (ec e s); return (s',c)
 700
 701 nopEC = code nopC
 702 stmtEC stmt = code (stmtC stmt)
 703 stmtsEC stmts = code (stmtsC stmts)
 704 getCgStmtsEC = code2 getCgStmts'
 705
 706 forkLabelledCodeEC ec = do
 707   stmts <- getCgStmtsEC ec
 708   code (forkCgStmts stmts)
 709
 710 retInfo name size live_bits cl_type vector = do
 711   let liveness = smallLiveness (fromIntegral size) (fromIntegral live_bits)
 712       info_lbl = mkRtsRetInfoLabelFS name
 713       (info1,info2) = mkRetInfoTable info_lbl liveness NoC_SRT
 714                                 (fromIntegral cl_type) vector
 715   return (info_lbl, info1, info2)
 716
 717 stdInfo name ptrs nptrs srt_bitmap cl_type desc_str ty_str =
 718   basicInfo name (packHalfWordsCLit ptrs nptrs)
 719         srt_bitmap cl_type desc_str ty_str
 720
 721 basicInfo name layout srt_bitmap cl_type desc_str ty_str = do
 722   lit1 <- if opt_SccProfilingOn
 723                    then code $ mkStringCLit desc_str
 724                    else return (mkIntCLit 0)
 725   lit2 <- if opt_SccProfilingOn
 726                    then code $ mkStringCLit ty_str
 727                    else return (mkIntCLit 0)
 728   let info1 = mkStdInfoTable lit1 lit2 (fromIntegral cl_type)
 729                         (fromIntegral srt_bitmap)
 730                         layout
 731   return (mkRtsInfoLabelFS name, info1, [])
 732
 733 funInfo name ptrs nptrs cl_type desc_str ty_str fun_type = do
 734   (label,info1,_) <- stdInfo name ptrs nptrs 0{-srt_bitmap-}
 735                          cl_type desc_str ty_str
 736   let info2 = mkFunGenInfoExtraBits (fromIntegral fun_type) 0 zero zero zero
 737                 -- we leave most of the fields zero here.  This is only used
 738                 -- to generate the BCO info table in the RTS at the moment.
 739   return (label,info1,info2)
 740  where
 741    zero = mkIntCLit 0
 742
 743
 744 staticClosure :: FastString -> FastString -> [CmmLit] -> ExtCode
 745 staticClosure cl_label info payload
 746   = code $ emitDataLits (mkRtsDataLabelFS cl_label) lits
 747   where  lits = mkStaticClosure (mkRtsInfoLabelFS info) dontCareCCS payload [] [] []
 748
 749 foreignCall
 750         :: String
 751         -> [ExtFCode (CmmReg,MachHint)]
 752         -> ExtFCode CmmExpr
 753         -> [ExtFCode (CmmExpr,MachHint)]
 754         -> Maybe [GlobalReg] -> P ExtCode
 755 foreignCall "C" results_code expr_code args_code vols
 756   = return $ do
 757         results <- sequence results_code
 758         expr <- expr_code
 759         args <- sequence args_code
 760         code (emitForeignCall' PlayRisky results
 761                  (CmmForeignCall expr CCallConv) args vols)
 762 foreignCall conv _ _ _ _
 763   = fail ("unknown calling convention: " ++ conv)
 764
 765 primCall
 766         :: [ExtFCode (CmmReg,MachHint)]
 767         -> FastString
 768         -> [ExtFCode (CmmExpr,MachHint)]
 769         -> Maybe [GlobalReg] -> P ExtCode
 770 primCall results_code name args_code vols
 771   = case lookupUFM callishMachOps name of
 772         Nothing -> fail ("unknown primitive " ++ unpackFS name)
 773         Just p  -> return $ do
 774                 results <- sequence results_code
 775                 args <- sequence args_code
 776                 code (emitForeignCall' PlayRisky results (CmmPrim p) args vols)
 777
 778 doStore :: MachRep -> ExtFCode CmmExpr  -> ExtFCode CmmExpr -> ExtCode
 779 doStore rep addr_code val_code
 780   = do addr <- addr_code
 781        val <- val_code
 782         -- if the specified store type does not match the type of the expr
 783         -- on the rhs, then we insert a coercion that will cause the type
 784         -- mismatch to be flagged by cmm-lint.  If we don't do this, then
 785         -- the store will happen at the wrong type, and the error will not
 786         -- be noticed.
 787        let coerce_val
 788                 | cmmExprRep val /= rep = CmmMachOp (MO_U_Conv rep rep) [val]
 789                 | otherwise             = val
 790        stmtEC (CmmStore addr coerce_val)
 791
 792 -- Return an unboxed tuple.
 793 emitRetUT :: [(CgRep,CmmExpr)] -> Code
 794 emitRetUT args = do
 795   tickyUnboxedTupleReturn (length args)  -- TICK
 796   (sp, stmts) <- pushUnboxedTuple 0 args
 797   emitStmts stmts
 798   when (sp /= 0) $ stmtC (CmmAssign spReg (cmmRegOffW spReg (-sp)))
 799   stmtC (CmmJump (entryCode (CmmLoad (cmmRegOffW spReg sp) wordRep)) [])
 800
 801 -- -----------------------------------------------------------------------------
 802 -- If-then-else and boolean expressions
 803
 804 data BoolExpr
 805   = BoolExpr `BoolAnd` BoolExpr
 806   | BoolExpr `BoolOr`  BoolExpr
 807   | BoolNot BoolExpr
 808   | BoolTest CmmExpr
 809
 810 -- ToDo: smart constructors which simplify the boolean expression.
 811
 812 ifThenElse cond then_part else_part = do
 813      then_id <- code newLabelC
 814      join_id <- code newLabelC
 815      c <- cond
 816      emitCond c then_id
 817      else_part
 818      stmtEC (CmmBranch join_id)
 819      code (labelC then_id)
 820      then_part
 821      -- fall through to join
 822      code (labelC join_id)
 823
 824 -- 'emitCond cond true_id'  emits code to test whether the cond is true,
 825 -- branching to true_id if so, and falling through otherwise.
 826 emitCond (BoolTest e) then_id = do
 827   stmtEC (CmmCondBranch e then_id)
 828 emitCond (BoolNot (BoolTest (CmmMachOp op args))) then_id
 829   | Just op' <- maybeInvertComparison op
 830   = emitCond (BoolTest (CmmMachOp op' args)) then_id
 831 emitCond (BoolNot e) then_id = do
 832   else_id <- code newLabelC
 833   emitCond e else_id
 834   stmtEC (CmmBranch then_id)
 835   code (labelC else_id)
 836 emitCond (e1 `BoolOr` e2) then_id = do
 837   emitCond e1 then_id
 838   emitCond e2 then_id
 839 emitCond (e1 `BoolAnd` e2) then_id = do
 840         -- we'd like to invert one of the conditionals here to avoid an
 841         -- extra branch instruction, but we can't use maybeInvertComparison
 842         -- here because we can't look too closely at the expression since
 843         -- we're in a loop.
 844   and_id <- code newLabelC
 845   else_id <- code newLabelC
 846   emitCond e1 and_id
 847   stmtEC (CmmBranch else_id)
 848   code (labelC and_id)
 849   emitCond e2 then_id
 850   code (labelC else_id)
 851
 852
 853 -- -----------------------------------------------------------------------------
 854 -- Table jumps
 855
 856 -- We use a simplified form of C-- switch statements for now.  A
 857 -- switch statement always compiles to a table jump.  Each arm can
 858 -- specify a list of values (not ranges), and there can be a single
 859 -- default branch.  The range of the table is given either by the
 860 -- optional range on the switch (eg. switch [0..7] {...}), or by
 861 -- the minimum/maximum values from the branches.
 862
 863 doSwitch :: Maybe (Int,Int) -> ExtFCode CmmExpr -> [([Int],ExtCode)]
 864          -> Maybe ExtCode -> ExtCode
 865 doSwitch mb_range scrut arms deflt
 866    = do
 867         -- Compile code for the default branch
 868         dflt_entry <-
 869                 case deflt of
 870                   Nothing -> return Nothing
 871                   Just e  -> do b <- forkLabelledCodeEC e; return (Just b)
 872
 873         -- Compile each case branch
 874         table_entries <- mapM emitArm arms
 875
 876         -- Construct the table
 877         let
 878             all_entries = concat table_entries
 879             ixs = map fst all_entries
 880             (min,max)
 881                 | Just (l,u) <- mb_range = (l,u)
 882                 | otherwise              = (minimum ixs, maximum ixs)
 883
 884             entries = elems (accumArray (\_ a -> Just a) dflt_entry (min,max)
 885                                 all_entries)
 886         expr <- scrut
 887         -- ToDo: check for out of range and jump to default if necessary
 888         stmtEC (CmmSwitch expr entries)
 889    where
 890         emitArm :: ([Int],ExtCode) -> ExtFCode [(Int,BlockId)]
 891         emitArm (ints,code) = do
 892            blockid <- forkLabelledCodeEC code
 893            return [ (i,blockid) | i <- ints ]
 894
 895
 896 -- -----------------------------------------------------------------------------
 897 -- Putting it all together
 898
 899 -- The initial environment: we define some constants that the compiler
 900 -- knows about here.
 901 initEnv :: Env
 902 initEnv = listToUFM [
 903   ( FSLIT("SIZEOF_StgHeader"),
 904     Var (CmmLit (CmmInt (fromIntegral (fixedHdrSize * wORD_SIZE)) wordRep) )),
 905   ( FSLIT("SIZEOF_StgInfoTable"),
 906     Var (CmmLit (CmmInt (fromIntegral stdInfoTableSizeB) wordRep) ))
 907   ]
 908
 909 parseCmmFile :: DynFlags -> FilePath -> IO (Maybe Cmm)
 910 parseCmmFile dflags filename = do
 911   showPass dflags "ParseCmm"
 912   buf <- hGetStringBuffer filename
 913   let
 914         init_loc = mkSrcLoc (mkFastString filename) 1 0
 915         init_state = (mkPState buf init_loc dflags) { lex_state = [0] }
 916                 -- reset the lex_state: the Lexer monad leaves some stuff
 917                 -- in there we don't want.
 918   case unP cmmParse init_state of
 919     PFailed span err -> do printError span err; return Nothing
 920     POk _ code -> do
 921         cmm <- initC dflags no_module (getCmm (unEC code initEnv [] >> return ()))
 922         dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (pprCmms [cmm])
 923         return (Just cmm)
 924   where
 925         no_module = panic "parseCmmFile: no module"
 926 }