CmmParse.y 55.2 KB
Newer Older
1 2
-----------------------------------------------------------------------------
--
3
-- (c) The University of Glasgow, 2004-2012
4 5 6 7 8
--
-- Parser for concrete Cmm.
--
-----------------------------------------------------------------------------

9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91
{- -----------------------------------------------------------------------------
Note [Syntax of .cmm files]

NOTE: You are very much on your own in .cmm.  There is very little
error checking at all:

  * Type errors are detected by the (optional) -dcmm-lint pass, if you
    don't turn this on then a type error will likely result in a panic
    from the native code generator.

  * Passing the wrong number of arguments or arguments of the wrong
    type is not detected.

There are two ways to write .cmm code:

 (1) High-level Cmm code delegates the stack handling to GHC, and
     never explicitly mentions Sp or registers.

 (2) Low-level Cmm manages the stack itself, and must know about
     calling conventions.

Whether you want high-level or low-level Cmm is indicated by the
presence of an argument list on a procedure.  For example:

foo ( gcptr a, bits32 b )
{
  // this is high-level cmm code

  if (b > 0) {
     // we can make tail calls passing arguments:
     jump stg_ap_0_fast(a);
  }

  push (stg_upd_frame_info, a) {
    // stack frames can be explicitly pushed

    (x,y) = call wibble(a,b,3,4);
      // calls pass arguments and return results using the native
      // Haskell calling convention.  The code generator will automatically
      // construct a stack frame and an info table for the continuation.

    return (x,y);
      // we can return multiple values from the current proc
  }
}

bar
{
  // this is low-level cmm code, indicated by the fact that we did not
  // put an argument list on bar.

  x = R1;  // the calling convention is explicit: better be careful
           // that this works on all platforms!

  jump %ENTRY_CODE(Sp(0))
}

Here is a list of rules for high-level and low-level code.  If you
break the rules, you get a panic (for using a high-level construct in
a low-level proc), or wrong code (when using low-level code in a
high-level proc).  This stuff isn't checked! (TODO!)

High-level only:

  - tail-calls with arguments, e.g.
    jump stg_fun (arg1, arg2);

  - function calls:
    (ret1,ret2) = call stg_fun (arg1, arg2);

    This makes a call with the NativeNodeCall convention, and the
    values are returned to the following code using the NativeReturn
    convention.

  - returning:
    return (ret1, ret2)

    These use the NativeReturn convention to return zero or more
    results to the caller.

  - pushing stack frames:
    push (info_ptr, field1, ..., fieldN) { ... statements ... }

92 93 94 95 96 97 98 99 100 101 102 103 104
  - reserving temporary stack space:

      reserve N = x { ... }

    this reserves an area of size N (words) on the top of the stack,
    and binds its address to x (a local register).  Typically this is
    used for allocating temporary storage for passing to foreign
    functions.

    Note that if you make any native calls or invoke the GC in the
    scope of the reserve block, you are responsible for ensuring that
    the stack you reserved is laid out correctly with an info table.

105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124
Low-level only:

  - References to Sp, R1-R8, F1-F4 etc.

    NB. foreign calls may clobber the argument registers R1-R8, F1-F4
    etc., so ensure they are saved into variables around foreign
    calls.

  - SAVE_THREAD_STATE() and LOAD_THREAD_STATE(), which modify Sp
    directly.

Both high-level and low-level code can use a raw tail-call:

    jump stg_fun [R1,R2]

NB. you *must* specify the list of GlobalRegs that are passed via a
jump, otherwise the register allocator will assume that all the
GlobalRegs are dead at the jump.


125 126 127 128 129 130 131 132 133 134 135 136 137
Calling Conventions
-------------------

High-level procedures use the NativeNode calling convention, or the
NativeReturn convention if the 'return' keyword is used (see Stack
Frames below).

Low-level procedures implement their own calling convention, so it can
be anything at all.

If a low-level procedure implements the NativeNode calling convention,
then it can be called by high-level code using an ordinary function
call.  In general this is hard to arrange because the calling
Gabor Greif's avatar
Gabor Greif committed
138
convention depends on the number of physical registers available for
139
parameter passing, but there are two cases where the calling
Gabor Greif's avatar
Gabor Greif committed
140
convention is platform-independent:
141 142 143 144 145 146 147 148 149 150 151 152 153

 - Zero arguments.

 - One argument of pointer or non-pointer word type; this is always
   passed in R1 according to the NativeNode convention.

 - Returning a single value; these conventions are fixed and platform
   independent.


Stack Frames
------------

154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192
A stack frame is written like this:

INFO_TABLE_RET ( label, FRAME_TYPE, info_ptr, field1, ..., fieldN )
               return ( arg1, ..., argM )
{
  ... code ...
}

where field1 ... fieldN are the fields of the stack frame (with types)
arg1...argN are the values returned to the stack frame (with types).
The return values are assumed to be passed according to the
NativeReturn convention.

On entry to the code, the stack frame looks like:

   |----------|
   | fieldN   |
   |   ...    |
   | field1   |
   |----------|
   | info_ptr |
   |----------|
   |  argN    |
   |   ...    | <- Sp

and some of the args may be in registers.

We prepend the code by a copyIn of the args, and assign all the stack
frame fields to their formals.  The initial "arg offset" for stack
layout purposes consists of the whole stack frame plus any args that
might be on the stack.

A tail-call may pass a stack frame to the callee using the following
syntax:

jump f (info_ptr, field1,..,fieldN) (arg1,..,argN)

where info_ptr and field1..fieldN describe the stack frame, and
arg1..argN are the arguments passed to f using the NativeNodeCall
193 194
convention. Note if a field is longer than a word (e.g. a D_ on
a 32-bit machine) then the call will push as many words as
195
necessary to the stack to accommodate it (e.g. 2).
196

197 198

----------------------------------------------------------------------------- -}
199

200
{
201 202
{-# LANGUAGE TupleSections #-}

203 204
module CmmParse ( parseCmmFile ) where

205 206
import GhcPrelude

207
import GHC.StgToCmm.ExtCode
208
import CmmCallConv
209 210 211 212 213 214 215 216 217 218 219 220 221
import GHC.StgToCmm.Prof
import GHC.StgToCmm.Heap
import GHC.StgToCmm.Monad hiding ( getCode, getCodeR, getCodeScoped, emitLabel, emit
                               , emitStore, emitAssign, emitOutOfLine, withUpdFrameOff
                               , getUpdFrameOff )
import qualified GHC.StgToCmm.Monad as F
import GHC.StgToCmm.Utils
import GHC.StgToCmm.Foreign
import GHC.StgToCmm.Expr
import GHC.StgToCmm.Closure
import GHC.StgToCmm.Layout     hiding (ArgRep(..))
import GHC.StgToCmm.Ticky
import GHC.StgToCmm.Bind  ( emitBlackHoleCode, emitUpdateFrame )
222
import CoreSyn          ( Tickish(SourceNote) )
223

224
import CmmOpt
225 226
import MkGraph
import Cmm
227
import CmmUtils
228
import CmmSwitch        ( mkSwitchTargets )
229
import CmmInfo
230
import BlockId
231 232
import CmmLex
import CLabel
233
import SMRep
234
import Lexer
235
import CmmMonad
236

237
import CostCentre
238
import ForeignCall
239
import Module
240
import GHC.Platform
241
import Literal
242 243 244
import Unique
import UniqFM
import SrcLoc
245 246 247
import DynFlags
import ErrUtils
import StringBuffer
248
import FastString
249 250
import Panic
import Constants
251
import Outputable
252
import BasicTypes
253
import Bag              ( emptyBag, unitBag )
254
import Var
255

256
import Control.Monad
257
import Data.Array
258
import Data.Char        ( ord )
259
import System.Exit
260
import Data.Maybe
261
import qualified Data.Map as M
262
import qualified Data.ByteString.Char8 as BS8
263 264

#include "HsVersions.h"
265 266
}

267 268
%expect 0

269
%token
270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301
        ':'     { 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) }
