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_NNP"),   \[a,b,c] ->   emitRetUT [(NonPtrArg,a),(NonPtrArg,b),(PtrArg,c)]),
 611   ( FSLIT("RET_NNNP"),  \[a,b,c,d] -> emitRetUT [(NonPtrArg,a),(NonPtrArg,b),(NonPtrArg,c),(PtrArg,d)]),
 612   ( FSLIT("RET_NPNP"),  \[a,b,c,d] -> emitRetUT [(NonPtrArg,a),(PtrArg,b),(NonPtrArg,c),(PtrArg,d)])
 613
 614  ]
 615
 616 -- -----------------------------------------------------------------------------
 617 -- Our extended FCode monad.
 618
 619 -- We add a mapping from names to CmmExpr, to support local variable names in
 620 -- the concrete C-- code.  The unique supply of the underlying FCode monad
 621 -- is used to grab a new unique for each local variable.
 622
 623 -- In C--, a local variable can be declared anywhere within a proc,
 624 -- and it scopes from the beginning of the proc to the end.  Hence, we have
 625 -- to collect declarations as we parse the proc, and feed the environment
 626 -- back in circularly (to avoid a two-pass algorithm).
 627
 628 data Named = Var CmmExpr | Label BlockId
 629 type Decls = [(FastString,Named)]
 630 type Env   = UniqFM Named
 631
 632 newtype ExtFCode a = EC { unEC :: Env -> Decls -> FCode (Decls, a) }
 633
 634 type ExtCode = ExtFCode ()
 635
 636 returnExtFC a = EC $ \e s -> return (s, a)
 637 thenExtFC (EC m) k = EC $ \e s -> do (s',r) <- m e s; unEC (k r) e s'
 638
 639 instance Monad ExtFCode where
 640   (>>=) = thenExtFC
 641   return = returnExtFC
 642
 643 -- This function takes the variable decarations and imports and makes
 644 -- an environment, which is looped back into the computation.  In this
 645 -- way, we can have embedded declarations that scope over the whole
 646 -- procedure, and imports that scope over the entire module.
 647 loopDecls :: ExtFCode a -> ExtFCode a
 648 loopDecls (EC fcode) =
 649    EC $ \e s -> fixC (\ ~(decls,a) -> fcode (addListToUFM e decls) [])
 650
 651 getEnv :: ExtFCode Env
 652 getEnv = EC $ \e s -> return (s, e)
 653
 654 addVarDecl :: FastString -> CmmExpr -> ExtCode
 655 addVarDecl var expr = EC $ \e s -> return ((var, Var expr):s, ())
 656
 657 addLabel :: FastString -> BlockId -> ExtCode
 658 addLabel name block_id = EC $ \e s -> return ((name, Label block_id):s, ())
 659
 660 newLocal :: MachRep -> FastString -> ExtCode
 661 newLocal ty name  = do
 662    u <- code newUnique
 663    addVarDecl name (CmmReg (CmmLocal (LocalReg u ty)))
 664
 665 newLabel :: FastString -> ExtFCode BlockId
 666 newLabel name = do
 667    u <- code newUnique
 668    addLabel name (BlockId u)
 669    return (BlockId u)
 670
 671 lookupLabel :: FastString -> ExtFCode BlockId
 672 lookupLabel name = do
 673   env <- getEnv
 674   return $
 675      case lookupUFM env name of
 676         Just (Label l) -> l
 677         _other -> BlockId (newTagUnique (getUnique name) 'L')
 678
 679 -- Unknown names are treated as if they had been 'import'ed.
 680 -- This saves us a lot of bother in the RTS sources, at the expense of
 681 -- deferring some errors to link time.
 682 lookupName :: FastString -> ExtFCode CmmExpr
 683 lookupName name = do
 684   env <- getEnv
 685   return $
 686      case lookupUFM env name of
 687         Just (Var e) -> e
 688         _other -> CmmLit (CmmLabel (mkRtsCodeLabelFS name))
 689
 690 -- Lifting FCode computations into the ExtFCode monad:
 691 code :: FCode a -> ExtFCode a
 692 code fc = EC $ \e s -> do r <- fc; return (s, r)
 693
 694 code2 :: (FCode (Decls,b) -> FCode ((Decls,b),c))
 695          -> ExtFCode b -> ExtFCode c
 696 code2 f (EC ec) = EC $ \e s -> do ((s',b),c) <- f (ec e s); return (s',c)
 697
 698 nopEC = code nopC
 699 stmtEC stmt = code (stmtC stmt)
 700 stmtsEC stmts = code (stmtsC stmts)
 701 getCgStmtsEC = code2 getCgStmts'
 702
 703 forkLabelledCodeEC ec = do
 704   stmts <- getCgStmtsEC ec
 705   code (forkCgStmts stmts)
 706
 707 retInfo name size live_bits cl_type = do
 708   let liveness = smallLiveness (fromIntegral size) (fromIntegral live_bits)
 709       info_lbl = mkRtsRetInfoLabelFS name
 710       (info1,info2) = mkRetInfoTable info_lbl liveness NoC_SRT
 711                                 (fromIntegral cl_type)
 712   return (info_lbl, info1, info2)
 713
 714 stdInfo name ptrs nptrs srt_bitmap cl_type desc_str ty_str =
 715   basicInfo name (packHalfWordsCLit ptrs nptrs)
 716         srt_bitmap cl_type desc_str ty_str
 717
 718 basicInfo name layout srt_bitmap cl_type desc_str ty_str = do
 719   lit1 <- if opt_SccProfilingOn
 720                    then code $ mkStringCLit desc_str
 721                    else return (mkIntCLit 0)
 722   lit2 <- if opt_SccProfilingOn
 723                    then code $ mkStringCLit ty_str
 724                    else return (mkIntCLit 0)
 725   let info1 = mkStdInfoTable lit1 lit2 (fromIntegral cl_type)
 726                         (fromIntegral srt_bitmap)
 727                         layout
 728   return (mkRtsInfoLabelFS name, info1, [])
 729
 730 funInfo name ptrs nptrs cl_type desc_str ty_str fun_type = do
 731   (label,info1,_) <- stdInfo name ptrs nptrs 0{-srt_bitmap-}
 732                          cl_type desc_str ty_str
 733   let info2 = mkFunGenInfoExtraBits (fromIntegral fun_type) 0 zero zero zero
 734                 -- we leave most of the fields zero here.  This is only used
 735                 -- to generate the BCO info table in the RTS at the moment.
 736   return (label,info1,info2)
 737  where
 738    zero = mkIntCLit 0
 739
 740
 741 staticClosure :: FastString -> FastString -> [CmmLit] -> ExtCode
 742 staticClosure cl_label info payload
 743   = code $ emitDataLits (mkRtsDataLabelFS cl_label) lits
 744   where  lits = mkStaticClosure (mkRtsInfoLabelFS info) dontCareCCS payload [] [] []
 745
 746 foreignCall
 747         :: String
 748         -> [ExtFCode (CmmReg,MachHint)]
 749         -> ExtFCode CmmExpr
 750         -> [ExtFCode (CmmExpr,MachHint)]
 751         -> Maybe [GlobalReg] -> P ExtCode
 752 foreignCall "C" results_code expr_code args_code vols
 753   = return $ do
 754         results <- sequence results_code
 755         expr <- expr_code
 756         args <- sequence args_code
 757         code (emitForeignCall' PlayRisky results
 758                  (CmmForeignCall expr CCallConv) args vols)
 759 foreignCall conv _ _ _ _
 760   = fail ("unknown calling convention: " ++ conv)
 761
 762 primCall
 763         :: [ExtFCode (CmmReg,MachHint)]
 764         -> FastString
 765         -> [ExtFCode (CmmExpr,MachHint)]
 766         -> Maybe [GlobalReg] -> P ExtCode
 767 primCall results_code name args_code vols
 768   = case lookupUFM callishMachOps name of
 769         Nothing -> fail ("unknown primitive " ++ unpackFS name)
 770         Just p  -> return $ do
 771                 results <- sequence results_code
 772                 args <- sequence args_code
 773                 code (emitForeignCall' PlayRisky results (CmmPrim p) args vols)
 774
 775 doStore :: MachRep -> ExtFCode CmmExpr  -> ExtFCode CmmExpr -> ExtCode
 776 doStore rep addr_code val_code
 777   = do addr <- addr_code
 778        val <- val_code
 779         -- if the specified store type does not match the type of the expr
 780         -- on the rhs, then we insert a coercion that will cause the type
 781         -- mismatch to be flagged by cmm-lint.  If we don't do this, then
 782         -- the store will happen at the wrong type, and the error will not
 783         -- be noticed.
 784        let coerce_val
 785                 | cmmExprRep val /= rep = CmmMachOp (MO_U_Conv rep rep) [val]
 786                 | otherwise             = val
 787        stmtEC (CmmStore addr coerce_val)
 788
 789 -- Return an unboxed tuple.
 790 emitRetUT :: [(CgRep,CmmExpr)] -> Code
 791 emitRetUT args = do
 792   tickyUnboxedTupleReturn (length args)  -- TICK
 793   (sp, stmts) <- pushUnboxedTuple 0 args
 794   emitStmts stmts
 795   when (sp /= 0) $ stmtC (CmmAssign spReg (cmmRegOffW spReg (-sp)))
 796   stmtC (CmmJump (entryCode (CmmLoad (cmmRegOffW spReg sp) wordRep)) [])
 797
 798 -- -----------------------------------------------------------------------------
 799 -- If-then-else and boolean expressions
 800
 801 data BoolExpr
 802   = BoolExpr `BoolAnd` BoolExpr
 803   | BoolExpr `BoolOr`  BoolExpr
 804   | BoolNot BoolExpr
 805   | BoolTest CmmExpr
 806
 807 -- ToDo: smart constructors which simplify the boolean expression.
 808
 809 ifThenElse cond then_part else_part = do
 810      then_id <- code newLabelC
 811      join_id <- code newLabelC
 812      c <- cond
 813      emitCond c then_id
 814      else_part
 815      stmtEC (CmmBranch join_id)
 816      code (labelC then_id)
 817      then_part
 818      -- fall through to join
 819      code (labelC join_id)
 820
 821 -- 'emitCond cond true_id'  emits code to test whether the cond is true,
 822 -- branching to true_id if so, and falling through otherwise.
 823 emitCond (BoolTest e) then_id = do
 824   stmtEC (CmmCondBranch e then_id)
 825 emitCond (BoolNot (BoolTest (CmmMachOp op args))) then_id
 826   | Just op' <- maybeInvertComparison op
 827   = emitCond (BoolTest (CmmMachOp op' args)) then_id
 828 emitCond (BoolNot e) then_id = do
 829   else_id <- code newLabelC
 830   emitCond e else_id
 831   stmtEC (CmmBranch then_id)
 832   code (labelC else_id)
 833 emitCond (e1 `BoolOr` e2) then_id = do
 834   emitCond e1 then_id
 835   emitCond e2 then_id
 836 emitCond (e1 `BoolAnd` e2) then_id = do
 837         -- we'd like to invert one of the conditionals here to avoid an
 838         -- extra branch instruction, but we can't use maybeInvertComparison
 839         -- here because we can't look too closely at the expression since
 840         -- we're in a loop.
 841   and_id <- code newLabelC
 842   else_id <- code newLabelC
 843   emitCond e1 and_id
 844   stmtEC (CmmBranch else_id)
 845   code (labelC and_id)
 846   emitCond e2 then_id
 847   code (labelC else_id)
 848
 849
 850 -- -----------------------------------------------------------------------------
 851 -- Table jumps
 852
 853 -- We use a simplified form of C-- switch statements for now.  A
 854 -- switch statement always compiles to a table jump.  Each arm can
 855 -- specify a list of values (not ranges), and there can be a single
 856 -- default branch.  The range of the table is given either by the
 857 -- optional range on the switch (eg. switch [0..7] {...}), or by
 858 -- the minimum/maximum values from the branches.
 859
 860 doSwitch :: Maybe (Int,Int) -> ExtFCode CmmExpr -> [([Int],ExtCode)]
 861          -> Maybe ExtCode -> ExtCode
 862 doSwitch mb_range scrut arms deflt
 863    = do
 864         -- Compile code for the default branch
 865         dflt_entry <-
 866                 case deflt of
 867                   Nothing -> return Nothing
 868                   Just e  -> do b <- forkLabelledCodeEC e; return (Just b)
 869
 870         -- Compile each case branch
 871         table_entries <- mapM emitArm arms
 872
 873         -- Construct the table
 874         let
 875             all_entries = concat table_entries
 876             ixs = map fst all_entries
 877             (min,max)
 878                 | Just (l,u) <- mb_range = (l,u)
 879                 | otherwise              = (minimum ixs, maximum ixs)
 880
 881             entries = elems (accumArray (\_ a -> Just a) dflt_entry (min,max)
 882                                 all_entries)
 883         expr <- scrut
 884         -- ToDo: check for out of range and jump to default if necessary
 885         stmtEC (CmmSwitch expr entries)
 886    where
 887         emitArm :: ([Int],ExtCode) -> ExtFCode [(Int,BlockId)]
 888         emitArm (ints,code) = do
 889            blockid <- forkLabelledCodeEC code
 890            return [ (i,blockid) | i <- ints ]
 891
 892
 893 -- -----------------------------------------------------------------------------
 894 -- Putting it all together
 895
 896 -- The initial environment: we define some constants that the compiler
 897 -- knows about here.
 898 initEnv :: Env
 899 initEnv = listToUFM [
 900   ( FSLIT("SIZEOF_StgHeader"),
 901     Var (CmmLit (CmmInt (fromIntegral (fixedHdrSize * wORD_SIZE)) wordRep) )),
 902   ( FSLIT("SIZEOF_StgInfoTable"),
 903     Var (CmmLit (CmmInt (fromIntegral stdInfoTableSizeB) wordRep) ))
 904   ]
 905
 906 parseCmmFile :: DynFlags -> FilePath -> IO (Maybe Cmm)
 907 parseCmmFile dflags filename = do
 908   showPass dflags "ParseCmm"
 909   buf <- hGetStringBuffer filename
 910   let
 911         init_loc = mkSrcLoc (mkFastString filename) 1 0
 912         init_state = (mkPState buf init_loc dflags) { lex_state = [0] }
 913                 -- reset the lex_state: the Lexer monad leaves some stuff
 914                 -- in there we don't want.
 915   case unP cmmParse init_state of
 916     PFailed span err -> do printError span err; return Nothing
 917     POk pst code -> do
 918         cmm <- initC dflags no_module (getCmm (unEC code initEnv [] >> return ()))
 919         let ms = getMessages pst
 920         printErrorsAndWarnings dflags ms
 921         when (errorsFound dflags ms) $ exitWith (ExitFailure 1)
 922         dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (pprCmms [cmm])
 923         return (Just cmm)
 924   where
 925         no_module = panic "parseCmmFile: no module"
 926 }