CmmParse.y 44.7 KB
Newer Older
1 2
-----------------------------------------------------------------------------
--
Simon Marlow's avatar
Simon Marlow committed
3
-- (c) The University of Glasgow, 2004-2006
4 5
--
-- Parser for concrete Cmm.
6 7
-- This doesn't just parse the Cmm file, we also do some code generation
-- along the way for switches and foreign calls etc.
8 9 10
--
-----------------------------------------------------------------------------

11 12
-- TODO: Add support for interruptible/uninterruptible foreign call specification

13
{
14
{-# LANGUAGE BangPatterns #-} -- required for versions of Happy before 1.18.6
15
{-# OPTIONS -Wwarn -w #-}
16 17 18
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix
-- any warnings in the module. See
Ian Lynagh's avatar
Ian Lynagh committed
19
--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
20 21
-- for details

22 23
module CmmParse ( parseCmmFile ) where

24
import CgMonad
25
import CgExtCode
26 27 28 29 30 31
import CgHeapery
import CgUtils
import CgProf
import CgTicky
import CgInfoTbls
import CgForeignCall
Simon Marlow's avatar
Simon Marlow committed
32 33 34 35 36 37
import CgTailCall
import CgStackery
import ClosureInfo
import CgCallConv
import CgClosure
import CostCentre
38

39
import BlockId
40 41
import OldCmm
import OldPprCmm()
Simon Marlow's avatar
Simon Marlow committed
42
import CmmUtils
43 44
import CmmLex
import CLabel
Simon Marlow's avatar
Simon Marlow committed
45
import SMRep
46 47
import Lexer

Simon Marlow's avatar
Simon Marlow committed
48
import ForeignCall
49
import Module
50
import Platform
Simon Marlow's avatar
Simon Marlow committed
51
import Literal
52 53 54
import Unique
import UniqFM
import SrcLoc
Simon Marlow's avatar
Simon Marlow committed
55 56 57 58
import DynFlags
import StaticFlags
import ErrUtils
import StringBuffer
59
import FastString
Simon Marlow's avatar
Simon Marlow committed
60 61
import Panic
import Constants
62
import Outputable
63
import BasicTypes
64
import Bag              ( emptyBag, unitBag )
65
import Var
66

67
import Control.Monad
68
import Data.Array
69
import Data.Char        ( ord )
70
import System.Exit
71 72

#include "HsVersions.h"
73 74
}

75 76
%expect 0

77
%token
78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109
        ':'     { L _ (CmmT_SpecChar ':') }
        ';'     { L _ (CmmT_SpecChar ';') }
        '{'     { L _ (CmmT_SpecChar '{') }
        '}'     { L _ (CmmT_SpecChar '}') }
        '['     { L _ (CmmT_SpecChar '[') }
        ']'     { L _ (CmmT_SpecChar ']') }
        '('     { L _ (CmmT_SpecChar '(') }
        ')'     { L _ (CmmT_SpecChar ')') }
        '='     { L _ (CmmT_SpecChar '=') }
        '`'     { L _ (CmmT_SpecChar '`') }
        '~'     { L _ (CmmT_SpecChar '~') }
        '/'     { L _ (CmmT_SpecChar '/') }
        '*'     { L _ (CmmT_SpecChar '*') }
        '%'     { L _ (CmmT_SpecChar '%') }
        '-'     { L _ (CmmT_SpecChar '-') }
        '+'     { L _ (CmmT_SpecChar '+') }
        '&'     { L _ (CmmT_SpecChar '&') }
        '^'     { L _ (CmmT_SpecChar '^') }
        '|'     { L _ (CmmT_SpecChar '|') }
        '>'     { L _ (CmmT_SpecChar '>') }
        '<'     { L _ (CmmT_SpecChar '<') }
        ','     { L _ (CmmT_SpecChar ',') }
        '!'     { L _ (CmmT_SpecChar '!') }

        '..'    { L _ (CmmT_DotDot) }
        '::'    { L _ (CmmT_DoubleColon) }
        '>>'    { L _ (CmmT_Shr) }
        '<<'    { L _ (CmmT_Shl) }
        '>='    { L _ (CmmT_Ge) }
        '<='    { L _ (CmmT_Le) }
        '=='    { L _ (CmmT_Eq) }
        '!='    { L _ (CmmT_Ne) }
110 111 112
        '&&'    { L _ (CmmT_BoolAnd) }
        '||'    { L _ (CmmT_BoolOr) }

113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147
        'CLOSURE'               { L _ (CmmT_CLOSURE) }
        'INFO_TABLE'            { L _ (CmmT_INFO_TABLE) }
        'INFO_TABLE_RET'        { L _ (CmmT_INFO_TABLE_RET) }
        'INFO_TABLE_FUN'        { L _ (CmmT_INFO_TABLE_FUN) }
        'INFO_TABLE_CONSTR'     { L _ (CmmT_INFO_TABLE_CONSTR) }
        'INFO_TABLE_SELECTOR'   { L _ (CmmT_INFO_TABLE_SELECTOR) }
        'else'                  { L _ (CmmT_else) }
        'export'                { L _ (CmmT_export) }
        'section'               { L _ (CmmT_section) }
        'align'                 { L _ (CmmT_align) }
        'goto'                  { L _ (CmmT_goto) }
        'if'                    { L _ (CmmT_if) }
        'jump'                  { L _ (CmmT_jump) }
        'foreign'               { L _ (CmmT_foreign) }
        'never'                 { L _ (CmmT_never) }
        'prim'                  { L _ (CmmT_prim) }
        'return'                { L _ (CmmT_return) }
        'returns'               { L _ (CmmT_returns) }
        'import'                { L _ (CmmT_import) }
        'switch'                { L _ (CmmT_switch) }
        'case'                  { L _ (CmmT_case) }
        'default'               { L _ (CmmT_default) }
        'bits8'                 { L _ (CmmT_bits8) }
        'bits16'                { L _ (CmmT_bits16) }
        'bits32'                { L _ (CmmT_bits32) }
        'bits64'                { L _ (CmmT_bits64) }
        'float32'               { L _ (CmmT_float32) }
        'float64'               { L _ (CmmT_float64) }
        'gcptr'                 { L _ (CmmT_gcptr) }

        GLOBALREG               { L _ (CmmT_GlobalReg   $$) }
        NAME                    { L _ (CmmT_Name        $$) }
        STRING                  { L _ (CmmT_String      $$) }
        INT                     { L _ (CmmT_Int         $$) }
        FLOAT                   { L _ (CmmT_Float       $$) }
148 149 150 151 152 153 154

%monad { P } { >>= } { return }
%lexer { cmmlex } { L _ CmmT_EOF }
%name cmmParse cmm
%tokentype { Located CmmToken }

-- C-- operator precedences, taken from the C-- spec
155 156
%right '||'     -- non-std extension, called %disjoin in C--
%right '&&'     -- non-std extension, called %conjoin in C--
157 158 159 160 161 162 163 164 165 166 167 168
%right '!'
%nonassoc '>=' '>' '<=' '<' '!=' '=='
%left '|'
%left '^'
%left '&'
%left '>>' '<<'
%left '-' '+'
%left '/' '*' '%'
%right '~'

%%

169 170 171
cmm     :: { ExtCode }
        : {- empty -}                   { return () }
        | cmmtop cmm                    { do $1; $2 }
172

173 174 175 176 177 178 179 180
cmmtop  :: { ExtCode }
        : cmmproc                       { $1 }
        | cmmdata                       { $1 }
        | decl                          { $1 }
        | 'CLOSURE' '(' NAME ',' NAME lits ')' ';'
                {% withThisPackage $ \pkg ->
                   do lits <- sequence $6;
                      staticClosure pkg $3 $5 (map getLit lits) }
181 182 183 184 185

-- The only static closures in the RTS are dummy closures like
-- stg_END_TSO_QUEUE_closure and stg_dummy_ret.  We don't need
-- to provide the full generality of static closures here.
-- In particular:
186 187 188 189
--      * CCS can always be CCS_DONT_CARE
--      * closure is always extern
--      * payload is always empty
--      * we can derive closure and info table labels from a single NAME
190 191

cmmdata :: { ExtCode }
192 193 194 195
        : 'section' STRING '{' data_label statics '}'
                { do lbl <- $4;
                     ss <- sequence $5;
                     code (emitDecl (CmmData (section $2) (Statics lbl $ concat ss))) }
196

197
data_label :: { ExtFCode CLabel }
198 199 200 201 202 203 204 205
    : NAME ':'
                {% withThisPackage $ \pkg ->
                   return (mkCmmDataLabel pkg $1) }

statics :: { [ExtFCode [CmmStatic]] }
        : {- empty -}                   { [] }
        | static statics                { $1 : $2 }

206 207
-- Strings aren't used much in the RTS HC code, so it doesn't seem
-- worth allowing inline strings.  C-- doesn't allow them anyway.
208 209 210 211 212 213 214 215 216 217 218 219 220
static  :: { ExtFCode [CmmStatic] }
        : type expr ';' { do e <- $2;
                             return [CmmStaticLit (getLit e)] }
        | type ';'                      { return [CmmUninitialised
                                                        (widthInBytes (typeWidth $1))] }
        | 'bits8' '[' ']' STRING ';'    { return [mkString $4] }
        | 'bits8' '[' INT ']' ';'       { return [CmmUninitialised
                                                        (fromIntegral $3)] }
        | typenot8 '[' INT ']' ';'      { return [CmmUninitialised
                                                (widthInBytes (typeWidth $1) *
                                                        fromIntegral $3)] }
        | 'CLOSURE' '(' NAME lits ')'
                { do { lits <- sequence $4
221
             ; dflags <- getDynFlags
222
                     ; return $ map CmmStaticLit $
223
                        mkStaticClosure dflags (mkForeignLabel $3 Nothing ForeignLabelInExternalPackage IsData)
224 225
                         -- mkForeignLabel because these are only used
                         -- for CHARLIKE and INTLIKE closures in the RTS.
226
                        dontCareCCS (map getLit lits) [] [] [] } }
227
        -- arrays of closures required for the CHARLIKE & INTLIKE arrays
228

229 230 231
lits    :: { [ExtFCode CmmExpr] }
        : {- empty -}           { [] }
        | ',' expr lits         { $2 : $3 }
232 233

cmmproc :: { ExtCode }
234
-- TODO: add real SRT/info tables to parsed Cmm
Simon Marlow's avatar
Simon Marlow committed
235 236
        : info maybe_formals_without_hints '{' body '}'
                { do ((entry_ret_label, info, live, formals), stmts) <-
237 238 239
                       getCgStmtsEC' $ loopDecls $ do {
                         (entry_ret_label, info, live) <- $1;
                         formals <- sequence $2;
Simon Marlow's avatar
Simon Marlow committed
240 241
                         $4;
                         return (entry_ret_label, info, live, formals) }
242
                     blks <- code (cgStmtsToBlocks stmts)
Simon Marlow's avatar
Simon Marlow committed
243
                     code (emitInfoTableAndCode entry_ret_label info formals blks) }
244

245 246 247
        | info maybe_formals_without_hints ';'
                { do (entry_ret_label, info, live) <- $1;
                     formals <- sequence $2;
Simon Marlow's avatar
Simon Marlow committed
248
                     code (emitInfoTableAndCode entry_ret_label info formals []) }
249

Simon Marlow's avatar
Simon Marlow committed
250
        | NAME maybe_formals_without_hints '{' body '}'
251 252
                {% withThisPackage $ \pkg ->
                   do   newFunctionName $1 pkg
Simon Marlow's avatar
Simon Marlow committed
253
                        (formals, stmts) <-
254 255
                                getCgStmtsEC' $ loopDecls $ do {
                                        formals <- sequence $2;
Simon Marlow's avatar
Simon Marlow committed
256 257
                                        $4;
                                        return formals }
258
                        blks <- code (cgStmtsToBlocks stmts)
259
                        code (emitProc Nothing (mkCmmCodeLabel pkg $1) formals blks) }