302 303 304
        '&&'    { L _ (CmmT_BoolAnd) }
        '||'    { L _ (CmmT_BoolOr) }

305 306 307 308
        'True'  { L _ (CmmT_True ) }
        'False' { L _ (CmmT_False) }
        'likely'{ L _ (CmmT_likely)}

309
        'CLOSURE'       { L _ (CmmT_CLOSURE) }
Simon Marlow's avatar
Simon Marlow committed
310 311 312 313 314 315 316 317 318 319
        '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) }
        'goto'          { L _ (CmmT_goto) }
        'if'            { L _ (CmmT_if) }
320 321 322
        'call'          { L _ (CmmT_call) }
        'jump'          { L _ (CmmT_jump) }
        'foreign'       { L _ (CmmT_foreign) }
Simon Marlow's avatar
Simon Marlow committed
323 324
        'never'         { L _ (CmmT_never) }
        'prim'          { L _ (CmmT_prim) }
325
        'reserve'       { L _ (CmmT_reserve) }
Simon Marlow's avatar
Simon Marlow committed
326 327 328 329 330
        'return'        { L _ (CmmT_return) }
        'returns'       { L _ (CmmT_returns) }
        'import'        { L _ (CmmT_import) }
        'switch'        { L _ (CmmT_switch) }
        'case'          { L _ (CmmT_case) }
331 332
        'default'       { L _ (CmmT_default) }
        'push'          { L _ (CmmT_push) }
333
        'unwind'        { L _ (CmmT_unwind) }
334
        'bits8'         { L _ (CmmT_bits8) }
Simon Marlow's avatar
Simon Marlow committed
335 336 337
        'bits16'        { L _ (CmmT_bits16) }
        'bits32'        { L _ (CmmT_bits32) }
        'bits64'        { L _ (CmmT_bits64) }
338
        'bits128'       { L _ (CmmT_bits128) }
339
        'bits256'       { L _ (CmmT_bits256) }
340
        'bits512'       { L _ (CmmT_bits512) }
Simon Marlow's avatar
Simon Marlow committed
341 342 343 344 345 346 347 348 349
        '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       $$) }
350

351
%monad { PD } { >>= } { return }
352 353 354 355 356
%lexer { cmmlex } { L _ CmmT_EOF }
%name cmmParse cmm
%tokentype { Located CmmToken }

-- C-- operator precedences, taken from the C-- spec
357 358
%right '||'     -- non-std extension, called %disjoin in C--
%right '&&'     -- non-std extension, called %conjoin in C--
359 360 361 362 363 364 365 366 367 368 369 370
%right '!'
%nonassoc '>=' '>' '<=' '<' '!=' '=='
%left '|'
%left '^'
%left '&'
%left '>>' '<<'
%left '-' '+'
%left '/' '*' '%'
%right '~'

%%

371
cmm     :: { CmmParse () }
Simon Marlow's avatar
Simon Marlow committed
372 373
        : {- empty -}                   { return () }
        | cmmtop cmm                    { do $1; $2 }
374

375
cmmtop  :: { CmmParse () }
Simon Marlow's avatar
Simon Marlow committed
376 377
        : cmmproc                       { $1 }
        | cmmdata                       { $1 }
378 379
        | decl                          { $1 }
        | 'CLOSURE' '(' NAME ',' NAME lits ')' ';'
380
                {% liftP . withThisPackage $ \pkg ->
381 382
                   do lits <- sequence $6;
                      staticClosure pkg $3 $5 (map getLit lits) }
383 384 385 386 387

-- 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:
388 389 390 391
--      * 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
392

393
cmmdata :: { CmmParse () }
394
        : 'section' STRING '{' data_label statics '}'
Simon Marlow's avatar
Simon Marlow committed
395 396
                { do lbl <- $4;
                     ss <- sequence $5;
397
                     code (emitDecl (CmmData (Section (section $2) lbl) (Statics lbl $ concat ss))) }
398 399

data_label :: { CmmParse CLabel }
400
    : NAME ':'
401
                {% liftP . withThisPackage $ \pkg ->
Simon Marlow's avatar
Simon Marlow committed
402
                   return (mkCmmDataLabel pkg $1) }
403

Simon Marlow's avatar
Simon Marlow committed
404 405 406
statics :: { [CmmParse [CmmStatic]] }
        : {- empty -}                   { [] }
        | static statics                { $1 : $2 }
407

408
static  :: { CmmParse [CmmStatic] }
Simon Marlow's avatar
Simon Marlow committed
409 410 411 412 413
        : type expr ';' { do e <- $2;
                             return [CmmStaticLit (getLit e)] }
        | type ';'                      { return [CmmUninitialised
                                                        (widthInBytes (typeWidth $1))] }
        | 'bits8' '[' ']' STRING ';'    { return [mkString $4] }
414
        | 'bits8' '[' INT ']' ';'       { return [CmmUninitialised
Simon Marlow's avatar
Simon Marlow committed
415
                                                        (fromIntegral $3)] }
416 417
        | typenot8 '[' INT ']' ';'      { return [CmmUninitialised
                                                (widthInBytes (typeWidth $1) *
Simon Marlow's avatar
Simon Marlow committed
418
                                                        fromIntegral $3)] }
419
        | 'CLOSURE' '(' NAME lits ')'
Simon Marlow's avatar
Simon Marlow committed
420
                { do { lits <- sequence $4
421
                ; dflags <- getDynFlags
422
                     ; return $ map CmmStaticLit $
423
                        mkStaticClosure dflags (mkForeignLabel $3 Nothing ForeignLabelInExternalPackage IsData)
424 425
                         -- mkForeignLabel because these are only used
                         -- for CHARLIKE and INTLIKE closures in the RTS.
426
                        dontCareCCS (map getLit lits) [] [] [] } }
427
        -- arrays of closures required for the CHARLIKE & INTLIKE arrays
428

429
lits    :: { [CmmParse CmmExpr] }
Simon Marlow's avatar
Simon Marlow committed
430 431
        : {- empty -}           { [] }
        | ',' expr lits         { $2 : $3 }
432 433 434 435

cmmproc :: { CmmParse () }
        : info maybe_conv maybe_formals maybe_body
                { do ((entry_ret_label, info, stk_formals, formals), agraph) <-
Peter Wortmann's avatar
Peter Wortmann committed
436
                       getCodeScoped $ loopDecls $ do {
437
                         (entry_ret_label, info, stk_formals) <- $1;
438
                         dflags <- getDynFlags;
439
                         formals <- sequence (fromMaybe [] $3);
440 441
                         withName (showSDoc dflags (ppr entry_ret_label))
                           $4;
442 443 444 445 446
                         return (entry_ret_label, info, stk_formals, formals) }
                     let do_layout = isJust $3
                     code (emitProcWithStackFrame $2 info
                                entry_ret_label stk_formals formals agraph
                                do_layout ) }
447

448 449 450
maybe_conv :: { Convention }
           : {- empty -}        { NativeNodeCall }
           | 'return'           { NativeReturn }
451

452 453
maybe_body :: { CmmParse () }
           : ';'                { return () }
