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