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 "relrodata" = RelocatableReadOnlyData
 428 section "bss"    = UninitialisedData
 429 section s        = OtherSection s
 430
 431 mkString :: String -> CmmStatic
 432 mkString s = CmmString (map (fromIntegral.ord) s)
 433
 434 -- mkMachOp infers the type of the MachOp from the type of its first
 435 -- argument.  We assume that this is correct: for MachOps that don't have
 436 -- symmetrical args (e.g. shift ops), the first arg determines the type of
 437 -- the op.
 438 mkMachOp :: (MachRep -> MachOp) -> [ExtFCode CmmExpr] -> ExtFCode CmmExpr
 439 mkMachOp fn args = do
 440   arg_exprs <- sequence args
 441   return (CmmMachOp (fn (cmmExprRep (head arg_exprs))) arg_exprs)
 442
 443 getLit :: CmmExpr -> CmmLit
 444 getLit (CmmLit l) = l
 445 getLit (CmmMachOp (MO_S_Neg _) [CmmLit (CmmInt i r)])  = CmmInt (negate i) r
 446 getLit _ = panic "invalid literal" -- TODO messy failure
 447
 448 nameToMachOp :: FastString -> P (MachRep -> MachOp)
 449 nameToMachOp name =
 450   case lookupUFM machOps name of
 451         Nothing -> fail ("unknown primitive " ++ unpackFS name)
 452         Just m  -> return m
 453
 454 exprOp :: FastString -> [ExtFCode CmmExpr] -> P (ExtFCode CmmExpr)
 455 exprOp name args_code =
 456   case lookupUFM exprMacros name of
 457      Just f  -> return $ do
 458         args <- sequence args_code
 459         return (f args)
 460      Nothing -> do
 461         mo <- nameToMachOp name
 462         return $ mkMachOp mo args_code
 463
 464 exprMacros :: UniqFM ([CmmExpr] -> CmmExpr)
 465 exprMacros = listToUFM [
 466   ( FSLIT("ENTRY_CODE"),   \ [x] -> entryCode x ),
 467   ( FSLIT("INFO_PTR"),     \ [x] -> closureInfoPtr x ),
 468   ( FSLIT("STD_INFO"),     \ [x] -> infoTable x ),
 469   ( FSLIT("FUN_INFO"),     \ [x] -> funInfoTable x ),
 470   ( FSLIT("GET_ENTRY"),    \ [x] -> entryCode (closureInfoPtr x) ),
 471   ( FSLIT("GET_STD_INFO"), \ [x] -> infoTable (closureInfoPtr x) ),
 472   ( FSLIT("GET_FUN_INFO"), \ [x] -> funInfoTable (closureInfoPtr x) ),
 473   ( FSLIT("INFO_TYPE"),    \ [x] -> infoTableClosureType x ),
 474   ( FSLIT("INFO_PTRS"),    \ [x] -> infoTablePtrs x ),
 475   ( FSLIT("INFO_NPTRS"),   \ [x] -> infoTableNonPtrs x ),
 476   ( FSLIT("RET_VEC"),      \ [info, conZ] -> retVec info conZ )
 477   ]
 478
 479 -- we understand a subset of C-- primitives:
 480 machOps = listToUFM $
 481         map (\(x, y) -> (mkFastString x, y)) [
 482         ( "add",        MO_Add ),
 483         ( "sub",        MO_Sub ),
 484         ( "eq",         MO_Eq ),
 485         ( "ne",         MO_Ne ),
 486         ( "mul",        MO_Mul ),
 487         ( "neg",        MO_S_Neg ),
 488         ( "quot",       MO_S_Quot ),
 489         ( "rem",        MO_S_Rem ),
 490         ( "divu",       MO_U_Quot ),
 491         ( "modu",       MO_U_Rem ),
 492
 493         ( "ge",         MO_S_Ge ),
 494         ( "le",         MO_S_Le ),
 495         ( "gt",         MO_S_Gt ),
 496         ( "lt",         MO_S_Lt ),
 497
 498         ( "geu",        MO_U_Ge ),
 499         ( "leu",        MO_U_Le ),
 500         ( "gtu",        MO_U_Gt ),
 501         ( "ltu",        MO_U_Lt ),
 502
 503         ( "flt",        MO_S_Lt ),
 504         ( "fle",        MO_S_Le ),
 505         ( "feq",        MO_Eq ),
 506         ( "fne",        MO_Ne ),
 507         ( "fgt",        MO_S_Gt ),
 508         ( "fge",        MO_S_Ge ),
 509         ( "fneg",       MO_S_Neg ),
 510
 511         ( "and",        MO_And ),
 512         ( "or",         MO_Or ),
 513         ( "xor",        MO_Xor ),
 514         ( "com",        MO_Not ),
 515         ( "shl",        MO_Shl ),
 516         ( "shrl",       MO_U_Shr ),
 517         ( "shra",       MO_S_Shr ),
 518
 519         ( "lobits8",  flip MO_U_Conv I8  ),
 520         ( "lobits16", flip MO_U_Conv I16 ),
 521         ( "lobits32", flip MO_U_Conv I32 ),
 522         ( "lobits64", flip MO_U_Conv I64 ),
 523         ( "sx16",     flip MO_S_Conv I16 ),
 524         ( "sx32",     flip MO_S_Conv I32 ),
 525         ( "sx64",     flip MO_S_Conv I64 ),
 526         ( "zx16",     flip MO_U_Conv I16 ),
 527         ( "zx32",     flip MO_U_Conv I32 ),
 528         ( "zx64",     flip MO_U_Conv I64 ),
 529         ( "f2f32",    flip MO_S_Conv F32 ),  -- TODO; rounding mode
 530         ( "f2f64",    flip MO_S_Conv F64 ),  -- TODO; rounding mode
 531         ( "f2i8",     flip MO_S_Conv I8 ),
 532         ( "f2i16",    flip MO_S_Conv I8 ),
 533         ( "f2i32",    flip MO_S_Conv I8 ),
 534         ( "f2i64",    flip MO_S_Conv I8 ),
 535         ( "i2f32",    flip MO_S_Conv F32 ),
 536         ( "i2f64",    flip MO_S_Conv F64 )
 537         ]
 538
 539 callishMachOps = listToUFM $
 540         map (\(x, y) -> (mkFastString x, y)) [
 541         ( "write_barrier", MO_WriteBarrier )
 542         -- ToDo: the rest, maybe
 543     ]
 544
 545 parseHint :: String -> P MachHint
 546 parseHint "ptr"    = return PtrHint
 547 parseHint "signed" = return SignedHint
 548 parseHint "float"  = return FloatHint
 549 parseHint str      = fail ("unrecognised hint: " ++ str)
 550
 551 -- labels are always pointers, so we might as well infer the hint
 552 inferHint :: CmmExpr -> MachHint
 553 inferHint (CmmLit (CmmLabel _)) = PtrHint
 554 inferHint (CmmReg (CmmGlobal g)) | isPtrGlobalReg g = PtrHint
 555 inferHint _ = NoHint
 556
 557 isPtrGlobalReg Sp               = True
 558 isPtrGlobalReg SpLim            = True
 559 isPtrGlobalReg Hp               = True
 560 isPtrGlobalReg HpLim            = True
 561 isPtrGlobalReg CurrentTSO       = True
 562 isPtrGlobalReg CurrentNursery   = True
 563 isPtrGlobalReg _                = False
 564
 565 happyError :: P a
 566 happyError = srcParseFail
 567
 568 -- -----------------------------------------------------------------------------
 569 -- Statement-level macros
 570
 571 stmtMacro :: FastString -> [ExtFCode CmmExpr] -> P ExtCode
 572 stmtMacro fun args_code = do
 573   case lookupUFM stmtMacros fun of
 574     Nothing -> fail ("unknown macro: " ++ unpackFS fun)
 575     Just fcode -> return $ do
 576         args <- sequence args_code
 577         code (fcode args)
 578
 579 stmtMacros :: UniqFM ([CmmExpr] -> Code)
 580 stmtMacros = listToUFM [
 581   ( FSLIT("CCS_ALLOC"),            \[words,ccs]  -> profAlloc words ccs ),
 582   ( FSLIT("CLOSE_NURSERY"),        \[]  -> emitCloseNursery ),
 583   ( FSLIT("ENTER_CCS_PAP_CL"),     \[e] -> enterCostCentrePAP e ),
 584   ( FSLIT("ENTER_CCS_THUNK"),      \[e] -> enterCostCentreThunk e ),
 585   ( FSLIT("HP_CHK_GEN"),           \[words,liveness,reentry] ->
 586                                       hpChkGen words liveness reentry ),
 587   ( FSLIT("HP_CHK_NP_ASSIGN_SP0"), \[e,f] -> hpChkNodePointsAssignSp0 e f ),
 588   ( FSLIT("LOAD_THREAD_STATE"),    \[] -> emitLoadThreadState ),
 589   ( FSLIT("LDV_ENTER"),            \[e] -> ldvEnter e ),
 590   ( FSLIT("LDV_RECORD_CREATE"),    \[e] -> ldvRecordCreate e ),
 591   ( FSLIT("OPEN_NURSERY"),         \[]  -> emitOpenNursery ),
 592   ( FSLIT("PUSH_UPD_FRAME"),       \[sp,e] -> emitPushUpdateFrame sp e ),
 593   ( FSLIT("SAVE_THREAD_STATE"),    \[] -> emitSaveThreadState ),
 594   ( FSLIT("SET_HDR"),              \[ptr,info,ccs] ->
 595                                         emitSetDynHdr ptr info ccs ),
 596   ( FSLIT("STK_CHK_GEN"),          \[words,liveness,reentry] ->
 597                                       stkChkGen words liveness reentry ),
 598   ( FSLIT("STK_CHK_NP"),           \[e] -> stkChkNodePoints e ),
 599   ( FSLIT("TICK_ALLOC_PRIM"),      \[hdr,goods,slop] ->
 600                                         tickyAllocPrim hdr goods slop ),
 601   ( FSLIT("TICK_ALLOC_PAP"),       \[goods,slop] ->
 602                                         tickyAllocPAP goods slop ),
 603   ( FSLIT("TICK_ALLOC_UP_THK"),    \[goods,slop] ->
 604                                         tickyAllocThunk goods slop ),
 605   ( FSLIT("UPD_BH_UPDATABLE"),       \[] -> emitBlackHoleCode False ),
 606   ( FSLIT("UPD_BH_SINGLE_ENTRY"),    \[] -> emitBlackHoleCode True ),
 607
 608   ( FSLIT("RET_P"),     \[a] ->       emitRetUT [(PtrArg,a)]),
 609   ( FSLIT("RET_N"),     \[a] ->       emitRetUT [(NonPtrArg,a)]),
 610   ( FSLIT("RET_PP"),    \[a,b] ->     emitRetUT [(PtrArg,a),(PtrArg,b)]),
 611   ( FSLIT("RET_NN"),    \[a,b] ->     emitRetUT [(NonPtrArg,a),(NonPtrArg,b)]),
 612   ( FSLIT("RET_NP"),    \[a,b] ->     emitRetUT [(NonPtrArg,a),(PtrArg,b)]),
 613   ( FSLIT("RET_PPP"),   \[a,b,c] ->   emitRetUT [(PtrArg,a),(PtrArg,b),(PtrArg,c)]),
 614   ( FSLIT("RET_NNP"),   \[a,b,c] ->   emitRetUT [(NonPtrArg,a),(NonPtrArg,b),(PtrArg,c)]),
 615   ( FSLIT("RET_NNNP"),  \[a,b,c,d] -> emitRetUT [(NonPtrArg,a),(NonPtrArg,b),(NonPtrArg,c),(PtrArg,d)]),
 616   ( FSLIT("RET_NPNP"),  \[a,b,c,d] -> emitRetUT [(NonPtrArg,a),(PtrArg,b),(NonPtrArg,c),(PtrArg,d)])
 617
 618  ]
 619
 620 -- -----------------------------------------------------------------------------
 621 -- Our extended FCode monad.
 622
 623 -- We add a mapping from names to CmmExpr, to support local variable names in
 624 -- the concrete C-- code.  The unique supply of the underlying FCode monad
 625 -- is used to grab a new unique for each local variable.
 626
 627 -- In C--, a local variable can be declared anywhere within a proc,
 628 -- and it scopes from the beginning of the proc to the end.  Hence, we have
 629 -- to collect declarations as we parse the proc, and feed the environment
 630 -- back in circularly (to avoid a two-pass algorithm).
 631
 632 data Named = Var CmmExpr | Label BlockId
 633 type Decls = [(FastString,Named)]
 634 type Env   = UniqFM Named
 635
 636 newtype ExtFCode a = EC { unEC :: Env -> Decls -> FCode (Decls, a) }
 637
 638 type ExtCode = ExtFCode ()
 639
 640 returnExtFC a = EC $ \e s -> return (s, a)
 641 thenExtFC (EC m) k = EC $ \e s -> do (s',r) <- m e s; unEC (k r) e s'
 642
 643 instance Monad ExtFCode where
 644   (>>=) = thenExtFC
 645   return = returnExtFC
 646
 647 -- This function takes the variable decarations and imports and makes
 648 -- an environment, which is looped back into the computation.  In this
 649 -- way, we can have embedded declarations that scope over the whole
 650 -- procedure, and imports that scope over the entire module.
 651 loopDecls :: ExtFCode a -> ExtFCode a
 652 loopDecls (EC fcode) =
 653    EC $ \e s -> fixC (\ ~(decls,a) -> fcode (addListToUFM e decls) [])
 654
 655 getEnv :: ExtFCode Env
 656 getEnv = EC $ \e s -> return (s, e)
 657
 658 addVarDecl :: FastString -> CmmExpr -> ExtCode
 659 addVarDecl var expr = EC $ \e s -> return ((var, Var expr):s, ())
 660
 661 addLabel :: FastString -> BlockId -> ExtCode
 662 addLabel name block_id = EC $ \e s -> return ((name, Label block_id):s, ())
 663
 664 newLocal :: MachRep -> FastString -> ExtCode
 665 newLocal ty name  = do
 666    u <- code newUnique
 667    addVarDecl name (CmmReg (CmmLocal (LocalReg u ty)))
 668
 669 newLabel :: FastString -> ExtFCode BlockId
 670 newLabel name = do
 671    u <- code newUnique
 672    addLabel name (BlockId u)
 673    return (BlockId u)
 674
 675 lookupLabel :: FastString -> ExtFCode BlockId
 676 lookupLabel name = do
 677   env <- getEnv
 678   return $
 679      case lookupUFM env name of
 680         Just (Label l) -> l
 681         _other -> BlockId (newTagUnique (getUnique name) 'L')
 682
 683 -- Unknown names are treated as if they had been 'import'ed.
 684 -- This saves us a lot of bother in the RTS sources, at the expense of
 685 -- deferring some errors to link time.
 686 lookupName :: FastString -> ExtFCode CmmExpr
 687 lookupName name = do
 688   env <- getEnv
 689   return $
 690      case lookupUFM env name of
 691         Just (Var e) -> e
 692         _other -> CmmLit (CmmLabel (mkRtsCodeLabelFS name))
 693
 694 -- Lifting FCode computations into the ExtFCode monad:
 695 code :: FCode a -> ExtFCode a
 696 code fc = EC $ \e s -> do r <- fc; return (s, r)
 697
 698 code2 :: (FCode (Decls,b) -> FCode ((Decls,b),c))
 699          -> ExtFCode b -> ExtFCode c
 700 code2 f (EC ec) = EC $ \e s -> do ((s',b),c) <- f (ec e s); return (s',c)
 701
 702 nopEC = code nopC
 703 stmtEC stmt = code (stmtC stmt)
 704 stmtsEC stmts = code (stmtsC stmts)
 705 getCgStmtsEC = code2 getCgStmts'
 706
 707 forkLabelledCodeEC ec = do
 708   stmts <- getCgStmtsEC ec
 709   code (forkCgStmts stmts)
 710
 711 retInfo name size live_bits cl_type vector = do
 712   let liveness = smallLiveness (fromIntegral size) (fromIntegral live_bits)
 713       info_lbl = mkRtsRetInfoLabelFS name
 714       (info1,info2) = mkRetInfoTable info_lbl liveness NoC_SRT
 715                                 (fromIntegral cl_type) vector
 716   return (info_lbl, info1, info2)
 717
 718 stdInfo name ptrs nptrs srt_bitmap cl_type desc_str ty_str =
 719   basicInfo name (packHalfWordsCLit ptrs nptrs)
 720         srt_bitmap cl_type desc_str ty_str
 721
 722 basicInfo name layout srt_bitmap cl_type desc_str ty_str = do
 723   lit1 <- if opt_SccProfilingOn
 724                    then code $ mkStringCLit desc_str
 725                    else return (mkIntCLit 0)
 726   lit2 <- if opt_SccProfilingOn
 727                    then code $ mkStringCLit ty_str
 728                    else return (mkIntCLit 0)
 729   let info1 = mkStdInfoTable lit1 lit2 (fromIntegral cl_type)
 730                         (fromIntegral srt_bitmap)
 731                         layout
 732   return (mkRtsInfoLabelFS name, info1, [])
 733
 734 funInfo name ptrs nptrs cl_type desc_str ty_str fun_type = do
 735   (label,info1,_) <- stdInfo name ptrs nptrs 0{-srt_bitmap-}
 736                          cl_type desc_str ty_str
 737   let info2 = mkFunGenInfoExtraBits (fromIntegral fun_type) 0 zero zero zero
 738                 -- we leave most of the fields zero here.  This is only used
 739                 -- to generate the BCO info table in the RTS at the moment.
 740   return (label,info1,info2)
 741  where
 742    zero = mkIntCLit 0
 743
 744
 745 staticClosure :: FastString -> FastString -> [CmmLit] -> ExtCode
 746 staticClosure cl_label info payload
 747   = code $ emitDataLits (mkRtsDataLabelFS cl_label) lits
 748   where  lits = mkStaticClosure (mkRtsInfoLabelFS info) dontCareCCS payload [] [] []
 749
 750 foreignCall
 751         :: String
 752         -> [ExtFCode (CmmReg,MachHint)]
 753         -> ExtFCode CmmExpr
 754         -> [ExtFCode (CmmExpr,MachHint)]
 755         -> Maybe [GlobalReg] -> P ExtCode
 756 foreignCall "C" results_code expr_code args_code vols
 757   = return $ do
 758         results <- sequence results_code
 759         expr <- expr_code
 760         args <- sequence args_code
 761         code (emitForeignCall' PlayRisky results
 762                  (CmmForeignCall expr CCallConv) args vols)
 763 foreignCall conv _ _ _ _
 764   = fail ("unknown calling convention: " ++ conv)
 765
 766 primCall
 767         :: [ExtFCode (CmmReg,MachHint)]
 768         -> FastString
 769         -> [ExtFCode (CmmExpr,MachHint)]
 770         -> Maybe [GlobalReg] -> P ExtCode
 771 primCall results_code name args_code vols
 772   = case lookupUFM callishMachOps name of
 773         Nothing -> fail ("unknown primitive " ++ unpackFS name)
 774         Just p  -> return $ do
 775                 results <- sequence results_code
 776                 args <- sequence args_code
 777                 code (emitForeignCall' PlayRisky results (CmmPrim p) args vols)
 778
 779 doStore :: MachRep -> ExtFCode CmmExpr  -> ExtFCode CmmExpr -> ExtCode
 780 doStore rep addr_code val_code
 781   = do addr <- addr_code
 782        val <- val_code
 783         -- if the specified store type does not match the type of the expr
 784         -- on the rhs, then we insert a coercion that will cause the type
 785         -- mismatch to be flagged by cmm-lint.  If we don't do this, then
 786         -- the store will happen at the wrong type, and the error will not
 787         -- be noticed.
 788        let coerce_val
 789                 | cmmExprRep val /= rep = CmmMachOp (MO_U_Conv rep rep) [val]
 790                 | otherwise             = val
 791        stmtEC (CmmStore addr coerce_val)
 792
 793 -- Return an unboxed tuple.
 794 emitRetUT :: [(CgRep,CmmExpr)] -> Code
 795 emitRetUT args = do
 796   tickyUnboxedTupleReturn (length args)  -- TICK
 797   (sp, stmts) <- pushUnboxedTuple 0 args
 798   emitStmts stmts
 799   when (sp /= 0) $ stmtC (CmmAssign spReg (cmmRegOffW spReg (-sp)))
 800   stmtC (CmmJump (entryCode (CmmLoad (cmmRegOffW spReg sp) wordRep)) [])
 801
 802 -- -----------------------------------------------------------------------------
 803 -- If-then-else and boolean expressions
 804
 805 data BoolExpr
 806   = BoolExpr `BoolAnd` BoolExpr
 807   | BoolExpr `BoolOr`  BoolExpr
 808   | BoolNot BoolExpr
 809   | BoolTest CmmExpr
 810
 811 -- ToDo: smart constructors which simplify the boolean expression.
 812
 813 ifThenElse cond then_part else_part = do
 814      then_id <- code newLabelC
 815      join_id <- code newLabelC
 816      c <- cond
 817      emitCond c then_id
 818      else_part
 819      stmtEC (CmmBranch join_id)
 820      code (labelC then_id)
 821      then_part
 822      -- fall through to join
 823      code (labelC join_id)
 824
 825 -- 'emitCond cond true_id'  emits code to test whether the cond is true,
 826 -- branching to true_id if so, and falling through otherwise.
 827 emitCond (BoolTest e) then_id = do
 828   stmtEC (CmmCondBranch e then_id)
 829 emitCond (BoolNot (BoolTest (CmmMachOp op args))) then_id
 830   | Just op' <- maybeInvertComparison op
 831   = emitCond (BoolTest (CmmMachOp op' args)) then_id
 832 emitCond (BoolNot e) then_id = do
 833   else_id <- code newLabelC
 834   emitCond e else_id
 835   stmtEC (CmmBranch then_id)
 836   code (labelC else_id)
 837 emitCond (e1 `BoolOr` e2) then_id = do
 838   emitCond e1 then_id
 839   emitCond e2 then_id
 840 emitCond (e1 `BoolAnd` e2) then_id = do
 841         -- we'd like to invert one of the conditionals here to avoid an
 842         -- extra branch instruction, but we can't use maybeInvertComparison
 843         -- here because we can't look too closely at the expression since
 844         -- we're in a loop.
 845   and_id <- code newLabelC
 846   else_id <- code newLabelC
 847   emitCond e1 and_id
 848   stmtEC (CmmBranch else_id)
 849   code (labelC and_id)
 850   emitCond e2 then_id
 851   code (labelC else_id)
 852
 853
 854 -- -----------------------------------------------------------------------------
 855 -- Table jumps
 856
 857 -- We use a simplified form of C-- switch statements for now.  A
 858 -- switch statement always compiles to a table jump.  Each arm can
 859 -- specify a list of values (not ranges), and there can be a single
 860 -- default branch.  The range of the table is given either by the
 861 -- optional range on the switch (eg. switch [0..7] {...}), or by
 862 -- the minimum/maximum values from the branches.
 863
 864 doSwitch :: Maybe (Int,Int) -> ExtFCode CmmExpr -> [([Int],ExtCode)]
 865          -> Maybe ExtCode -> ExtCode
 866 doSwitch mb_range scrut arms deflt
 867    = do
 868         -- Compile code for the default branch
 869         dflt_entry <-
 870                 case deflt of
 871                   Nothing -> return Nothing
 872                   Just e  -> do b <- forkLabelledCodeEC e; return (Just b)
 873
 874         -- Compile each case branch
 875         table_entries <- mapM emitArm arms
 876
 877         -- Construct the table
 878         let
 879             all_entries = concat table_entries
 880             ixs = map fst all_entries
 881             (min,max)
 882                 | Just (l,u) <- mb_range = (l,u)
 883                 | otherwise              = (minimum ixs, maximum ixs)
 884
 885             entries = elems (accumArray (\_ a -> Just a) dflt_entry (min,max)
 886                                 all_entries)
 887         expr <- scrut
 888         -- ToDo: check for out of range and jump to default if necessary
 889         stmtEC (CmmSwitch expr entries)
 890    where
 891         emitArm :: ([Int],ExtCode) -> ExtFCode [(Int,BlockId)]
 892         emitArm (ints,code) = do
 893            blockid <- forkLabelledCodeEC code
 894            return [ (i,blockid) | i <- ints ]
 895
 896
 897 -- -----------------------------------------------------------------------------
 898 -- Putting it all together
 899
 900 -- The initial environment: we define some constants that the compiler
 901 -- knows about here.
 902 initEnv :: Env
 903 initEnv = listToUFM [
 904   ( FSLIT("SIZEOF_StgHeader"),
 905     Var (CmmLit (CmmInt (fromIntegral (fixedHdrSize * wORD_SIZE)) wordRep) )),
 906   ( FSLIT("SIZEOF_StgInfoTable"),
 907     Var (CmmLit (CmmInt (fromIntegral stdInfoTableSizeB) wordRep) ))
 908   ]
 909
 910 parseCmmFile :: DynFlags -> FilePath -> IO (Maybe Cmm)
 911 parseCmmFile dflags filename = do
 912   showPass dflags "ParseCmm"
 913   buf <- hGetStringBuffer filename
 914   let
 915         init_loc = mkSrcLoc (mkFastString filename) 1 0
 916         init_state = (mkPState buf init_loc dflags) { lex_state = [0] }
 917                 -- reset the lex_state: the Lexer monad leaves some stuff
 918                 -- in there we don't want.
 919   case unP cmmParse init_state of
 920     PFailed span err -> do printError span err; return Nothing
 921     POk _ code -> do
 922         cmm <- initC dflags no_module (getCmm (unEC code initEnv [] >> return ()))
 923         dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (pprCmms [cmm])
 924         return (Just cmm)
 925   where
 926         no_module = panic "parseCmmFile: no module"
 927 }