454
           | '{' body '}'       { withSourceNote $1 $3 $2 }
455 456 457

info    :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }
        : NAME
458
                {% liftP . withThisPackage $ \pkg ->
Simon Marlow's avatar
Simon Marlow committed
459
                   do   newFunctionName $1 pkg
460 461 462 463
                        return (mkCmmCodeLabel pkg $1, Nothing, []) }


        | 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
Simon Marlow's avatar
Simon Marlow committed
464
                -- ptrs, nptrs, closure type, description, type
465
                {% liftP . withThisPackage $ \pkg ->
466 467
                   do dflags <- getDynFlags
                      let prof = profilingInfo dflags $11 $13
468
                          rep  = mkRTSRep (fromIntegral $9) $
469
                                   mkHeapRep dflags False (fromIntegral $5)
470 471 472 473
                                                   (fromIntegral $7) Thunk
                              -- not really Thunk, but that makes the info table
                              -- we want.
                      return (mkCmmEntryLabel pkg $3,
474
                              Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
Simon Marlow's avatar
Simon Marlow committed
475
                                           , cit_rep = rep
476
                                           , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },
Simon Marlow's avatar
Simon Marlow committed
477
                              []) }
478

479
        | 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ')'
Simon Marlow's avatar
Simon Marlow committed
480
                -- ptrs, nptrs, closure type, description, type, fun type
481
                {% liftP . withThisPackage $ \pkg ->
482 483
                   do dflags <- getDynFlags
                      let prof = profilingInfo dflags $11 $13
484
                          ty   = Fun 0 (ArgSpec (fromIntegral $15))
485
                                -- Arity zero, arg_type $15
486
                          rep = mkRTSRep (fromIntegral $9) $
487
                                    mkHeapRep dflags False (fromIntegral $5)
488 489
                                                    (fromIntegral $7) ty
                      return (mkCmmEntryLabel pkg $3,
490
                              Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
Simon Marlow's avatar
Simon Marlow committed
491
                                           , cit_rep = rep
492
                                           , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },
Simon Marlow's avatar
Simon Marlow committed
493 494 495
                              []) }
                -- we leave most of the fields zero here.  This is only used
                -- to generate the BCO info table in the RTS at the moment.
496 497

        | 'INFO_TABLE_CONSTR' '(' NAME ',' INT ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
498
                -- ptrs, nptrs, tag, closure type, description, type
499
                {% liftP . withThisPackage $ \pkg ->
500 501
                   do dflags <- getDynFlags
                      let prof = profilingInfo dflags $13 $15
502
                          ty  = Constr (fromIntegral $9)  -- Tag
503
                                       (BS8.pack $13)
504
                          rep = mkRTSRep (fromIntegral $11) $
505
                                  mkHeapRep dflags False (fromIntegral $5)
506 507
                                                  (fromIntegral $7) ty
                      return (mkCmmEntryLabel pkg $3,
508
                              Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
Simon Marlow's avatar
Simon Marlow committed
509
                                           , cit_rep = rep
510
                                           , cit_prof = prof, cit_srt = Nothing,cit_clo = Nothing },
Simon Marlow's avatar
Simon Marlow committed
511
                              []) }
512

Simon Marlow's avatar
Simon Marlow committed
513 514
                     -- 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.
515

516
        | 'INFO_TABLE_SELECTOR' '(' NAME ',' INT ',' INT ',' STRING ',' STRING ')'
Simon Marlow's avatar
Simon Marlow committed
517
                -- selector, closure type, description, type
518
                {% liftP . withThisPackage $ \pkg ->
519 520
                   do dflags <- getDynFlags
                      let prof = profilingInfo dflags $9 $11
521 522
                          ty  = ThunkSelector (fromIntegral $5)
                          rep = mkRTSRep (fromIntegral $7) $
523
                                   mkHeapRep dflags False 0 0 ty
524
                      return (mkCmmEntryLabel pkg $3,
525
                              Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
Simon Marlow's avatar
Simon Marlow committed
526
                                           , cit_rep = rep
527
                                           , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },
Simon Marlow's avatar
Simon Marlow committed
528
                              []) }
529 530

        | 'INFO_TABLE_RET' '(' NAME ',' INT ')'
Simon Marlow's avatar
Simon Marlow committed
531
                -- closure type (no live regs)
532
                {% liftP . withThisPackage $ \pkg ->
Simon Marlow's avatar
Simon Marlow committed
533
                   do let prof = NoProfilingInfo
534
                          rep  = mkRTSRep (fromIntegral $5) $ mkStackRep []
535
                      return (mkCmmRetLabel pkg $3,
536
                              Just $ CmmInfoTable { cit_lbl = mkCmmRetInfoLabel pkg $3
Simon Marlow's avatar
Simon Marlow committed
537
                                           , cit_rep = rep
538
                                           , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },
Simon Marlow's avatar
Simon Marlow committed
539
                              []) }
540 541

        | 'INFO_TABLE_RET' '(' NAME ',' INT ',' formals0 ')'
Simon Marlow's avatar
Simon Marlow committed
542
                -- closure type, live regs
543
                {% liftP . withThisPackage $ \pkg ->
544
                   do dflags <- getDynFlags
545
                      live <- sequence $7
Simon Marlow's avatar
Simon Marlow committed
546
                      let prof = NoProfilingInfo
547
                          -- drop one for the info pointer
548
                          bitmap = mkLiveness dflags (drop 1 live)
549
                          rep  = mkRTSRep (fromIntegral $5) $ mkStackRep bitmap
550
                      return (mkCmmRetLabel pkg $3,
551
                              Just $ CmmInfoTable { cit_lbl = mkCmmRetInfoLabel pkg $3
Simon Marlow's avatar
Simon Marlow committed
552
                                           , cit_rep = rep
553
                                           , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },
554
                              live) }
555

556
body    :: { CmmParse () }
Simon Marlow's avatar
Simon Marlow committed
557 558 559
        : {- empty -}                   { return () }
        | decl body                     { do $1; $2 }
        | stmt body                     { do $1; $2 }
560

561
decl    :: { CmmParse () }
Simon Marlow's avatar
Simon Marlow committed
562 563 564
        : type names ';'                { mapM_ (newLocal $1) $2 }
        | 'import' importNames ';'      { mapM_ newImport $2 }
        | 'export' names ';'            { return () }  -- ignore exports
565

566 567

-- an imported function name, with optional packageId
568 569 570 571 572
importNames
        :: { [(FastString, CLabel)] }
        : importName                    { [$1] }
        | importName ',' importNames    { $1 : $3 }

573
importName
574 575
        :: { (FastString,  CLabel) }

Simon Marlow's avatar
Simon Marlow committed
576 577
        -- A label imported without an explicit packageId.
        --      These are taken to come frome some foreign, unnamed package.
578
        : NAME
Simon Marlow's avatar
Simon Marlow committed
579 580
        { ($1, mkForeignLabel $1 Nothing ForeignLabelInExternalPackage IsFunction) }

581 582 583 584
        -- as previous 'NAME', but 'IsData'
        | 'CLOSURE' NAME
        { ($2, mkForeignLabel $2 Nothing ForeignLabelInExternalPackage IsData) }

Simon Marlow's avatar
Simon Marlow committed
585 586
        -- A label imported with an explicit packageId.
        | STRING NAME
587
        { ($2, mkCmmCodeLabel (fsToUnitId (mkFastString $1)) $2) }
588 589


Simon Marlow's avatar
Simon Marlow committed
590 591 592 593 594
names   :: { [FastString] }
        : NAME                          { [$1] }
        | NAME ',' names                { $1 : $3 }