260

261 262 263 264
info    :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) }
        : 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
                -- ptrs, nptrs, closure type, description, type
                {% withThisPackage $ \pkg ->
265 266
                   do dflags <- getDynFlags
                      let prof = profilingInfo dflags $11 $13
267
                          rep  = mkRTSRep (fromIntegral $9) $
268
                                   mkHeapRep dflags False (fromIntegral $5)
269 270 271 272
                                                   (fromIntegral $7) Thunk
                              -- not really Thunk, but that makes the info table
                              -- we want.
                      return (mkCmmEntryLabel pkg $3,
273 274 275 276 277 278 279 280
                              CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
                                           , cit_rep = rep
                                           , cit_prof = prof, cit_srt = NoC_SRT },
                              []) }

        | 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ')'
                -- ptrs, nptrs, closure type, description, type, fun type
                {% withThisPackage $ \pkg ->
281 282
                   do dflags <- getDynFlags
                      let prof = profilingInfo dflags $11 $13
283 284 285
                          ty   = Fun 0 (ArgSpec (fromIntegral $15))
                                -- Arity zero, arg_type $15
                          rep = mkRTSRep (fromIntegral $9) $
286
                                    mkHeapRep dflags False (fromIntegral $5)
287 288
                                                    (fromIntegral $7) ty
                      return (mkCmmEntryLabel pkg $3,
289 290 291 292 293 294
                              CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
                                           , cit_rep = rep
                                           , cit_prof = prof, cit_srt = NoC_SRT },
                              []) }
                -- we leave most of the fields zero here.  This is only used
                -- to generate the BCO info table in the RTS at the moment.
295

