Parser.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
Herbert Valerio Riedel's avatar
Herbert Valerio Riedel committed
195
necessary to the stack to accommodate it (e.g. 2).
196

197 198

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

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

203
module GHC.Cmm.Parser ( parseCmmFile ) where
204

205 206
import GhcPrelude

207
import GHC.StgToCmm.ExtCode
208
import GHC.Cmm.CallConv
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 )
Sylvain Henry's avatar
Sylvain Henry committed
222
import GHC.Core           ( Tickish(SourceNote) )
223 224 225 226 227 228 229 230 231 232 233

import GHC.Cmm.Opt
import GHC.Cmm.Graph
import GHC.Cmm
import GHC.Cmm.Utils
import GHC.Cmm.Switch     ( mkSwitchTargets )
import GHC.Cmm.Info
import GHC.Cmm.BlockId
import GHC.Cmm.Lexer
import GHC.Cmm.CLabel
import GHC.Cmm.Monad
234
import GHC.Runtime.Heap.Layout
235 236
import Lexer

237
import CostCentre
Simon Marlow's avatar
Simon Marlow committed
238
import ForeignCall
239
import Module
John Ericson's avatar
John Ericson committed
240
import GHC.Platform
Simon Marlow's avatar
Simon Marlow committed
241
import Literal
242 243 244
import Unique
import UniqFM
import SrcLoc
Sylvain Henry's avatar
Sylvain Henry committed
245
import GHC.Driver.Session
Simon Marlow's avatar
Simon Marlow committed
246 247
import ErrUtils
import StringBuffer
248
import FastString
Simon Marlow's avatar
Simon Marlow committed
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
untab  
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
untab  
Simon Marlow committed
323 324
        'never'         { L _ (CmmT_never) }
        'prim'          { L _ (CmmT_prim) }
325
        'reserve'       { L _ (CmmT_reserve) }
Simon Marlow's avatar
untab  
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) }
Peter Wortmann's avatar
Peter Wortmann committed
333
        'unwind'        { L _ (CmmT_unwind) }
334
        'bits8'         { L _ (CmmT_bits8) }
Simon Marlow's avatar
untab  
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
untab  
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
untab  
Simon Marlow committed
372 373
        : {- empty -}                   { return () }
        | cmmtop cmm                    { do $1; $2 }
374

375
cmmtop  :: { CmmParse () }
Simon Marlow's avatar
untab  
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
untab  
Simon Marlow committed
395 396
                { do lbl <- $4;
                     ss <- sequence $5;
397
                     code (emitDecl (CmmData (Section (section $2) lbl) (CmmStaticsRaw lbl (concat ss)))) }
398 399

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

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

408
static  :: { CmmParse [CmmStatic] }
Simon Marlow's avatar
untab  
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
untab  
Simon Marlow committed
415
                                                        (fromIntegral $3)] }
416 417
        | typenot8 '[' INT ']' ';'      { return [CmmUninitialised
                                                (widthInBytes (typeWidth $1) *
Simon Marlow's avatar
untab  
Simon Marlow committed
418
                                                        fromIntegral $3)] }
419
        | 'CLOSURE' '(' NAME lits ')'
Simon Marlow's avatar
untab  
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
untab  
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;
Peter Wortmann's avatar
Peter Wortmann committed
438
                         dflags <- getDynFlags;
439
                         formals <- sequence (fromMaybe [] $3);
Peter Wortmann's avatar
Peter Wortmann committed
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 () }
Peter Wortmann's avatar
Peter Wortmann committed
454
           | '{' body '}'       { withSourceNote $1 $3 $2 }
455 456 457

info    :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }
        : NAME
458
                {% liftP . withThisPackage $ \pkg ->
Simon Marlow's avatar
untab  
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
untab  
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
untab  
Simon Marlow committed
475
                                           , cit_rep = rep
476
                                           , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },
Simon Marlow's avatar
untab  
Simon Marlow committed
477
                              []) }
478

479
        | 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ')'
Simon Marlow's avatar
untab  
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
untab  
Simon Marlow committed
491
                                           , cit_rep = rep
492
                                           , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },
Simon Marlow's avatar
untab  
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
untab  
Simon Marlow committed
509
                                           , cit_rep = rep
510
                                           , cit_prof = prof, cit_srt = Nothing,cit_clo = Nothing },
Simon Marlow's avatar
untab  
Simon Marlow committed
511
                              []) }
512

Simon Marlow's avatar
untab  
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
untab  
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
untab  
Simon Marlow committed
526
                                           , cit_rep = rep
527
                                           , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },
Simon Marlow's avatar
untab  
Simon Marlow committed
528
                              []) }
529 530

        | 'INFO_TABLE_RET' '(' NAME ',' INT ')'
Simon Marlow's avatar
untab  
Simon Marlow committed
531
                -- closure type (no live regs)
532
                {% liftP . withThisPackage $ \pkg ->
Simon Marlow's avatar
untab  
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
untab  
Simon Marlow committed
537
                                           , cit_rep = rep
538
                                           , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },
Simon Marlow's avatar
untab  
Simon Marlow committed
539
                              []) }
540 541

        | 'INFO_TABLE_RET' '(' NAME ',' INT ',' formals0 ')'
Simon Marlow's avatar
untab  
Simon Marlow committed
542
                -- closure type, live regs