stmt    :: { CmmParse () }
595 596
        : ';'                                   { return () }

Simon Marlow's avatar
Simon Marlow committed
597
        | NAME ':'
598 599 600 601
                { do l <- newLabel $1; emitLabel l }



Simon Marlow's avatar
Simon Marlow committed
602
        | lreg '=' expr ';'
603
                { do reg <- $1; e <- $3; withSourceNote $2 $4 (emitAssign reg e) }
Simon Marlow's avatar
Simon Marlow committed
604
        | type '[' expr ']' '=' expr ';'
605
                { withSourceNote $2 $7 (doStore $1 $3 $6) }
606 607

        -- Gah! We really want to say "foreign_results" but that causes
Simon Marlow's avatar
Simon Marlow committed
608 609 610 611 612
        -- 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.
613
        | foreign_results 'foreign' STRING foreignLabel '(' cmm_hint_exprs0 ')' safety opt_never_returns ';'
614 615 616
                {% foreignCall $3 $1 $4 $6 $8 $9 }
        | foreign_results 'prim' '%' NAME '(' exprs0 ')' ';'
                {% primCall $1 $4 $6 }
Simon Marlow's avatar
Simon Marlow committed
617 618 619 620 621 622 623
        -- 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 ';'
624 625 626
                { do l <- lookupLabel $2; emit (mkBranch l) }
        | 'return' '(' exprs0 ')' ';'
                { doReturn $3 }
627
        | 'jump' expr vols ';'
628 629 630 631 632 633 634 635 636
                { doRawJump $2 $3 }
        | 'jump' expr '(' exprs0 ')' ';'
                { doJumpWithStack $2 [] $4 }
        | 'jump' expr '(' exprs0 ')' '(' exprs0 ')' ';'
                { doJumpWithStack $2 $4 $7 }
        | 'call' expr '(' exprs0 ')' ';'
                { doCall $2 [] $4 }
        | '(' formals ')' '=' 'call' expr '(' exprs0 ')' ';'
                { doCall $6 $2 $8 }
637 638 639 640
        | 'if' bool_expr cond_likely 'goto' NAME
                { do l <- lookupLabel $5; cmmRawIf $2 l $3 }
        | 'if' bool_expr cond_likely '{' body '}' else
                { cmmIfThenElse $2 (withSourceNote $4 $6 $5) $7 $3 }
641 642
        | 'push' '(' exprs0 ')' maybe_body
                { pushStackFrame $3 $5 }
643 644
        | 'reserve' expr '=' lreg maybe_body
                { reserveStackFrame $2 $4 $5 }
645 646 647 648
        | 'unwind' unwind_regs ';'
                { $2 >>= code . emitUnwind }

unwind_regs
649 650
        :: { CmmParse [(GlobalReg, Maybe CmmExpr)] }
        : GLOBALREG '=' expr_or_unknown ',' unwind_regs
651
                { do e <- $3; rest <- $5; return (($1, e) : rest) }
652
        | GLOBALREG '=' expr_or_unknown
653
                { do e <- $3; return [($1, e)] }
654

655 656 657 658 659 660 661 662
-- | Used by unwind to indicate unknown unwinding values.
expr_or_unknown
        :: { CmmParse (Maybe CmmExpr) }
        : 'return'
                { do return Nothing }
        | expr
                { do e <- $1; return (Just e) }

663
foreignLabel     :: { CmmParse CmmExpr }
664
        : NAME                          { return (CmmLit (CmmLabel (mkForeignLabel $1 Nothing ForeignLabelInThisPackage IsFunction))) }
665

666 667 668
opt_never_returns :: { CmmReturnInfo }
        :                               { CmmMayReturn }
        | 'never' 'returns'             { CmmNeverReturns }
669

670
bool_expr :: { CmmParse BoolExpr }
Simon Marlow's avatar
Simon Marlow committed
671 672
        : bool_op                       { $1 }
        | expr                          { do e <- $1; return (BoolTest e) }
673 674

bool_op :: { CmmParse BoolExpr }
675
        : bool_expr '&&' bool_expr      { do e1 <- $1; e2 <- $3;
Simon Marlow's avatar
Simon Marlow committed
676
                                          return (BoolAnd e1 e2) }
677
        | bool_expr '||' bool_expr      { do e1 <- $1; e2 <- $3;
Simon Marlow's avatar
Simon Marlow committed
678 679 680
                                          return (BoolOr e1 e2)  }
        | '!' bool_expr                 { do e <- $2; return (BoolNot e) }
        | '(' bool_op ')'               { $2 }
681 682 683

safety  :: { Safety }
        : {- empty -}                   { PlayRisky }
Simon Marlow's avatar
Simon Marlow committed
684
        | STRING                        {% parseSafety $1 }
685 686 687 688

vols    :: { [GlobalReg] }
        : '[' ']'                       { [] }
        | '[' '*' ']'                   {% do df <- getDynFlags
689 690 691
                                         ; return (realArgRegsCover df) }
                                           -- All of them. See comment attached
                                           -- to realArgRegsCover
692
        | '[' globals ']'               { $2 }
693 694

globals :: { [GlobalReg] }
695 696
        : GLOBALREG                     { [$1] }
        | GLOBALREG ',' globals         { $1 : $3 }
697

698 699
maybe_range :: { Maybe (Integer,Integer) }
        : '[' INT '..' INT ']'  { Just ($2, $4) }
700
        | {- empty -}           { Nothing }
701

702
arms    :: { [CmmParse ([Integer],Either BlockId (CmmParse ()))] }
Simon Marlow's avatar
Simon Marlow committed
703 704
        : {- empty -}                   { [] }
        | arm arms                      { $1 : $2 }
705

706
arm     :: { CmmParse ([Integer],Either BlockId (CmmParse ())) }
Simon Marlow's avatar
Simon Marlow committed
707
        : 'case' ints ':' arm_body      { do b <- $4; return ($2, b) }
708

709
arm_body :: { CmmParse (Either BlockId (CmmParse ())) }
710
        : '{' body '}'                  { return (Right (withSourceNote $1 $3 $2)) }
Simon Marlow's avatar
Simon Marlow committed
711
        | 'goto' NAME ';'               { do l <- lookupLabel $2; return (Left l) }
712

713 714 715
ints    :: { [Integer] }
        : INT                           { [ $1 ] }
        | INT ',' ints                  { $1 : $3 }
716

717
default :: { Maybe (CmmParse ()) }
718
        : 'default' ':' '{' body '}'    { Just (withSourceNote $3 $5 $4) }
Simon Marlow's avatar
Simon Marlow committed
719 720 721
        -- taking a few liberties with the C-- syntax here; C-- doesn't have
        -- 'default' branches
        | {- empty -}                   { Nothing }
722

723 724
-- Note: OldCmm doesn't support a first class 'else' statement, though
-- CmmNode does.
725 726
else    :: { CmmParse () }
        : {- empty -}                   { return () }
727
        | 'else' '{' body '}'           { withSourceNote $2 $4 $3 }
728

729 730 731 732 733 734
cond_likely :: { Maybe Bool }
        : '(' 'likely' ':' 'True'  ')'  { Just True  }
        | '(' 'likely' ':' 'False' ')'  { Just False }
        | {- empty -}                   { Nothing }


735 736
-- we have to write this out longhand so that Happy's precedence rules
-- can kick in.
737
expr    :: { CmmParse CmmExpr }
Simon Marlow's avatar
Simon Marlow committed
738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762
        : 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   :: { CmmParse CmmExpr }
        : INT   maybe_ty         { return (CmmLit (CmmInt $1 (typeWidth $2))) }
        | FLOAT maybe_ty         { return (CmmLit (CmmFloat $1 (typeWidth $2))) }
