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