296
        | 'INFO_TABLE_CONSTR' '(' NAME ',' INT ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
297 298
                -- ptrs, nptrs, tag, closure type, description, type
                {% withThisPackage $ \pkg ->
299 300
                   do dflags <- getDynFlags
                      let prof = profilingInfo dflags $13 $15
301
                          ty  = Constr (fromIntegral $9)  -- Tag
302
                                       (stringToWord8s $13)
303
                          rep = mkRTSRep (fromIntegral $11) $
304
                                  mkHeapRep dflags False (fromIntegral $5)
305 306
                                                  (fromIntegral $7) ty
                      return (mkCmmEntryLabel pkg $3,
307 308 309 310 311 312 313 314 315 316 317
                              CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
                                           , cit_rep = rep
                                           , cit_prof = prof, cit_srt = NoC_SRT },
                              []) }

                     -- If profiling is on, this string gets duplicated,
                     -- but that's the way the old code did it we can fix it some other time.

        | 'INFO_TABLE_SELECTOR' '(' NAME ',' INT ',' INT ',' STRING ',' STRING ')'
                -- selector, closure type, description, type
                {% withThisPackage $ \pkg ->
318 319
                   do dflags <- getDynFlags
                      let prof = profilingInfo dflags $9 $11
320
                          ty  = ThunkSelector (fromIntegral $5)
321
                          rep = mkRTSRep (fromIntegral $7) $
322
                                   mkHeapRep dflags False 0 0 ty
323
                      return (mkCmmEntryLabel pkg $3,
324 325 326 327 328 329 330 331 332
                              CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
                                           , cit_rep = rep
                                           , cit_prof = prof, cit_srt = NoC_SRT },
                              []) }

        | 'INFO_TABLE_RET' '(' NAME ',' INT ')'
                -- closure type (no live regs)
                {% withThisPackage $ \pkg ->
                   do let prof = NoProfilingInfo
333 334
                          rep  = mkRTSRep (fromIntegral $5) $ mkStackRep []
                      return (mkCmmRetLabel pkg $3,
335 336 337 338 339 340 341 342
                              CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
                                           , cit_rep = rep
                                           , cit_prof = prof, cit_srt = NoC_SRT },
                              []) }

        | 'INFO_TABLE_RET' '(' NAME ',' INT ',' formals_without_hints0 ')'
                -- closure type, live regs
                {% withThisPackage $ \pkg ->
343 344
                   do dflags <- getDynFlags
                      live <- sequence (map (liftM Just) $7)
345
                      let prof = NoProfilingInfo
346
                          bitmap = mkLiveness dflags live
347 348
                          rep  = mkRTSRep (fromIntegral $5) $ mkStackRep bitmap
                      return (mkCmmRetLabel pkg $3,
349 350 351 352
                              CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
                                           , cit_rep = rep
                                           , cit_prof = prof, cit_srt = NoC_SRT },
                              []) }
353

354 355 356 357
body    :: { ExtCode }
        : {- empty -}                   { return () }
        | decl body                     { do $1; $2 }
        | stmt body                     { do $1; $2 }
358

359 360 361 362
decl    :: { ExtCode }
        : type names ';'                { mapM_ (newLocal $1) $2 }
        | 'import' importNames ';'      { mapM_ newImport $2 }
        | 'export' names ';'            { return () }  -- ignore exports
363

364 365

-- an imported function name, with optional packageId
366 367 368 369 370
importNames
        :: { [(FastString, CLabel)] }
        : importName                    { [$1] }
        | importName ',' importNames    { $1 : $3 }

371
importName
372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418
        :: { (FastString,  CLabel) }

        -- A label imported without an explicit packageId.
        --      These are taken to come frome some foreign, unnamed package.
        : NAME
        { ($1, mkForeignLabel $1 Nothing ForeignLabelInExternalPackage IsFunction) }

        -- A label imported with an explicit packageId.
        | STRING NAME
        { ($2, mkCmmCodeLabel (fsToPackageId (mkFastString $1)) $2) }


names   :: { [FastString] }
        : NAME                          { [$1] }
        | NAME ',' names                { $1 : $3 }

stmt    :: { ExtCode }
        : ';'                                   { nopEC }

        | NAME ':'
                { do l <- newLabel $1; code (labelC l) }

        | lreg '=' expr ';'
                { do reg <- $1; e <- $3; stmtEC (CmmAssign reg e) }
        | type '[' expr ']' '=' expr ';'
                { doStore $1 $3 $6 }

        -- Gah! We really want to say "maybe_results" but that causes
        -- a shift/reduce conflict with assignment.  We either
        -- we expand out the no-result and single result cases or
        -- we tweak the syntax to avoid the conflict.  The later
        -- option is taken here because the other way would require
        -- multiple levels of expanding and get unwieldy.
        | maybe_results 'foreign' STRING expr '(' cmm_hint_exprs0 ')' safety vols opt_never_returns ';'
                {% foreignCall $3 $1 $4 $6 $9 $8 $10 }
        | maybe_results 'prim' '%' NAME '(' cmm_hint_exprs0 ')' safety vols ';'
                {% primCall $1 $4 $6 $9 $8 }
        -- stmt-level macros, stealing syntax from ordinary C-- function calls.
        -- Perhaps we ought to use the %%-form?
        | NAME '(' exprs0 ')' ';'
                {% stmtMacro $1 $3  }
        | 'switch' maybe_range expr '{' arms default '}'
                { do as <- sequence $5; doSwitch $2 $3 as $6 }
        | 'goto' NAME ';'
                { do l <- lookupLabel $2; stmtEC (CmmBranch l) }
        | 'jump' expr vols ';'
                { do e <- $2; stmtEC (CmmJump e $3) }
dterei's avatar
dterei committed
419
        | 'return' ';'
420 421 422 423 424
                { stmtEC CmmReturn }
        | 'if' bool_expr 'goto' NAME
                { do l <- lookupLabel $4; cmmRawIf $2 l }
        | 'if' bool_expr '{' body '}' else
                { cmmIfThenElse $2 $4 $6 }
425

426 427 428
opt_never_returns :: { CmmReturnInfo }
        :                               { CmmMayReturn }
        | 'never' 'returns'             { CmmNeverReturns }
429

430
bool_expr :: { ExtFCode BoolExpr }
431 432
        : bool_op                       { $1 }
        | expr                          { do e <- $1; return (BoolTest e) }
433 434

bool_op :: { ExtFCode BoolExpr }
435 436 437 438 439 440
        : bool_expr '&&' bool_expr      { do e1 <- $1; e2 <- $3;
                                          return (BoolAnd e1 e2) }
        | bool_expr '||' bool_expr      { do e1 <- $1; e2 <- $3;
                                          return (BoolOr e1 e2)  }
        | '!' bool_expr                 { do e <- $2; return (BoolNot e) }
        | '(' bool_op ')'               { $2 }
441

