compiler/cmm/CmmParse.y

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