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