Parser.y 55.5 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

Sylvain Henry's avatar
Sylvain Henry committed
237 238 239
import GHC.Types.CostCentre
import GHC.Types.ForeignCall
import GHC.Types.Module
John Ericson's avatar
John Ericson committed
240
import GHC.Platform
Sylvain Henry's avatar
Sylvain Henry committed
241 242 243 244
import GHC.Types.Literal
import GHC.Types.Unique
import GHC.Types.Unique.FM
import GHC.Types.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
Sylvain Henry's avatar
Sylvain Henry committed
252
import GHC.Types.Basic
253
import Bag              ( emptyBag, unitBag )
Sylvain Henry's avatar
Sylvain Henry committed
254
import GHC.Types.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
Sylvain Henry's avatar
Sylvain Henry committed
545
                      let platform = targetPlatform dflags
546
                      live <- sequence $7
Simon Marlow's avatar
untab  
Simon Marlow committed
547
                      let prof = NoProfilingInfo
548
                          -- drop one for the info pointer
Sylvain Henry's avatar
Sylvain Henry committed
549
                          bitmap = mkLiveness platform (drop 1 live)
550
                          rep  = mkRTSRep (fromIntegral $5) $ mkStackRep bitmap
551
                      return (mkCmmRetLabel pkg $3,
552
                              Just $ CmmInfoTable { cit_lbl = mkCmmRetInfoLabel pkg $3
Simon Marlow's avatar
untab  
Simon Marlow committed
553
                                           , cit_rep = rep
554
                                           , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },
555
                              live) }
556

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

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

567 568

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

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

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

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

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


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

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

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



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

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

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

656 657 658 659 660 661 662 663
-- | 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) }

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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


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


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

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

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

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

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

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

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

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

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

foreign_formal :: { CmmParse (LocalReg, ForeignHint) }
814
        : local_lreg            { do e <- $1; return (e, inferCmmHint (CmmReg (CmmLocal e))) }
815 816 817 818 819
        | 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
820 821
        : NAME                  { do e <- lookupName $1;
                                     return $
822
                                       case e of
Simon Marlow's avatar
untab  
Simon Marlow committed
823 824 825 826 827 828
                                        CmmReg (CmmLocal r) -> r
                                        other -> pprPanic "CmmParse:" (ftext $1 <> text " not a local register") }

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

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

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

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

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

Simon Marlow's avatar
Simon Marlow committed
850
type    :: { CmmType }
851 852
        : 'bits8'               { b8 }
        | typenot8              { $1 }
853

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

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

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

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

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

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

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

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

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

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

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

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

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

1027
        -- ToDo: the rest, maybe