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