442 443
-- This is not C-- syntax.  What to do?
safety  :: { CmmSafety }
444 445
        : {- empty -}                   { CmmUnsafe } -- Default may change soon
        | STRING                        {% parseSafety $1 }
446

447
-- This is not C-- syntax.  What to do?
448 449 450 451
vols    :: { Maybe [GlobalReg] }
        : {- empty -}                   { Nothing }
        | '[' ']'                       { Just [] }
        | '[' globals ']'               { Just $2 }
452 453

globals :: { [GlobalReg] }
454 455
        : GLOBALREG                     { [$1] }
        | GLOBALREG ',' globals         { $1 : $3 }
456 457

maybe_range :: { Maybe (Int,Int) }
458 459
        : '[' INT '..' INT ']'  { Just (fromIntegral $2, fromIntegral $4) }
        | {- empty -}           { Nothing }
460

461 462 463
arms    :: { [ExtFCode ([Int],Either BlockId ExtCode)] }
        : {- empty -}                   { [] }
        | arm arms                      { $1 : $2 }
464

465 466
arm     :: { ExtFCode ([Int],Either BlockId ExtCode) }
        : 'case' ints ':' arm_body      { do b <- $4; return ($2, b) }
467 468

arm_body :: { ExtFCode (Either BlockId ExtCode) }
469 470
        : '{' body '}'                  { return (Right $2) }
        | 'goto' NAME ';'               { do l <- lookupLabel $2; return (Left l) }
471

472 473 474
ints    :: { [Int] }
        : INT                           { [ fromIntegral $1 ] }
        | INT ',' ints                  { fromIntegral $1 : $3 }
475 476

default :: { Maybe ExtCode }
477 478 479 480
        : 'default' ':' '{' body '}'    { Just $4 }
        -- taking a few liberties with the C-- syntax here; C-- doesn't have
        -- 'default' branches
        | {- empty -}                   { Nothing }
481

482 483
-- Note: OldCmm doesn't support a first class 'else' statement, though
-- CmmNode does.
484 485 486
else    :: { ExtCode }
        : {- empty -}                   { nopEC }
        | 'else' '{' body '}'           { $3 }
487 488 489

-- we have to write this out longhand so that Happy's precedence rules
-- can kick in.
490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521
expr    :: { ExtFCode CmmExpr }
        : expr '/' expr                 { mkMachOp MO_U_Quot [$1,$3] }
        | expr '*' expr                 { mkMachOp MO_Mul [$1,$3] }
        | expr '%' expr                 { mkMachOp MO_U_Rem [$1,$3] }
        | expr '-' expr                 { mkMachOp MO_Sub [$1,$3] }
        | expr '+' expr                 { mkMachOp MO_Add [$1,$3] }
        | expr '>>' expr                { mkMachOp MO_U_Shr [$1,$3] }
        | expr '<<' expr                { mkMachOp MO_Shl [$1,$3] }
        | expr '&' expr                 { mkMachOp MO_And [$1,$3] }
        | expr '^' expr                 { mkMachOp MO_Xor [$1,$3] }
        | expr '|' expr                 { mkMachOp MO_Or [$1,$3] }
        | expr '>=' expr                { mkMachOp MO_U_Ge [$1,$3] }
        | expr '>' expr                 { mkMachOp MO_U_Gt [$1,$3] }
        | expr '<=' expr                { mkMachOp MO_U_Le [$1,$3] }
        | expr '<' expr                 { mkMachOp MO_U_Lt [$1,$3] }
        | expr '!=' expr                { mkMachOp MO_Ne [$1,$3] }
        | expr '==' expr                { mkMachOp MO_Eq [$1,$3] }
        | '~' expr                      { mkMachOp MO_Not [$2] }
        | '-' expr                      { mkMachOp MO_S_Neg [$2] }
        | expr0 '`' NAME '`' expr0      {% do { mo <- nameToMachOp $3 ;
                                                return (mkMachOp mo [$1,$5]) } }
        | expr0                         { $1 }

expr0   :: { ExtFCode CmmExpr }
        : INT   maybe_ty         { return (CmmLit (CmmInt $1 (typeWidth $2))) }
        | FLOAT maybe_ty         { return (CmmLit (CmmFloat $1 (typeWidth $2))) }
        | STRING                 { do s <- code (newStringCLit $1);
                                      return (CmmLit s) }
        | reg                    { $1 }
        | type '[' expr ']'      { do e <- $3; return (CmmLoad e $1) }
        | '%' NAME '(' exprs0 ')' {% exprOp $2 $4 }
        | '(' expr ')'           { $2 }
522 523 524


-- leaving out the type of a literal gives you the native word size in C--
525
maybe_ty :: { CmmType }
526
        : {- empty -}                   {% do dflags <- getDynFlags; return $ bWord dflags }
527
        | '::' type                     { $2 }
528

529
maybe_actuals :: { [ExtFCode HintedCmmActual] }
530 531
        : {- empty -}                   { [] }
        | '(' cmm_hint_exprs0 ')'       { $2 }
532

533
cmm_hint_exprs0 :: { [ExtFCode HintedCmmActual] }
534 535
        : {- empty -}                   { [] }
        | cmm_hint_exprs                { $1 }
536

537
cmm_hint_exprs :: { [ExtFCode HintedCmmActual] }
538 539
        : cmm_hint_expr                         { [$1] }
        | cmm_hint_expr ',' cmm_hint_exprs      { $1 : $3 }
540

541
cmm_hint_expr :: { ExtFCode HintedCmmActual }
542 543 544 545
        : expr                          { do e <- $1; return (CmmHinted e (inferCmmHint e)) }
        | expr STRING                   {% do h <- parseCmmHint $2;
                                              return $ do
                                                e <- $1; return (CmmHinted e h) }
546 547

exprs0  :: { [ExtFCode CmmExpr] }
548 549
        : {- empty -}                   { [] }
        | exprs                         { $1 }
550

551 552 553
exprs   :: { [ExtFCode CmmExpr] }
        : expr                          { [ $1 ] }
        | expr ',' exprs                { $1 : $3 }
554

555 556 557
reg     :: { ExtFCode CmmExpr }
        : NAME                  { lookupName $1 }
        | GLOBALREG             { return (CmmReg (CmmGlobal $1)) }
558

559
maybe_results :: { [ExtFCode HintedCmmFormal] }
560 561
        : {- empty -}           { [] }
        | '(' cmm_formals ')' '='       { $2 }
562

563
cmm_formals :: { [ExtFCode HintedCmmFormal] }
564 565 566
        : cmm_formal                    { [$1] }
        | cmm_formal ','                { [$1] }
        | cmm_formal ',' cmm_formals    { $1 : $3 }
567

568
cmm_formal :: { ExtFCode HintedCmmFormal }
569 570 571 572
        : local_lreg                    { do e <- $1; return (CmmHinted e (inferCmmHint (CmmReg (CmmLocal e)))) }
        | STRING local_lreg             {% do h <- parseCmmHint $1;
                                              return $ do
                                                e <- $2; return (CmmHinted e h) }