543
                {% liftP . withThisPackage $ \pkg ->
544
                   do dflags <- getDynFlags
545
                      live <- sequence $7
Simon Marlow's avatar
untab  
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
untab  
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
untab  
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
untab  
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
untab  
Simon Marlow committed
576
        -- A label imported without an explicit packageId.
577
        --      These are taken to come from some foreign, unnamed package.
578
        : NAME
Simon Marlow's avatar
untab  
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
untab  
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
untab  
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
untab  
Simon Marlow committed
597
        | NAME ':'
598 599 600 601
                { do l <- newLabel $1; emitLabel l }



Simon Marlow's avatar
untab  
Simon Marlow committed
602
        | lreg '=' expr ';'
603
                { do reg <- $1; e <- $3; withSourceNote $2 $4 (emitAssign reg e) }
Simon Marlow's avatar
untab  
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
untab  
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
untab  
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
untab  
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
untab  
Simon Marlow committed
676
                                          return (BoolAnd e1 e2) }
677
        | bool_expr '||' bool_expr      { do e1 <- $1; e2 <- $3;
Simon Marlow's avatar
untab  
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
untab  
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
untab  
Simon Marlow committed
703 704
        : {- empty -}                   { [] }
        | arm arms                      { $1 : $2 }
705

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

709
arm_body :: { CmmParse (Either BlockId (CmmParse ())) }
Peter Wortmann's avatar
Peter Wortmann committed
710
        : '{' body '}'                  { return (Right (withSourceNote $1 $3 $2)) }
Simon Marlow's avatar
untab  
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 ()) }
Peter Wortmann's avatar
Peter Wortmann committed
718
        : 'default' ':' '{' body '}'    { Just (withSourceNote $3 $5 $4) }
Simon Marlow's avatar
untab  
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 () }
Peter Wortmann's avatar
Peter Wortmann committed
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
untab  
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
untab  
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 (targetPlatform dflags) }
774
        | '::' type                     { $2 }
775

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

780
cmm_hint_exprs :: { [CmmParse (CmmExpr, ForeignHint)] }
Simon Marlow's avatar
untab  
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
untab  
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
untab  
Simon Marlow committed
792 793
        : {- empty -}                   { [] }
        | exprs                         { $1 }
794

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

799
reg     :: { CmmParse CmmExpr }
Simon Marlow's avatar
untab  
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
untab  
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
untab  
Simon Marlow committed
819 820
        : NAME                  { do e <- lookupName $1;
                                     return $
821
                                       case e of
Simon Marlow's avatar
untab  
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
untab  
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
untab  
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
untab  
Simon Marlow committed
847
        : type NAME             { newLocal $1 $2 }
848

Simon Marlow's avatar
Simon Marlow committed
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 (targetPlatform 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
-- 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.
880
mkMachOp :: (Width -> MachOp) -> [CmmParse CmmExpr] -> CmmParse CmmExpr
881
mkMachOp fn args = do
882
  dflags <- getDynFlags
883
  let platform = targetPlatform dflags
884
  arg_exprs <- sequence args
885
  return (CmmMachOp (fn (typeWidth (cmmExprType platform (head arg_exprs)))) arg_exprs)
886 887 888 889 890 891

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

892
nameToMachOp :: FastString -> PD (Width -> MachOp)
893
nameToMachOp name =
894
  case lookupUFM machOps name of
895
        Nothing -> failMsgPD ("unknown primitive " ++ unpackFS name)
896
        Just m  -> return m
897

898
exprOp :: FastString -> [CmmParse CmmExpr] -> PD (CmmParse CmmExpr)
899 900 901
exprOp name args_code = do
  dflags <- getDynFlags
  case lookupUFM (exprMacros dflags) name of
902 903
     Just f  -> return $ do
        args <- sequence args_code
904
        return (f args)
905
     Nothing -> do
906 907
        mo <- nameToMachOp name
        return $ mkMachOp mo args_code
908

909 910
exprMacros :: DynFlags -> UniqFM ([CmmExpr] -> CmmExpr)
exprMacros dflags = listToUFM [
911
  ( fsLit "ENTRY_CODE",   \ [x] -> entryCode dflags x ),
912
  ( fsLit "INFO_PTR",     \ [x] -> closureInfoPtr dflags x ),
913 914
  ( fsLit "STD_INFO",     \ [x] -> infoTable dflags x ),
  ( fsLit "FUN_INFO",     \ [x] -> funInfoTable dflags x ),
915 916 917
  ( 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) ),
918 919 920
  ( fsLit "INFO_TYPE",    \ [x] -> infoTableClosureType dflags x ),
  ( fsLit "INFO_PTRS",    \ [x] -> infoTablePtrs dflags x ),
  ( fsLit "INFO_NPTRS",   \ [x] -> infoTableNonPtrs dflags x )
921 922 923 924
  ]

-- we understand a subset of C-- primitives:
machOps = listToUFM $
925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945
        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 ),
946

947
        ( "and",        MO_And ),
948 949 950 951 952 953
        ( "or",         MO_Or ),
        ( "xor",        MO_Xor ),
        ( "com",        MO_Not ),
        ( "shl",        MO_Shl ),
        ( "shrl",       MO_U_Shr ),
        ( "shra",       MO_S_Shr ),
954

955 956 957 958 959 960 961 962 963 964 965 966 967 968
        ( "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  ),
969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989
        ( "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 )
        ]
990

991
callishMachOps :: UniqFM ([CmmExpr] -> (CallishMachOp, [CmmExpr]))
992
callishMachOps = listToUFM $
993
        map (\(x, y) -> (mkFastString x, y)) [
994
        ( "read_barrier", (MO_ReadBarrier,)),
995
        ( "write_barrier", (MO_WriteBarrier,)),
996 997 998
        ( "memcpy", memcpyLikeTweakArgs MO_Memcpy ),
        ( "memset", memcpyLikeTweakArgs MO_Memset ),
        ( "memmove", memcpyLikeTweakArgs MO_Memmove ),
999
        ( "memcmp", memcpyLikeTweakArgs MO_Memcmp ),
1000

1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024
        ("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,))