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