573

574
local_lreg :: { ExtFCode LocalReg }
575 576 577 578 579 580 581 582 583 584 585 586 587
        : NAME                  { do e <- lookupName $1;
                                     return $
                                       case e of
                                        CmmReg (CmmLocal r) -> r
                                        other -> pprPanic "CmmParse:" (ftext $1 <> text " not a local register") }

lreg    :: { ExtFCode CmmReg }
        : NAME                  { do e <- lookupName $1;
                                     return $
                                       case e of
                                        CmmReg r -> r
                                        other -> pprPanic "CmmParse:" (ftext $1 <> text " not a register") }
        | GLOBALREG             { return (CmmGlobal $1) }
588

589
maybe_formals_without_hints :: { [ExtFCode LocalReg] }
590 591
        : {- empty -}                           { [] }
        | '(' formals_without_hints0 ')'        { $2 }
592

593
formals_without_hints0 :: { [ExtFCode LocalReg] }
594 595
        : {- empty -}                   { [] }
        | formals_without_hints         { $1 }
596

597
formals_without_hints :: { [ExtFCode LocalReg] }
598 599 600
        : formal_without_hint ','                       { [$1] }
        | formal_without_hint                           { [$1] }
        | formal_without_hint ',' formals_without_hints { $1 : $3 }
601

602
formal_without_hint :: { ExtFCode LocalReg }
603
        : type NAME             { newLocal $1 $2 }
604

Simon Marlow's avatar
Simon Marlow committed
605
type    :: { CmmType }
606 607
        : 'bits8'               { b8 }
        | typenot8              { $1 }
608

609
typenot8 :: { CmmType }
610 611 612 613 614
        : 'bits16'              { b16 }
        | 'bits32'              { b32 }
        | 'bits64'              { b64 }
        | 'float32'             { f32 }
        | 'float64'             { f64 }
615
        | 'gcptr'               {% do dflags <- getDynFlags; return $ gcWord dflags }
