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                 { conInfo $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 I16 ),
 529         ( "f2i32",    flip MO_S_Conv I32 ),
 530         ( "f2i64",    flip MO_S_Conv I64 ),
 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 conInfo name ptrs nptrs srt_bitmap cl_type desc_str ty_str = do
 720   (lbl, info1, _) <- basicInfo name (packHalfWordsCLit ptrs nptrs)
 721                         srt_bitmap cl_type desc_str ty_str
 722   desc_lit <- code $ mkStringCLit desc_str
 723   let desc_field = makeRelativeRefTo lbl desc_lit
 724   return (lbl, info1, [desc_field])
 725
 726 basicInfo name layout srt_bitmap cl_type desc_str ty_str = do
 727   lit1 <- if opt_SccProfilingOn
 728                    then code $ mkStringCLit desc_str
 729                    else return (mkIntCLit 0)
 730   lit2 <- if opt_SccProfilingOn
 731                    then code $ mkStringCLit ty_str
 732                    else return (mkIntCLit 0)
 733   let info1 = mkStdInfoTable lit1 lit2 (fromIntegral cl_type)
 734                         (fromIntegral srt_bitmap)
 735                         layout
 736   return (mkRtsInfoLabelFS name, info1, [])
 737
 738 funInfo name ptrs nptrs cl_type desc_str ty_str fun_type = do
 739   (label,info1,_) <- stdInfo name ptrs nptrs 0{-srt_bitmap-}
 740                          cl_type desc_str ty_str
 741   let info2 = mkFunGenInfoExtraBits (fromIntegral fun_type) 0 zero zero zero
 742                 -- we leave most of the fields zero here.  This is only used
 743                 -- to generate the BCO info table in the RTS at the moment.
 744   return (label,info1,info2)
 745  where
 746    zero = mkIntCLit 0
 747
 748
 749 staticClosure :: FastString -> FastString -> [CmmLit] -> ExtCode
 750 staticClosure cl_label info payload
 751   = code $ emitDataLits (mkRtsDataLabelFS cl_label) lits
 752   where  lits = mkStaticClosure (mkRtsInfoLabelFS info) dontCareCCS payload [] [] []
 753
 754 foreignCall
 755         :: String
 756         -> [ExtFCode (CmmReg,MachHint)]
 757         -> ExtFCode CmmExpr
 758         -> [ExtFCode (CmmExpr,MachHint)]
 759         -> Maybe [GlobalReg] -> P ExtCode
 760 foreignCall "C" results_code expr_code args_code vols
 761   = return $ do
 762         results <- sequence results_code
 763         expr <- expr_code
 764         args <- sequence args_code
 765         code (emitForeignCall' PlayRisky results
 766                  (CmmForeignCall expr CCallConv) args vols)
 767 foreignCall conv _ _ _ _
 768   = fail ("unknown calling convention: " ++ conv)
 769
 770 primCall
 771         :: [ExtFCode (CmmReg,MachHint)]
 772         -> FastString
 773         -> [ExtFCode (CmmExpr,MachHint)]
 774         -> Maybe [GlobalReg] -> P ExtCode
 775 primCall results_code name args_code vols
 776   = case lookupUFM callishMachOps name of
 777         Nothing -> fail ("unknown primitive " ++ unpackFS name)
 778         Just p  -> return $ do
 779                 results <- sequence results_code
 780                 args <- sequence args_code
 781                 code (emitForeignCall' PlayRisky results (CmmPrim p) args vols)
 782
 783 doStore :: MachRep -> ExtFCode CmmExpr  -> ExtFCode CmmExpr -> ExtCode
 784 doStore rep addr_code val_code
 785   = do addr <- addr_code
 786        val <- val_code
 787         -- if the specified store type does not match the type of the expr
 788         -- on the rhs, then we insert a coercion that will cause the type
 789         -- mismatch to be flagged by cmm-lint.  If we don't do this, then
 790         -- the store will happen at the wrong type, and the error will not
 791         -- be noticed.
 792        let coerce_val
 793                 | cmmExprRep val /= rep = CmmMachOp (MO_U_Conv rep rep) [val]
 794                 | otherwise             = val
 795        stmtEC (CmmStore addr coerce_val)
 796
 797 -- Return an unboxed tuple.
 798 emitRetUT :: [(CgRep,CmmExpr)] -> Code
 799 emitRetUT args = do
 800   tickyUnboxedTupleReturn (length args)  -- TICK
 801   (sp, stmts) <- pushUnboxedTuple 0 args
 802   emitStmts stmts
 803   when (sp /= 0) $ stmtC (CmmAssign spReg (cmmRegOffW spReg (-sp)))
 804   stmtC (CmmJump (entryCode (CmmLoad (cmmRegOffW spReg sp) wordRep)) [])
 805
 806 -- -----------------------------------------------------------------------------
 807 -- If-then-else and boolean expressions
 808
 809 data BoolExpr
 810   = BoolExpr `BoolAnd` BoolExpr
 811   | BoolExpr `BoolOr`  BoolExpr
 812   | BoolNot BoolExpr
 813   | BoolTest CmmExpr
 814
 815 -- ToDo: smart constructors which simplify the boolean expression.
 816
 817 ifThenElse cond then_part else_part = do
 818      then_id <- code newLabelC
 819      join_id <- code newLabelC
 820      c <- cond
 821      emitCond c then_id
 822      else_part
 823      stmtEC (CmmBranch join_id)
 824      code (labelC then_id)
 825      then_part
 826      -- fall through to join
 827      code (labelC join_id)
 828
 829 -- 'emitCond cond true_id'  emits code to test whether the cond is true,
 830 -- branching to true_id if so, and falling through otherwise.
 831 emitCond (BoolTest e) then_id = do
 832   stmtEC (CmmCondBranch e then_id)
 833 emitCond (BoolNot (BoolTest (CmmMachOp op args))) then_id
 834   | Just op' <- maybeInvertComparison op
 835   = emitCond (BoolTest (CmmMachOp op' args)) then_id
 836 emitCond (BoolNot e) then_id = do
 837   else_id <- code newLabelC
 838   emitCond e else_id
 839   stmtEC (CmmBranch then_id)
 840   code (labelC else_id)
 841 emitCond (e1 `BoolOr` e2) then_id = do
 842   emitCond e1 then_id
 843   emitCond e2 then_id
 844 emitCond (e1 `BoolAnd` e2) then_id = do
 845         -- we'd like to invert one of the conditionals here to avoid an
 846         -- extra branch instruction, but we can't use maybeInvertComparison
 847         -- here because we can't look too closely at the expression since
 848         -- we're in a loop.
 849   and_id <- code newLabelC
 850   else_id <- code newLabelC
 851   emitCond e1 and_id
 852   stmtEC (CmmBranch else_id)
 853   code (labelC and_id)
 854   emitCond e2 then_id
 855   code (labelC else_id)
 856
 857
 858 -- -----------------------------------------------------------------------------
 859 -- Table jumps
 860
 861 -- We use a simplified form of C-- switch statements for now.  A
 862 -- switch statement always compiles to a table jump.  Each arm can
 863 -- specify a list of values (not ranges), and there can be a single
 864 -- default branch.  The range of the table is given either by the
 865 -- optional range on the switch (eg. switch [0..7] {...}), or by
 866 -- the minimum/maximum values from the branches.
 867
 868 doSwitch :: Maybe (Int,Int) -> ExtFCode CmmExpr -> [([Int],ExtCode)]
 869          -> Maybe ExtCode -> ExtCode
 870 doSwitch mb_range scrut arms deflt
 871    = do
 872         -- Compile code for the default branch
 873         dflt_entry <-
 874                 case deflt of
 875                   Nothing -> return Nothing
 876                   Just e  -> do b <- forkLabelledCodeEC e; return (Just b)
 877
 878         -- Compile each case branch
 879         table_entries <- mapM emitArm arms
 880
 881         -- Construct the table
 882         let
 883             all_entries = concat table_entries
 884             ixs = map fst all_entries
 885             (min,max)
 886                 | Just (l,u) <- mb_range = (l,u)
 887                 | otherwise              = (minimum ixs, maximum ixs)
 888
 889             entries = elems (accumArray (\_ a -> Just a) dflt_entry (min,max)
 890                                 all_entries)
 891         expr <- scrut
 892         -- ToDo: check for out of range and jump to default if necessary
 893         stmtEC (CmmSwitch expr entries)
 894    where
 895         emitArm :: ([Int],ExtCode) -> ExtFCode [(Int,BlockId)]
 896         emitArm (ints,code) = do
 897            blockid <- forkLabelledCodeEC code
 898            return [ (i,blockid) | i <- ints ]
 899
 900
 901 -- -----------------------------------------------------------------------------
 902 -- Putting it all together
 903
 904 -- The initial environment: we define some constants that the compiler
 905 -- knows about here.
 906 initEnv :: Env
 907 initEnv = listToUFM [
 908   ( FSLIT("SIZEOF_StgHeader"),
 909     Var (CmmLit (CmmInt (fromIntegral (fixedHdrSize * wORD_SIZE)) wordRep) )),
 910   ( FSLIT("SIZEOF_StgInfoTable"),
 911     Var (CmmLit (CmmInt (fromIntegral stdInfoTableSizeB) wordRep) ))
 912   ]
 913
 914 parseCmmFile :: DynFlags -> FilePath -> IO (Maybe Cmm)
 915 parseCmmFile dflags filename = do
 916   showPass dflags "ParseCmm"
 917   buf <- hGetStringBuffer filename
 918   let
 919         init_loc = mkSrcLoc (mkFastString filename) 1 0
 920         init_state = (mkPState buf init_loc dflags) { lex_state = [0] }
 921                 -- reset the lex_state: the Lexer monad leaves some stuff
 922                 -- in there we don't want.
 923   case unP cmmParse init_state of
 924     PFailed span err -> do printError span err; return Nothing
 925     POk pst code -> do
 926         cmm <- initC dflags no_module (getCmm (unEC code initEnv [] >> return ()))
 927         let ms = getMessages pst
 928         printErrorsAndWarnings dflags ms
 929         when (errorsFound dflags ms) $ exitWith (ExitFailure 1)
 930         dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (pprCmms [cmm])
 931         return (Just cmm)
 932   where
 933         no_module = panic "parseCmmFile: no module"
 934 }