763
        | STRING                 { do s <- code (newStringCLit $1);
Simon Marlow's avatar
Simon Marlow committed
764 765 766 767 768
                                      return (CmmLit s) }
        | reg                    { $1 }
        | type '[' expr ']'      { do e <- $3; return (CmmLoad e $1) }
        | '%' NAME '(' exprs0 ')' {% exprOp $2 $4 }
        | '(' expr ')'           { $2 }
769 770 771


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

776
cmm_hint_exprs0 :: { [CmmParse (CmmExpr, ForeignHint)] }
Simon Marlow's avatar
Simon Marlow committed
777
        : {- empty -}                   { [] }
778
        | cmm_hint_exprs                { $1 }
779

780
cmm_hint_exprs :: { [CmmParse (CmmExpr, ForeignHint)] }
Simon Marlow's avatar
Simon Marlow committed
781 782
        : cmm_hint_expr                 { [$1] }
        | cmm_hint_expr ',' cmm_hint_exprs      { $1 : $3 }
783

784 785 786
cmm_hint_expr :: { CmmParse (CmmExpr, ForeignHint) }
        : expr                          { do e <- $1;
                                             return (e, inferCmmHint e) }
Simon Marlow's avatar
Simon Marlow committed
787 788
        | expr STRING                   {% do h <- parseCmmHint $2;
                                              return $ do
789
                                                e <- $1; return (e, h) }
790

791
exprs0  :: { [CmmParse CmmExpr] }
Simon Marlow's avatar
Simon Marlow committed
792 793
        : {- empty -}                   { [] }
        | exprs                         { $1 }
794

795
exprs   :: { [CmmParse CmmExpr] }
Simon Marlow's avatar
Simon Marlow committed
796 797
        : expr                          { [ $1 ] }
        | expr ',' exprs                { $1 : $3 }
798

799
reg     :: { CmmParse CmmExpr }
Simon Marlow's avatar
Simon Marlow committed
800 801
        : NAME                  { lookupName $1 }
        | GLOBALREG             { return (CmmReg (CmmGlobal $1)) }
802 803 804 805 806 807

foreign_results :: { [CmmParse (LocalReg, ForeignHint)] }
        : {- empty -}                   { [] }
        | '(' foreign_formals ')' '='   { $2 }

foreign_formals :: { [CmmParse (LocalReg, ForeignHint)] }
Simon Marlow's avatar
Simon Marlow committed
808
        : foreign_formal                        { [$1] }
809 810 811 812
        | foreign_formal ','                    { [$1] }
        | foreign_formal ',' foreign_formals    { $1 : $3 }

foreign_formal :: { CmmParse (LocalReg, ForeignHint) }
813
        : local_lreg            { do e <- $1; return (e, inferCmmHint (CmmReg (CmmLocal e))) }
814 815 816 817 818
        | STRING local_lreg     {% do h <- parseCmmHint $1;
                                      return $ do
                                         e <- $2; return (e,h) }

local_lreg :: { CmmParse LocalReg }
Simon Marlow's avatar
Simon Marlow committed
819 820
        : NAME                  { do e <- lookupName $1;
                                     return $
821
                                       case e of
Simon Marlow's avatar
Simon Marlow committed
822 823 824 825 826 827
                                        CmmReg (CmmLocal r) -> r
                                        other -> pprPanic "CmmParse:" (ftext $1 <> text " not a local register") }

lreg    :: { CmmParse CmmReg }
        : NAME                  { do e <- lookupName $1;
                                     return $
828
                                       case e of
Simon Marlow's avatar
Simon Marlow committed
829 830 831
                                        CmmReg r -> r
                                        other -> pprPanic "CmmParse:" (ftext $1 <> text " not a register") }
        | GLOBALREG             { return (CmmGlobal $1) }
832 833 834 835 836 837

maybe_formals :: { Maybe [CmmParse LocalReg] }
        : {- empty -}           { Nothing }
        | '(' formals0 ')'      { Just $2 }

formals0 :: { [CmmParse LocalReg] }
Simon Marlow's avatar
Simon Marlow committed
838
        : {- empty -}           { [] }
839 840 841 842 843 844 845 846
        | formals               { $1 }

formals :: { [CmmParse LocalReg] }
        : formal ','            { [$1] }
        | formal                { [$1] }
        | formal ',' formals       { $1 : $3 }

formal :: { CmmParse LocalReg }
Simon Marlow's avatar
Simon Marlow committed
847
        : type NAME             { newLocal $1 $2 }
848

849
type    :: { CmmType }
850 851
        : 'bits8'               { b8 }
        | typenot8              { $1 }
852

853
typenot8 :: { CmmType }
854 855 856
        : 'bits16'              { b16 }
        | 'bits32'              { b32 }
        | 'bits64'              { b64 }
857
        | 'bits128'             { b128 }
858
        | 'bits256'             { b256 }
859
        | 'bits512'             { b512 }
860 861
        | 'float32'             { f32 }
        | 'float64'             { f64 }
862
        | 'gcptr'               {% do dflags <- getDynFlags; return $ gcWord dflags }
863

864
{
865
section :: String -> SectionType
866 867 868
section "text"      = Text
section "data"      = Data
section "rodata"    = ReadOnlyData
869
section "relrodata" = RelocatableReadOnlyData
870 871
section "bss"       = UninitialisedData
section s           = OtherSection s
872

873
mkString :: String -> CmmStatic
874
mkString s = CmmString (BS8.pack s)
875

876 877 878 879 880 881 882 883 884 885 886
-- |
-- Given an info table, decide what the entry convention for the proc
-- is.  That is, for an INFO_TABLE_RET we want the return convention,
-- otherwise it is a NativeNodeCall.
--
infoConv :: Maybe CmmInfoTable -> Convention
infoConv Nothing = NativeNodeCall
infoConv (Just info)
  | isStackRep (cit_rep info) = NativeReturn
  | otherwise                 = NativeNodeCall

887 888 889 890
-- 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.
891
mkMachOp :: (Width -> MachOp) -> [CmmParse CmmExpr] -> CmmParse CmmExpr
892
mkMachOp fn args = do
893
  dflags <- getDynFlags
894
  arg_exprs <- sequence args
895
  return (CmmMachOp (fn (typeWidth (cmmExprType dflags (head arg_exprs)))) arg_exprs)
896 897 898 899 900 901

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

902
nameToMachOp :: FastString -> PD (Width -> MachOp)
903
nameToMachOp name =
904
  case lookupUFM machOps name of
905 906
        Nothing -> fail ("unknown primitive " ++ unpackFS name)
        Just m  -> return m
907

908
exprOp :: FastString -> [CmmParse CmmExpr] -> PD (CmmParse CmmExpr)
909 910 911
exprOp name args_code = do
  dflags <- getDynFlags
  case lookupUFM (exprMacros dflags) name of
912 913
     Just f  -> return $ do
        args <- sequence args_code
914
        return (f args)
915
     Nothing -> do
916 917
        mo <- nameToMachOp name
        return $ mkMachOp mo args_code
918

919 920
exprMacros :: DynFlags -> UniqFM ([CmmExpr] -> CmmExpr)
exprMacros dflags = listToUFM [
921
  ( fsLit "ENTRY_CODE",   \ [x] -> entryCode dflags x ),
922
  ( fsLit "INFO_PTR",     \ [x] -> closureInfoPtr dflags x ),
923 924
  ( fsLit "STD_INFO",     \ [x] -> infoTable dflags x ),
  ( fsLit "FUN_INFO",     \ [x] -> funInfoTable dflags x ),
925 926 927
  ( 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) ),
928 929 930
  ( fsLit "INFO_TYPE",    \ [x] -> infoTableClosureType dflags x ),
  ( fsLit "INFO_PTRS",    \ [x] -> infoTablePtrs dflags x ),
  ( fsLit "INFO_NPTRS",   \ [x] -> infoTableNonPtrs dflags x )
931 932 933 934
  ]