616 617
{
section :: String -> Section
618 619 620
section "text"      = Text
section "data"      = Data
section "rodata"    = ReadOnlyData
621
section "relrodata" = RelocatableReadOnlyData
622 623
section "bss"       = UninitialisedData
section s           = OtherSection s
624

625 626 627
mkString :: String -> CmmStatic
mkString s = CmmString (map (fromIntegral.ord) s)

628 629 630 631
-- mkMachOp infers the type of the MachOp from the type of its first
-- argument.  We assume that this is correct: for MachOps that don't have
-- symmetrical args (e.g. shift ops), the first arg determines the type of
-- the op.
632
mkMachOp :: (Width -> MachOp) -> [ExtFCode CmmExpr] -> ExtFCode CmmExpr
633
mkMachOp fn args = do
634
  dflags <- getDynFlags
635
  arg_exprs <- sequence args
636
  return (CmmMachOp (fn (typeWidth (cmmExprType dflags (head arg_exprs)))) arg_exprs)
637 638 639 640 641 642

getLit :: CmmExpr -> CmmLit
getLit (CmmLit l) = l
getLit (CmmMachOp (MO_S_Neg _) [CmmLit (CmmInt i r)])  = CmmInt (negate i) r
getLit _ = panic "invalid literal" -- TODO messy failure

643
nameToMachOp :: FastString -> P (Width -> MachOp)
644
nameToMachOp name =
645
  case lookupUFM machOps name of
646 647
        Nothing -> fail ("unknown primitive " ++ unpackFS name)
        Just m  -> return m
648 649

exprOp :: FastString -> [ExtFCode CmmExpr] -> P (ExtFCode CmmExpr)
650 651 652
exprOp name args_code = do
  dflags <- getDynFlags
  case lookupUFM (exprMacros dflags) name of
653 654
     Just f  -> return $ do
        args <- sequence args_code
655
        return (f args)
656
     Nothing -> do
657 658
        mo <- nameToMachOp name
        return $ mkMachOp mo args_code
659

660 661
exprMacros :: DynFlags -> UniqFM ([CmmExpr] -> CmmExpr)
exprMacros dflags = listToUFM [
662
  ( fsLit "ENTRY_CODE",   \ [x] -> entryCode dflags x ),
663
  ( fsLit "INFO_PTR",     \ [x] -> closureInfoPtr dflags x ),
664 665
  ( fsLit "STD_INFO",     \ [x] -> infoTable dflags x ),
  ( fsLit "FUN_INFO",     \ [x] -> funInfoTable dflags x ),
666 667 668
  ( fsLit "GET_ENTRY",    \ [x] -> entryCode dflags (closureInfoPtr dflags x) ),
  ( fsLit "GET_STD_INFO", \ [x] -> infoTable dflags (closureInfoPtr dflags x) ),
  ( fsLit "GET_FUN_INFO", \ [x] -> funInfoTable dflags (closureInfoPtr dflags x) ),
669 670 671
  ( fsLit "INFO_TYPE",    \ [x] -> infoTableClosureType dflags x ),
  ( fsLit "INFO_PTRS",    \ [x] -> infoTablePtrs dflags x ),
  ( fsLit "INFO_NPTRS",   \ [x] -> infoTableNonPtrs dflags x )
672 673 674 675
  ]

-- we understand a subset of C-- primitives:
machOps = listToUFM $
676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696
        map (\(x, y) -> (mkFastString x, y)) [
        ( "add",        MO_Add ),
        ( "sub",        MO_Sub ),
        ( "eq",         MO_Eq ),
        ( "ne",         MO_Ne ),
        ( "mul",        MO_Mul ),
        ( "neg",        MO_S_Neg ),
        ( "quot",       MO_S_Quot ),
        ( "rem",        MO_S_Rem ),
        ( "divu",       MO_U_Quot ),
        ( "modu",       MO_U_Rem ),

        ( "ge",         MO_S_Ge ),
        ( "le",         MO_S_Le ),
        ( "gt",         MO_S_Gt ),
        ( "lt",         MO_S_Lt ),

        ( "geu",        MO_U_Ge ),
        ( "leu",        MO_U_Le ),
        ( "gtu",        MO_U_Gt ),
        ( "ltu",        MO_U_Lt ),
697

698
        ( "and",        MO_And ),
699 700 701 702 703 704
        ( "or",         MO_Or ),
        ( "xor",        MO_Xor ),
        ( "com",        MO_Not ),
        ( "shl",        MO_Shl ),
        ( "shrl",       MO_U_Shr ),
        ( "shra",       MO_S_Shr ),
705

706 707 708 709 710 711 712 713 714 715 716 717 718 719
        ( "fadd",       MO_F_Add ),
        ( "fsub",       MO_F_Sub ),
        ( "fneg",       MO_F_Neg ),
        ( "fmul",       MO_F_Mul ),
        ( "fquot",      MO_F_Quot ),

        ( "feq",        MO_F_Eq ),
        ( "fne",        MO_F_Ne ),
        ( "fge",        MO_F_Ge ),
        ( "fle",        MO_F_Le ),
        ( "fgt",        MO_F_Gt ),
        ( "flt",        MO_F_Lt ),

        ( "lobits8",  flip MO_UU_Conv W8  ),
720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740
        ( "lobits16", flip MO_UU_Conv W16 ),
        ( "lobits32", flip MO_UU_Conv W32 ),
        ( "lobits64", flip MO_UU_Conv W64 ),

        ( "zx16",     flip MO_UU_Conv W16 ),
        ( "zx32",     flip MO_UU_Conv W32 ),
        ( "zx64",     flip MO_UU_Conv W64 ),

        ( "sx16",     flip MO_SS_Conv W16 ),
        ( "sx32",     flip MO_SS_Conv W32 ),
        ( "sx64",     flip MO_SS_Conv W64 ),

        ( "f2f32",    flip MO_FF_Conv W32 ),  -- TODO; rounding mode
        ( "f2f64",    flip MO_FF_Conv W64 ),  -- TODO; rounding mode
        ( "f2i8",     flip MO_FS_Conv W8 ),
        ( "f2i16",    flip MO_FS_Conv W16 ),
        ( "f2i32",    flip MO_FS_Conv W32 ),
        ( "f2i64",    flip MO_FS_Conv W64 ),
        ( "i2f32",    flip MO_SF_Conv W32 ),
        ( "i2f64",    flip MO_SF_Conv W64 )
        ]
741

742
callishMachOps = listToUFM $
743
        map (\(x, y) -> (mkFastString x, y)) [
744 745 746 747
        ( "write_barrier", MO_WriteBarrier ),
        ( "memcpy", MO_Memcpy ),
        ( "memset", MO_Memset ),
        ( "memmove", MO_Memmove )
748 749 750
        -- ToDo: the rest, maybe
    ]

751 752 753
parseSafety :: String -> P CmmSafety
parseSafety "safe"   = return (CmmSafe NoC_SRT)
parseSafety "unsafe" = return CmmUnsafe
754
parseSafety "interruptible" = return CmmInterruptible
755 756
parseSafety str      = fail ("unrecognised safety: " ++ str)

757 758 759 760
parseCmmHint :: String -> P ForeignHint
parseCmmHint "ptr"    = return AddrHint
parseCmmHint "signed" = return SignedHint
parseCmmHint str      = fail ("unrecognised hint: " ++ str)
761

762
-- labels are always pointers, so we might as well infer the hint
763 764 765 766 767
inferCmmHint :: CmmExpr -> ForeignHint
inferCmmHint (CmmLit (CmmLabel _)) = AddrHint
inferCmmHint (CmmReg (CmmGlobal g)) | isPtrGlobalReg g = AddrHint
inferCmmHint _ = NoHint

768 769 770 771
isPtrGlobalReg Sp                    = True
isPtrGlobalReg SpLim                 = True
isPtrGlobalReg Hp                    = True
isPtrGlobalReg HpLim                 = True
772 773 774
isPtrGlobalReg CCCS                  = True
isPtrGlobalReg CurrentTSO            = True
isPtrGlobalReg CurrentNursery        = True
775
isPtrGlobalReg (VanillaReg _ VGcPtr) = True
776
isPtrGlobalReg _                     = False
777 778 779 780 781 782 783 784 785 786 787 788

happyError :: P a
happyError = srcParseFail

-- -----------------------------------------------------------------------------
-- Statement-level macros

stmtMacro :: FastString -> [ExtFCode CmmExpr] -> P ExtCode
stmtMacro fun args_code = do
  case lookupUFM stmtMacros fun of
    Nothing -> fail ("unknown macro: " ++ unpackFS fun)
    Just fcode -> return $ do
789 790
        args <- sequence args_code
        code (fcode args)
791 792 793

stmtMacros :: UniqFM ([CmmExpr] -> Code)
stmtMacros = listToUFM [
794 795
  ( fsLit "CCS_ALLOC",             \[words,ccs]  -> profAlloc words ccs ),
  ( fsLit "CLOSE_NURSERY",         \[]  -> emitCloseNursery ),
Ian Lynagh's avatar
Ian Lynagh committed
796
  ( fsLit "ENTER_CCS_THUNK",      \[e] -> enterCostCentreThunk e ),
797
  ( fsLit "HP_CHK_GEN",           \[words,liveness,reentry] ->
798
                                      hpChkGen words liveness reentry ),
Ian Lynagh's avatar
Ian Lynagh committed
799 800 801 802
  ( fsLit "HP_CHK_NP_ASSIGN_SP0", \[e,f] -> hpChkNodePointsAssignSp0 e f ),
  ( fsLit "LOAD_THREAD_STATE",    \[] -> emitLoadThreadState ),
  ( fsLit "LDV_ENTER",            \[e] -> ldvEnter e ),
  ( fsLit "LDV_RECORD_CREATE",    \[e] -> ldvRecordCreate e ),
803 804
  ( fsLit "OPEN_NURSERY",          \[]  -> emitOpenNursery ),
  ( fsLit "PUSH_UPD_FRAME",        \[sp,e] -> emitPushUpdateFrame sp e ),
Ian Lynagh's avatar
Ian Lynagh committed
805
  ( fsLit "SAVE_THREAD_STATE",    \[] -> emitSaveThreadState ),
806 807 808
  ( fsLit "SET_HDR",               \[ptr,info,ccs] ->
                                        emitSetDynHdr ptr info ccs ),
  ( fsLit "STK_CHK_GEN",          \[words,liveness,reentry] ->
809
                                      stkChkGen words liveness reentry ),
810 811 812 813 814 815 816
  ( fsLit "STK_CHK_NP",    \[e] -> stkChkNodePoints e ),
  ( fsLit "TICK_ALLOC_PRIM",       \[hdr,goods,slop] ->
                                        tickyAllocPrim hdr goods slop ),
  ( fsLit "TICK_ALLOC_PAP",       \[goods,slop] ->
                                        tickyAllocPAP goods slop ),
  ( fsLit "TICK_ALLOC_UP_THK",    \[goods,slop] ->
                                        tickyAllocThunk goods slop ),
Ian Lynagh's avatar
Ian Lynagh committed
817 818 819
  ( fsLit "UPD_BH_UPDATABLE",       \[] -> emitBlackHoleCode False ),
  ( fsLit "UPD_BH_SINGLE_ENTRY",    \[] -> emitBlackHoleCode True ),

820 821 822 823 824 825 826 827
  ( fsLit "RET_P",      \[a] ->       emitRetUT [(PtrArg,a)]),
  ( fsLit "RET_N",      \[a] ->       emitRetUT [(NonPtrArg,a)]),
  ( fsLit "RET_PP",     \[a,b] ->     emitRetUT [(PtrArg,a),(PtrArg,b)]),
  ( fsLit "RET_NN",     \[a,b] ->     emitRetUT [(NonPtrArg,a),(NonPtrArg,b)]),
  ( fsLit "RET_NP",     \[a,b] ->     emitRetUT [(NonPtrArg,a),(PtrArg,b)]),
  ( fsLit "RET_PPP",    \[a,b,c] ->   emitRetUT [(PtrArg,a),(PtrArg,b),(PtrArg,c)]),
  ( fsLit "RET_NPP",    \[a,b,c] ->   emitRetUT [(NonPtrArg,a),(PtrArg,b),(PtrArg,c)]),
  ( fsLit "RET_NNP",    \[a,b,c] ->   emitRetUT [(NonPtrArg,a),(NonPtrArg,b),(PtrArg,c)]),
Ian Lynagh's avatar
Ian Lynagh committed
828
  ( fsLit "RET_NNN",  \[a,b,c] -> emitRetUT [(NonPtrArg,a),(NonPtrArg,b),(NonPtrArg,c)]),
829
  ( fsLit "RET_NNNN",  \[a,b,c,d] -> emitRetUT [(NonPtrArg,a),(NonPtrArg,b),(NonPtrArg,c),(NonPtrArg,d)]),
830 831
  ( fsLit "RET_NNNP",   \[a,b,c,d] -> emitRetUT [(NonPtrArg,a),(NonPtrArg,b),(NonPtrArg,c),(PtrArg,d)]),
  ( fsLit "RET_NPNP",   \[a,b,c,d] -> emitRetUT [(NonPtrArg,a),(PtrArg,b),(NonPtrArg,c),(PtrArg,d)])
832 833 834 835

 ]


836
profilingInfo dflags desc_str ty_str
837 838 839 840
  = if not (dopt Opt_SccProfilingOn dflags)
    then NoProfilingInfo
    else ProfilingInfo (stringToWord8s desc_str)
                       (stringToWord8s ty_str)
841

842 843
staticClosure :: PackageId -> FastString -> FastString -> [CmmLit] -> ExtCode
staticClosure pkg cl_label info payload
844 845 846
  = do dflags <- getDynFlags
       let lits = mkStaticClosure dflags (mkCmmInfoLabel pkg info) dontCareCCS payload [] [] []
       code $ emitDataLits (mkCmmDataLabel pkg cl_label) lits
847 848

foreignCall
849 850 851 852 853
        :: String
        -> [ExtFCode HintedCmmFormal]
        -> ExtFCode CmmExpr
        -> [ExtFCode HintedCmmActual]
        -> Maybe [GlobalReg]
854
        -> CmmSafety
855
        -> CmmReturnInfo
856
        -> P ExtCode
857
foreignCall conv_string results_code expr_code args_code vols safety ret
858 859
  = do  convention <- case conv_string of
          "C" -> return CCallConv
860
          "stdcall" -> return StdCallConv
861 862
          "C--" -> return CmmCallConv
          _ -> fail ("unknown calling convention: " ++ conv_string)
863
        return $ do
864 865
          dflags <- getDynFlags
          let platform = targetPlatform dflags
866 867 868
          results <- sequence results_code
          expr <- expr_code
          args <- sequence args_code
869 870
          case convention of
            -- Temporary hack so at least some functions are CmmSafe
871
            CmmCallConv -> code (stmtC (CmmCall (CmmCallee expr convention) results args ret))
872
            _ ->
873
              let expr' = adjCallTarget dflags convention expr args in
874
              case safety of
875 876
              CmmUnsafe ->
                code (emitForeignCall' PlayRisky results
877
                   (CmmCallee expr' convention) args vols NoC_SRT ret)
878
              CmmSafe srt ->
879
                code (emitForeignCall' PlaySafe results
880
                   (CmmCallee expr' convention) args vols NoC_SRT ret) where
881
              CmmInterruptible ->
882
                code (emitForeignCall' PlayInterruptible results
883
                   (CmmCallee expr' convention) args vols NoC_SRT ret)
884

885
adjCallTarget :: DynFlags -> CCallConv -> CmmExpr -> [CmmHinted CmmExpr]
886
              -> CmmExpr
887 888
-- On Windows, we have to add the '@N' suffix to the label when making
-- a call with the stdcall calling convention.
889 890
adjCallTarget dflags StdCallConv (CmmLit (CmmLabel lbl)) args
 | platformOS (targetPlatform dflags) == OSMinGW32
891
  = CmmLit (CmmLabel (addLabelSize lbl (sum (map size args))))
892
  where size (CmmHinted e _) = max (wORD_SIZE dflags) (widthInBytes (typeWidth (cmmExprType dflags e)))
893
                 -- c.f. CgForeignCall.emitForeignCall
894
adjCallTarget _ _ expr _
895 896
  = expr

897
primCall
898 899 900 901
        :: [ExtFCode HintedCmmFormal]
        -> FastString
        -> [ExtFCode HintedCmmActual]
        -> Maybe [GlobalReg]
902
        -> CmmSafety
903
        -> P ExtCode
904
primCall results_code name args_code vols safety
905
  = case lookupUFM callishMachOps name of
906 907 908 909 910 911 912 913 914 915 916 917 918 919
        Nothing -> fail ("unknown primitive " ++ unpackFS name)
        Just p  -> return $ do
                results <- sequence results_code
                args <- sequence args_code
                case safety of
                  CmmUnsafe ->
                    code (emitForeignCall' PlayRisky results
                      (CmmPrim p Nothing) args vols NoC_SRT CmmMayReturn)
                  CmmSafe srt ->
                    code (emitForeignCall' PlaySafe results
                      (CmmPrim p Nothing) args vols NoC_SRT CmmMayReturn) where
                  CmmInterruptible ->
                    code (emitForeignCall' PlayInterruptible results
                      (CmmPrim p Nothing) args vols NoC_SRT CmmMayReturn)
920

921
doStore :: CmmType -> ExtFCode CmmExpr  -> ExtFCode CmmExpr -> ExtCode
922
doStore rep addr_code val_code
923 924
  = do dflags <- getDynFlags
       addr <- addr_code
925
       val <- val_code
926 927 928 929 930
        -- if the specified store type does not match the type of the expr
        -- on the rhs, then we insert a coercion that will cause the type
        -- mismatch to be flagged by cmm-lint.  If we don't do this, then
        -- the store will happen at the wrong type, and the error will not
        -- be noticed.
931
       let val_width = typeWidth (cmmExprType dflags val)
932
           rep_width = typeWidth rep
933 934 935
       let coerce_val
                | val_width /= rep_width = CmmMachOp (MO_UU_Conv val_width rep_width) [val]
                | otherwise              = val
936 937 938 939 940
       stmtEC (CmmStore addr coerce_val)

-- Return an unboxed tuple.
emitRetUT :: [(CgRep,CmmExpr)] -> Code
emitRetUT args = do
941
  dflags <- getDynFlags
942
  tickyUnboxedTupleReturn (length args)  -- TICK
943
  (sp, stmts, live) <- pushUnboxedTuple 0 args
944 945 946
  emitSimultaneously stmts -- NB. the args might overlap with the stack slots
                           -- or regs that we assign to, so better use
                           -- simultaneous assignments here (#3546)
947 948
  when (sp /= 0) $ stmtC (CmmAssign spReg (cmmRegOffW dflags spReg (-sp)))
  stmtC $ CmmJump (entryCode dflags (CmmLoad (cmmRegOffW dflags spReg sp) (bWord dflags))) (Just live)
949 950 951 952 953 954 955 956 957 958 959 960

-- -----------------------------------------------------------------------------
-- If-then-else and boolean expressions

data BoolExpr
  = BoolExpr `BoolAnd` BoolExpr
  | BoolExpr `BoolOr`  BoolExpr
  | BoolNot BoolExpr
  | BoolTest CmmExpr

-- ToDo: smart constructors which simplify the boolean expression.

961
cmmIfThenElse cond then_part else_part = do
962 963 964 965 966 967 968 969 970 971 972
     then_id <- code newLabelC
     join_id <- code newLabelC
     c <- cond
     emitCond c then_id
     else_part
     stmtEC (CmmBranch join_id)
     code (labelC then_id)
     then_part
     -- fall through to join
     code (labelC join_id)

973 974 975 976
cmmRawIf cond then_id = do
    c <- cond
    emitCond c then_id

977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992
-- 'emitCond cond true_id'  emits code to test whether the cond is true,
-- branching to true_id if so, and falling through otherwise.
emitCond (BoolTest e) then_id = do
  stmtEC (CmmCondBranch e then_id)
emitCond (BoolNot (BoolTest (CmmMachOp op args))) then_id
  | Just op' <- maybeInvertComparison op
  = emitCond (BoolTest (CmmMachOp op' args)) then_id
emitCond (BoolNot e) then_id = do
  else_id <- code newLabelC
  emitCond e else_id
  stmtEC (CmmBranch then_id)
  code (labelC else_id)
emitCond (e1 `BoolOr` e2) then_id = do
  emitCond e1 then_id
  emitCond e2 then_id
emitCond (e1 `BoolAnd` e2) then_id = do
993 994 995 996
        -- we'd like to invert one of the conditionals here to avoid an
        -- extra branch instruction, but we can't use maybeInvertComparison
        -- here because we can't look too closely at the expression since
        -- we're in a loop.
997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015
  and_id <- code newLabelC
  else_id <- code newLabelC
  emitCond e1 and_id
  stmtEC (CmmBranch else_id)
  code (labelC and_id)
  emitCond e2 then_id
  code (labelC else_id)


-- -----------------------------------------------------------------------------
-- Table jumps

-- We use a simplified form of C-- switch statements for now.  A
-- switch statement always compiles to a table jump.  Each arm can
-- specify a list of values (not ranges), and there can be a single
-- default branch.  The range of the table is given either by the
-- optional range on the switch (eg. switch [0..7] {...}), or by
-- the minimum/maximum values from the branches.

1016
doSwitch :: Maybe (Int,Int) -> ExtFCode CmmExpr -> [([Int],Either BlockId ExtCode)]
1017 1018
         -> Maybe ExtCode -> ExtCode
doSwitch mb_range scrut arms deflt
1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040
   = do
        -- Compile code for the default branch
        dflt_entry <-
                case deflt of
                  Nothing -> return Nothing
                  Just e  -> do b <- forkLabelledCodeEC e; return (Just b)

        -- Compile each case branch
        table_entries <- mapM emitArm arms

        -- Construct the table
        let
            all_entries = concat table_entries
            ixs = map fst all_entries
            (min,max)
                | Just (l,u) <- mb_range = (l,u)
                | otherwise              = (minimum ixs, maximum ixs)

            entries = elems (accumArray (\_ a -> Just a) dflt_entry (min,max)
                                all_entries)
        expr <- scrut
        -- ToDo: check for out of range and jump to default if necessary
1041 1042
        stmtEC (CmmSwitch expr entries)
   where
1043 1044 1045 1046 1047
        emitArm :: ([Int],Either BlockId ExtCode) -> ExtFCode [(Int,BlockId)]
        emitArm (ints,Left blockid) = return [ (i,blockid) | i <- ints ]
        emitArm (ints,Right code) = do
           blockid <- forkLabelledCodeEC code
           return [ (i,blockid) | i <- ints ]
1048 1049 1050 1051 1052 1053

-- -----------------------------------------------------------------------------
-- Putting it all together

-- The initial environment: we define some constants that the compiler
-- knows about here.
1054 1055
initEnv :: DynFlags -> Env
initEnv dflags = listToUFM [
1056
  ( fsLit "SIZEOF_StgHeader",
1057
    VarN (CmmLit (CmmInt (fromIntegral (fixedHdrSize dflags * wORD_SIZE dflags)) (wordWidth dflags)) )),
Ian Lynagh's avatar
Ian Lynagh committed
1058
  ( fsLit "SIZEOF_StgInfoTable",
1059
    VarN (CmmLit (CmmInt (fromIntegral (stdInfoTableSizeB dflags)) (wordWidth dflags)) ))
1060 1061
  ]

Simon Peyton Jones's avatar
Simon Peyton Jones committed
1062
parseCmmFile :: DynFlags -> FilePath -> IO (Messages, Maybe CmmGroup)
Simon Marlow's avatar
Simon Marlow committed
1063
parseCmmFile dflags filename = do
1064 1065 1066
  showPass dflags "ParseCmm"
  buf <- hGetStringBuffer filename
  let
1067 1068 1069 1070
        init_loc = mkRealSrcLoc (mkFastString filename) 1 1
        init_state = (mkPState dflags buf init_loc) { lex_state = [0] }
                -- reset the lex_state: the Lexer monad leaves some stuff
                -- in there we don't want.
1071
  case unP cmmParse init_state of
1072
    PFailed span err -> do
Ian Lynagh's avatar
Ian Lynagh committed
1073
        let msg = mkPlainErrMsg dflags span err
1074
        return ((emptyBag, unitBag msg), Nothing)
1075
    POk pst code -> do
1076
        st <- initC
1077
        let (cmm,_) = runC dflags no_module st (getCmm (unEC code (initEnv dflags) [] >> return ()))
1078 1079 1080 1081
        let ms = getMessages pst
        if (errorsFound dflags ms)
         then return (ms, Nothing)
         else do
Ian Lynagh's avatar
Ian Lynagh committed
1082
           dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (ppr cmm)
1083
           return (ms, Just cmm)
1084
  where
1085
        no_module = panic "parseCmmFile: no module"
1086
}