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