-- we understand a subset of C-- primitives:
machOps = listToUFM $
935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955
        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 ),
956

957
        ( "and",        MO_And ),
958 959 960 961 962 963
        ( "or",         MO_Or ),
        ( "xor",        MO_Xor ),
        ( "com",        MO_Not ),
        ( "shl",        MO_Shl ),
        ( "shrl",       MO_U_Shr ),
        ( "shra",       MO_S_Shr ),
964

965 966 967 968 969 970 971 972 973 974 975 976 977 978
        ( "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  ),
979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999
        ( "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 )
        ]
1000

1001
callishMachOps :: UniqFM ([CmmExpr] -> (CallishMachOp, [CmmExpr]))
1002
callishMachOps = listToUFM $
1003
        map (\(x, y) -> (mkFastString x, y)) [
1004
        ( "read_barrier", (MO_ReadBarrier,)),
1005
        ( "write_barrier", (MO_WriteBarrier,)),
1006 1007 1008
        ( "memcpy", memcpyLikeTweakArgs MO_Memcpy ),
        ( "memset", memcpyLikeTweakArgs MO_Memset ),
        ( "memmove", memcpyLikeTweakArgs MO_Memmove ),
1009
        ( "memcmp", memcpyLikeTweakArgs MO_Memcmp ),
1010

1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034
        ("prefetch0", (MO_Prefetch_Data 0,)),
        ("prefetch1", (MO_Prefetch_Data 1,)),
        ("prefetch2", (MO_Prefetch_Data 2,)),
        ("prefetch3", (MO_Prefetch_Data 3,)),

        ( "popcnt8",  (MO_PopCnt W8,)),
        ( "popcnt16", (MO_PopCnt W16,)),
        ( "popcnt32", (MO_PopCnt W32,)),
        ( "popcnt64", (MO_PopCnt W64,)),

        ( "pdep8",  (MO_Pdep W8,)),
        ( "pdep16", (MO_Pdep W16,)),
        ( "pdep32", (MO_Pdep W32,)),
        ( "pdep64", (MO_Pdep W64,)),

        ( "pext8",  (MO_Pext W8,)),
        ( "pext16", (MO_Pext W16,)),
        ( "pext32", (MO_Pext W32,)),
        ( "pext64", (MO_Pext W64,)),

        ( "cmpxchg8",  (MO_Cmpxchg W8,)),
        ( "cmpxchg16", (MO_Cmpxchg W16,)),
        ( "cmpxchg32", (MO_Cmpxchg W32,)),
        ( "cmpxchg64", (MO_Cmpxchg W64,))
1035

1036
        -- ToDo: the rest, maybe
1037 1038
        -- edit: which rest?
        -- also: how do we tell CMM Lint how to type check callish macops?
1039
    ]
1040 1041 1042 1043
  where
    memcpyLikeTweakArgs :: (Int -> CallishMachOp) -> [CmmExpr] -> (CallishMachOp, [CmmExpr])
    memcpyLikeTweakArgs op [] = pgmError "memcpy-like function requires at least one argument"
    memcpyLikeTweakArgs op args@(_:_) =
1044
        (op align, args')
1045 1046 1047 1048 1049 1050 1051 1052 1053
      where
        args' = init args
        align = case last args of
          CmmLit (CmmInt alignInteger _) -> fromInteger alignInteger
          e -> pprPgmError "Non-constant alignment in memcpy-like function:" (ppr e)
        -- The alignment of memcpy-ish operations must be a
        -- compile-time constant. We verify this here, passing it around
        -- in the MO_* constructor. In order to do this, however, we
        -- must intercept the arguments in primCall.
1054

1055
parseSafety :: String -> PD Safety
1056 1057 1058
parseSafety "safe"   = return PlaySafe
parseSafety "unsafe" = return PlayRisky
parseSafety "interruptible" = return PlayInterruptible
1059 1060
parseSafety str      = fail ("unrecognised safety: " ++ str)

1061
parseCmmHint :: String -> PD ForeignHint
1062 1063 1064
parseCmmHint "ptr"    = return AddrHint
parseCmmHint "signed" = return SignedHint
parseCmmHint str      = fail ("unrecognised hint: " ++ str)
1065

1066
-- labels are always pointers, so we might as well infer the hint
1067 1068 1069 1070 1071
inferCmmHint :: CmmExpr -> ForeignHint
inferCmmHint (CmmLit (CmmLabel _)) = AddrHint
inferCmmHint (CmmReg (CmmGlobal g)) | isPtrGlobalReg g = AddrHint
inferCmmHint _ = NoHint

1072 1073 1074 1075
isPtrGlobalReg Sp                    = True
isPtrGlobalReg SpLim                 = True
isPtrGlobalReg Hp                    = True
isPtrGlobalReg HpLim                 = True
1076 1077 1078
isPtrGlobalReg CCCS                  = True
isPtrGlobalReg CurrentTSO            = True
isPtrGlobalReg CurrentNursery        = True
1079
isPtrGlobalReg (VanillaReg _ VGcPtr) = True
1080
isPtrGlobalReg _                     = False
1081

1082 1083
happyError :: PD a
happyError = PD $ \_ s -> unP srcParseFail s
1084 1085 1086 1087

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

1088
stmtMacro :: FastString -> [CmmParse CmmExpr] -> PD (CmmParse ())
1089 1090 1091 1092
stmtMacro fun args_code = do
  case lookupUFM stmtMacros fun of
    Nothing -> fail ("unknown macro: " ++ unpackFS fun)
    Just fcode -> return $ do
1093 1094
        args <- sequence args_code
        code (fcode args)
1095

1096
stmtMacros :: UniqFM ([CmmExpr] -> FCode ())
1097
stmtMacros = listToUFM [
1098
  ( fsLit "CCS_ALLOC",             \[words,ccs]  -> profAlloc words ccs ),
1099 1100
  ( fsLit "ENTER_CCS_THUNK",       \[e] -> enterCostCentreThunk e ),

1101 1102
  ( fsLit "CLOSE_NURSERY",         \[]  -> emitCloseNursery ),
  ( fsLit "OPEN_NURSERY",          \[]  -> emitOpenNursery ),
1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123

  -- completely generic heap and stack checks, for use in high-level cmm.
  ( fsLit "HP_CHK_GEN",            \[bytes] ->
                                      heapStackCheckGen Nothing (Just bytes) ),
  ( fsLit "STK_CHK_GEN",           \[] ->
                                      heapStackCheckGen (Just (CmmLit CmmHighStackMark)) Nothing ),

  -- A stack check for a fixed amount of stack.  Sounds a bit strange, but
  -- we use the stack for a bit of temporary storage in a couple of primops
  ( fsLit "STK_CHK_GEN_N",         \[bytes] ->
                                      heapStackCheckGen (Just bytes) Nothing ),

  -- A stack check on entry to a thunk, where the argument is the thunk pointer.
  ( fsLit "STK_CHK_NP"   ,         \[node] -> entryHeapCheck' False node 0 [] (return ())),

  ( fsLit "LOAD_THREAD_STATE",     \[] -> emitLoadThreadState ),
  ( fsLit "SAVE_THREAD_STATE",     \[] -> emitSaveThreadState ),

  ( fsLit "LDV_ENTER",             \[e] -> ldvEnter e ),
  ( fsLit "LDV_RECORD_CREATE",     \[e] -> ldvRecordCreate e ),

1124 1125
  ( fsLit "PUSH_UPD_FRAME",        \[sp,e] -> emitPushUpdateFrame sp e ),
  ( fsLit "SET_HDR",               \[ptr,info,ccs] ->
Simon Marlow's avatar
Simon Marlow committed
1126
                                        emitSetDynHdr ptr info ccs ),
1127
  ( fsLit "TICK_ALLOC_PRIM",       \[hdr,goods,slop] ->
Simon Marlow's avatar
Simon Marlow committed
1128
                                        tickyAllocPrim hdr goods slop ),
1129
  ( fsLit "TICK_ALLOC_PAP",        \[goods,slop] ->
Simon Marlow's avatar
Simon Marlow committed
1130
                                        tickyAllocPAP goods slop ),
1131
  ( fsLit "TICK_ALLOC_UP_THK",     \[goods,slop] ->
Simon Marlow's avatar
Simon Marlow committed
1132
                                        tickyAllocThunk goods slop ),
1133
  ( fsLit "UPD_BH_UPDATABLE",      \[reg] -> emitBlackHoleCode reg )
1134 1135
 ]

1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146
emitPushUpdateFrame :: CmmExpr -> CmmExpr -> FCode ()
emitPushUpdateFrame sp e = do
  dflags <- getDynFlags
  emitUpdateFrame dflags sp mkUpdInfoLabel e

pushStackFrame :: [CmmParse CmmExpr] -> CmmParse () -> CmmParse ()
pushStackFrame fields body = do
  dflags <- getDynFlags
  exprs <- sequence fields
  updfr_off <- getUpdFrameOff
  let (new_updfr_off, _, g) = copyOutOflow dflags NativeReturn Ret Old
1147
                                           [] updfr_off exprs
1148 1149
  emit g
  withUpdFrameOff new_updfr_off body
1150

1151 1152 1153 1154 1155 1156
reserveStackFrame
  :: CmmParse CmmExpr
  -> CmmParse CmmReg
  -> CmmParse ()
  -> CmmParse ()
reserveStackFrame psize preg body = do
1157 1158 1159
  dflags <- getDynFlags
  old_updfr_off <- getUpdFrameOff
  reg <- preg
1160 1161 1162 1163 1164 1165
  esize <- psize
  let size = case constantFoldExpr dflags esize of
               CmmLit (CmmInt n _) -> n
               _other -> pprPanic "CmmParse: not a compile-time integer: "
                            (ppr esize)
  let frame = old_updfr_off + wORD_SIZE dflags * fromIntegral size
1166 1167 1168
  emitAssign reg (CmmStackSlot Old frame)
  withUpdFrameOff frame body

1169
profilingInfo dflags desc_str ty_str
ian@well-typed.com's avatar
ian@well-typed.com committed
1170
  = if not (gopt Opt_SccProfilingOn dflags)
1171
    then NoProfilingInfo
1172
    else ProfilingInfo (BS8.pack desc_str) (BS8.pack ty_str)
1173

1174
staticClosure :: UnitId -> FastString -> FastString -> [CmmLit] -> CmmParse ()
1175
staticClosure pkg cl_label info payload
1176
  = do dflags <- getDynFlags
1177
       let lits = mkStaticClosure dflags (mkCmmInfoLabel pkg info) dontCareCCS payload [] [] []
1178
       code $ emitDataLits (mkCmmDataLabel pkg cl_label) lits
1179 1180

foreignCall
1181
        :: String
1182
        -> [CmmParse (LocalReg, ForeignHint)]
Simon Marlow's avatar
Simon Marlow committed
1183
        -> CmmParse CmmExpr
1184 1185
        -> [CmmParse (CmmExpr, ForeignHint)]
        -> Safety
1186
        -> CmmReturnInfo
1187
        -> PD (CmmParse ())
1188 1189
foreignCall conv_string results_code expr_code args_code safety ret
  = do  conv <- case conv_string of
1190
          "C" -> return CCallConv
1191
          "stdcall" -> return StdCallConv
1192
          _ -> fail ("unknown calling convention: " ++ conv_string)
1193
        return $ do
1194
          dflags <- getDynFlags
1195
          results <- sequence results_code
Simon Marlow's avatar
Simon Marlow committed
1196 1197
          expr <- expr_code
          args <- sequence args_code
1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214
          let
                  expr' = adjCallTarget dflags conv expr args
                  (arg_exprs, arg_hints) = unzip args
                  (res_regs,  res_hints) = unzip results
                  fc = ForeignConvention conv arg_hints res_hints ret
                  target = ForeignTarget expr' fc
          _ <- code $ emitForeignCall safety res_regs target arg_exprs
          return ()


doReturn :: [CmmParse CmmExpr] -> CmmParse ()
doReturn exprs_code = do
  dflags <- getDynFlags
  exprs <- sequence exprs_code
  updfr_off <- getUpdFrameOff
  emit (mkReturnSimple dflags exprs updfr_off)

1215 1216
mkReturnSimple  :: DynFlags -> [CmmActual] -> UpdFrameOffset -> CmmAGraph
mkReturnSimple dflags actuals updfr_off =
1217
  mkReturn dflags e actuals updfr_off
1218 1219 1220
  where e = entryCode dflags (CmmLoad (CmmStackSlot Old updfr_off)
                             (gcWord dflags))

1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235
doRawJump :: CmmParse CmmExpr -> [GlobalReg] -> CmmParse ()
doRawJump expr_code vols = do
  dflags <- getDynFlags
  expr <- expr_code
  updfr_off <- getUpdFrameOff
  emit (mkRawJump dflags expr updfr_off vols)

doJumpWithStack :: CmmParse CmmExpr -> [CmmParse CmmExpr]
                -> [CmmParse CmmExpr] -> CmmParse ()
doJumpWithStack expr_code stk_code args_code = do
  dflags <- getDynFlags
  expr <- expr_code
  stk_args <- sequence stk_code
  args <- sequence args_code
  updfr_off <- getUpdFrameOff
1236
  emit (mkJumpExtra dflags NativeNodeCall expr args updfr_off stk_args)
1237 1238 1239 1240 1241 1242 1243 1244 1245

doCall :: CmmParse CmmExpr -> [CmmParse LocalReg] -> [CmmParse CmmExpr]
       -> CmmParse ()
doCall expr_code res_code args_code = do
  dflags <- getDynFlags
  expr <- expr_code
  args <- sequence args_code
  ress <- sequence res_code
  updfr_off <- getUpdFrameOff
1246
  c <- code $ mkCall expr (NativeNodeCall,NativeReturn) ress args updfr_off []
1247 1248 1249
  emit c

adjCallTarget :: DynFlags -> CCallConv -> CmmExpr -> [(CmmExpr, ForeignHint) ]
1250
              -> CmmExpr
1251 1252
-- On Windows, we have to add the '@N' suffix to the label when making
-- a call with the stdcall calling convention.
1253 1254
adjCallTarget dflags StdCallConv (CmmLit (CmmLabel lbl)) args
 | platformOS (targetPlatform dflags) == OSMinGW32
1255
  = CmmLit (CmmLabel (addLabelSize lbl (sum (map size args))))
1256
  where size (e, _) = max (wORD_SIZE dflags) (widthInBytes (typeWidth (cmmExprType dflags e)))
1257
                 -- c.f. CgForeignCall.emitForeignCall
1258
adjCallTarget _ _ expr _
1259 1260
  = expr

1261
primCall
1262
        :: [CmmParse (CmmFormal, ForeignHint)]
Simon Marlow's avatar
Simon Marlow committed
1263
        -> FastString
1264
        -> [CmmParse CmmExpr]
1265
        -> PD (CmmParse ())
1266
primCall results_code name args_code
1267
  = case lookupUFM callishMachOps name of
1268
        Nothing -> fail ("unknown primitive " ++ unpackFS name)
1269
        Just f  -> return $ do
Simon Marlow's avatar
Simon Marlow committed
1270 1271
                results <- sequence results_code
                args <- sequence args_code
1272 1273
                let (p, args') = f args
                code (emitPrimCall (map fst results) p args')
1274 1275

doStore :: CmmType -> CmmParse CmmExpr  -> CmmParse CmmExpr -> CmmParse ()
1276
doStore rep addr_code val_code
1277 1278
  = do dflags <- getDynFlags
       addr <- addr_code
1279
       val <- val_code
1280 1281 1282 1283 1284
        -- 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.
1285
       let val_width = typeWidth (cmmExprType dflags val)
1286
           rep_width = typeWidth rep
1287 1288 1289
       let coerce_val
                | val_width /= rep_width = CmmMachOp (MO_UU_Conv val_width rep_width) [val]
                | otherwise              = val
1290
       emitStore addr coerce_val
1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302

-- -----------------------------------------------------------------------------
-- 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.

1303
cmmIfThenElse cond then_part else_part likely = do
1304 1305
     then_id <- newBlockId
     join_id <- newBlockId
1306
     c <- cond
1307
     emitCond c then_id likely
1308
     else_part
1309 1310
     emit (mkBranch join_id)
     emitLabel then_id
1311 1312
     then_part
     -- fall through to join
1313
     emitLabel join_id
1314

1315
cmmRawIf cond then_id likely = do
1316
    c <- cond
1317
    emitCond c then_id likely
1318

1319 1320
-- 'emitCond cond true_id'  emits code to test whether the cond is true,
-- branching to true_id if so, and falling through otherwise.
1321
emitCond (BoolTest e) then_id likely = do
1322
  else_id <- newBlockId
1323
  emit (mkCbranch e then_id else_id likely)
1324
  emitLabel else_id
1325
emitCond (BoolNot (BoolTest (CmmMachOp op args))) then_id likely
1326
  | Just op' <- maybeInvertComparison op
1327 1328
  = emitCond (BoolTest (CmmMachOp op' args)) then_id (not <$> likely)
emitCond (BoolNot e) then_id likely = do
1329
  else_id <- newBlockId
1330
  emitCond e else_id likely
1331 1332
  emit (mkBranch then_id)
  emitLabel else_id
1333 1334 1335 1336
emitCond (e1 `BoolOr` e2) then_id likely = do
  emitCond e1 then_id likely
  emitCond e2 then_id likely
emitCond (e1 `BoolAnd` e2) then_id likely = do
1337
        -- we'd like to invert one of the conditionals here to avoid an
Simon Marlow's avatar
Simon Marlow committed
1338 1339 1340
        -- 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.
1341 1342
  and_id <- newBlockId
  else_id <- newBlockId
1343
  emitCond e1 and_id likely
1344 1345
  emit (mkBranch else_id)
  emitLabel and_id
1346
  emitCond e2 then_id likely
1347
  emitLabel else_id
1348

1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360
-- -----------------------------------------------------------------------------
-- Source code notes

-- | Generate a source note spanning from "a" to "b" (inclusive), then
-- proceed with parsing. This allows debugging tools to reason about
-- locations in Cmm code.
withSourceNote :: Located a -> Located b -> CmmParse c -> CmmParse c
withSourceNote a b parse = do
  name <- getName
  case combineSrcSpans (getLoc a) (getLoc b) of
    RealSrcSpan span -> code (emitTick (SourceNote span name)) >> parse
    _other           -> parse
1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371

-- -----------------------------------------------------------------------------
-- 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.

1372 1373 1374
doSwitch :: Maybe (Integer,Integer)
         -> CmmParse CmmExpr
         -> [([Integer],Either BlockId (CmmParse ()))]
1375
         -> Maybe (CmmParse ()) -> CmmParse ()
1376
doSwitch mb_range scrut arms deflt
1377
   = do
Simon Marlow's avatar
Simon Marlow committed
1378
        -- Compile code for the default branch
1379
        dflt_entry <-
Simon Marlow's avatar
Simon Marlow committed
1380 1381
                case deflt of
                  Nothing -> return Nothing
1382 1383
                  Just e  -> do b <- forkLabelledCode e; return (Just b)

Simon Marlow's avatar
Simon Marlow committed
1384 1385
        -- Compile each case branch
        table_entries <- mapM emitArm arms
1386
        let table = M.fromList (concat table_entries)
Simon Marlow's avatar
Simon Marlow committed
1387

1388 1389
        dflags <- getDynFlags
        let range = fromMaybe (0, tARGET_MAX_WORD dflags) mb_range
Simon Marlow's avatar
Simon Marlow committed
1390 1391 1392

        expr <- scrut
        -- ToDo: check for out of range and jump to default if necessary
1393
        emit $ mkSwitch expr (mkSwitchTargets False range dflt_entry table)
1394
   where
1395
        emitArm :: ([Integer],Either BlockId (CmmParse ())) -> CmmParse [(Integer,BlockId)]
Simon Marlow's avatar
Simon Marlow committed
1396 1397
        emitArm (ints,Left blockid) = return [ (i,blockid) | i <- ints ]
        emitArm (ints,Right code) = do
1398
           blockid <- forkLabelledCode code
Simon Marlow's avatar
Simon Marlow committed
1399
           return [ (i,blockid) | i <- ints ]
1400 1401 1402

forkLabelledCode :: CmmParse () -> CmmParse BlockId
forkLabelledCode p = do
Peter Wortmann's avatar
Peter Wortmann committed
1403
  (_,ag) <- getCodeScoped p
1404 1405 1406
  l <- newBlockId
  emitOutOfLine l ag
  return l
1407 1408 1409 1410 1411 1412

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

-- The initial environment: we define some constants that the compiler
-- knows about here.
1413 1414
initEnv :: DynFlags -> Env
initEnv dflags = listToUFM [
1415
  ( fsLit "SIZEOF_StgHeader",
1416
    VarN (CmmLit (CmmInt (fromIntegral (fixedHdrSize dflags)) (wordWidth dflags)) )),
1417
  ( fsLit "SIZEOF_StgInfoTable",
1418
    VarN (CmmLit (CmmInt (fromIntegral (stdInfoTableSizeB dflags)) (wordWidth dflags)) ))
1419 1420
  ]

Simon Peyton Jones's avatar
Simon Peyton Jones committed
1421
parseCmmFile :: DynFlags -> FilePath -> IO (Messages, Maybe CmmGroup)
1422
parseCmmFile dflags filename = withTiming dflags (text "ParseCmm"<+>brackets (text filename)) (\_ -> ()) $ do
1423 1424
  buf <- hGetStringBuffer filename
  let
1425 1426 1427 1428
        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.
1429
  case unPD cmmParse dflags init_state of
1430 1431
    PFailed pst ->
        return (getMessages pst dflags, Nothing)
1432
    POk pst code -> do
1433
        st <- initC