Parser.y 55.9 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
import GHC.Prelude
206
import qualified Prelude -- for happy-generated code
207

208 209 210
import GHC.Platform
import GHC.Platform.Profile

211 212 213 214
import GHC.StgToCmm.ExtCode
import GHC.StgToCmm.Prof
import GHC.StgToCmm.Heap
import GHC.StgToCmm.Monad hiding ( getCode, getCodeR, getCodeScoped, emitLabel, emit
215 216
                                 , emitStore, emitAssign, emitOutOfLine, withUpdFrameOff
                                 , getUpdFrameOff, getProfile, getPlatform, getPtrOpts )
217 218 219 220 221 222 223 224
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 )
225

Sylvain Henry's avatar
Sylvain Henry committed
226
import GHC.Core           ( Tickish(SourceNote) )
227 228 229 230 231 232 233 234 235 236

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
237 238 239
import GHC.Cmm.Monad hiding (getPlatform, getProfile, getPtrOpts)
import qualified GHC.Cmm.Monad as PD
import GHC.Cmm.CallConv
240
import GHC.Runtime.Heap.Layout
Sylvain Henry's avatar
Sylvain Henry committed
241
import GHC.Parser.Lexer
242

Sylvain Henry's avatar
Sylvain Henry committed
243 244
import GHC.Types.CostCentre
import GHC.Types.ForeignCall
Sylvain Henry's avatar
Sylvain Henry committed
245
import GHC.Unit.Module
Sylvain Henry's avatar
Sylvain Henry committed
246 247 248 249
import GHC.Types.Literal
import GHC.Types.Unique
import GHC.Types.Unique.FM
import GHC.Types.SrcLoc
Sylvain Henry's avatar
Sylvain Henry committed
250
import GHC.Driver.Session
251
import GHC.Driver.Ppr
252 253 254 255
import GHC.Utils.Error
import GHC.Data.StringBuffer
import GHC.Data.FastString
import GHC.Utils.Panic
Sylvain Henry's avatar
Sylvain Henry committed
256
import GHC.Settings.Constants
257
import GHC.Utils.Outputable
Sylvain Henry's avatar
Sylvain Henry committed
258
import GHC.Types.Basic
259
import GHC.Data.Bag     ( emptyBag, unitBag )
Sylvain Henry's avatar
Sylvain Henry committed
260
import GHC.Types.Var
261

262
import Control.Monad
263
import Data.Array
264
import Data.Char        ( ord )
265
import System.Exit
266
import Data.Maybe
267
import qualified Data.Map as M
268
import qualified Data.ByteString.Char8 as BS8
269 270

#include "HsVersions.h"
271 272
}

273 274
%expect 0

275
%token
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 302 303 304 305 306 307
        ':'     { 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) }
308 309 310
        '&&'    { L _ (CmmT_BoolAnd) }
        '||'    { L _ (CmmT_BoolOr) }

311 312 313 314
        'True'  { L _ (CmmT_True ) }
        'False' { L _ (CmmT_False) }
        'likely'{ L _ (CmmT_likely)}

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

357
%monad { PD } { >>= } { return }
358 359 360 361 362
%lexer { cmmlex } { L _ CmmT_EOF }
%name cmmParse cmm
%tokentype { Located CmmToken }

-- C-- operator precedences, taken from the C-- spec
363 364
%right '||'     -- non-std extension, called %disjoin in C--
%right '&&'     -- non-std extension, called %conjoin in C--
365 366 367 368 369 370 371 372 373 374 375 376
%right '!'
%nonassoc '>=' '>' '<=' '<' '!=' '=='
%left '|'
%left '^'
%left '&'
%left '>>' '<<'
%left '-' '+'
%left '/' '*' '%'
%right '~'

%%

377
cmm     :: { CmmParse () }
Simon Marlow's avatar
untab  
Simon Marlow committed
378 379
        : {- empty -}                   { return () }
        | cmmtop cmm                    { do $1; $2 }
380

381
cmmtop  :: { CmmParse () }
Simon Marlow's avatar
untab  
Simon Marlow committed
382 383
        : cmmproc                       { $1 }
        | cmmdata                       { $1 }
384 385
        | decl                          { $1 }
        | 'CLOSURE' '(' NAME ',' NAME lits ')' ';'
Sylvain Henry's avatar
Sylvain Henry committed
386
                {% liftP . withHomeUnitId $ \pkg ->
387 388
                   do lits <- sequence $6;
                      staticClosure pkg $3 $5 (map getLit lits) }
389 390 391 392 393

-- 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:
394 395 396 397
--      * 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
398

399
cmmdata :: { CmmParse () }
400
        : 'section' STRING '{' data_label statics '}'
Simon Marlow's avatar
untab  
Simon Marlow committed
401 402
                { do lbl <- $4;
                     ss <- sequence $5;
403
                     code (emitDecl (CmmData (Section (section $2) lbl) (CmmStaticsRaw lbl (concat ss)))) }
404 405

data_label :: { CmmParse CLabel }
406
    : NAME ':'
Sylvain Henry's avatar
Sylvain Henry committed
407
                {% liftP . withHomeUnitId $ \pkg ->
408
                   return (mkCmmDataLabel pkg (NeedExternDecl False) $1) }
409

Simon Marlow's avatar
untab  
Simon Marlow committed
410 411 412
statics :: { [CmmParse [CmmStatic]] }
        : {- empty -}                   { [] }
        | static statics                { $1 : $2 }
413

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

435
lits    :: { [CmmParse CmmExpr] }
Simon Marlow's avatar
untab  
Simon Marlow committed
436 437
        : {- empty -}           { [] }
        | ',' expr lits         { $2 : $3 }
438 439 440 441

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
442
                       getCodeScoped $ loopDecls $ do {
443
                         (entry_ret_label, info, stk_formals) <- $1;
Peter Wortmann's avatar
Peter Wortmann committed
444
                         dflags <- getDynFlags;
445
                         formals <- sequence (fromMaybe [] $3);
Peter Wortmann's avatar
Peter Wortmann committed
446 447
                         withName (showSDoc dflags (ppr entry_ret_label))
                           $4;
448 449 450 451 452
                         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 ) }
453

454 455 456
maybe_conv :: { Convention }
           : {- empty -}        { NativeNodeCall }
           | 'return'           { NativeReturn }
457

458 459
maybe_body :: { CmmParse () }
           : ';'                { return () }
Peter Wortmann's avatar
Peter Wortmann committed
460
           | '{' body '}'       { withSourceNote $1 $3 $2 }
461 462 463

info    :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }
        : NAME
Sylvain Henry's avatar
Sylvain Henry committed
464
                {% liftP . withHomeUnitId $ \pkg ->
Simon Marlow's avatar
untab  
Simon Marlow committed
465
                   do   newFunctionName $1 pkg
466 467 468 469
                        return (mkCmmCodeLabel pkg $1, Nothing, []) }


        | 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
Simon Marlow's avatar
untab  
Simon Marlow committed
470
                -- ptrs, nptrs, closure type, description, type
Sylvain Henry's avatar
Sylvain Henry committed
471
                {% liftP . withHomeUnitId $ \pkg ->
472 473
                   do profile <- getProfile
                      let prof = profilingInfo profile $11 $13
474
                          rep  = mkRTSRep (fromIntegral $9) $
475
                                   mkHeapRep profile False (fromIntegral $5)
476 477 478 479
                                                   (fromIntegral $7) Thunk
                              -- not really Thunk, but that makes the info table
                              -- we want.
                      return (mkCmmEntryLabel pkg $3,
480
                              Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
Simon Marlow's avatar
untab  
Simon Marlow committed
481
                                           , cit_rep = rep
482
                                           , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },
Simon Marlow's avatar
untab  
Simon Marlow committed
483
                              []) }
484

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

        | 'INFO_TABLE_CONSTR' '(' NAME ',' INT ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
504
                -- ptrs, nptrs, tag, closure type, description, type
Sylvain Henry's avatar
Sylvain Henry committed
505
                {% liftP . withHomeUnitId $ \pkg ->
506 507
                   do profile <- getProfile
                      let prof = profilingInfo profile $13 $15
508
                          ty  = Constr (fromIntegral $9)  -- Tag
509
                                       (BS8.pack $13)
510
                          rep = mkRTSRep (fromIntegral $11) $
511
                                  mkHeapRep profile False (fromIntegral $5)
512 513
                                                  (fromIntegral $7) ty
                      return (mkCmmEntryLabel pkg $3,
514
                              Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
Simon Marlow's avatar
untab  
Simon Marlow committed
515
                                           , cit_rep = rep
516
                                           , cit_prof = prof, cit_srt = Nothing,cit_clo = Nothing },
Simon Marlow's avatar
untab  
Simon Marlow committed
517
                              []) }
518

Simon Marlow's avatar
untab  
Simon Marlow committed
519 520
                     -- 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.
521

522
        | 'INFO_TABLE_SELECTOR' '(' NAME ',' INT ',' INT ',' STRING ',' STRING ')'
Simon Marlow's avatar
untab  
Simon Marlow committed
523
                -- selector, closure type, description, type
Sylvain Henry's avatar
Sylvain Henry committed
524
                {% liftP . withHomeUnitId $ \pkg ->
525 526
                   do profile <- getProfile
                      let prof = profilingInfo profile $9 $11
527 528
                          ty  = ThunkSelector (fromIntegral $5)
                          rep = mkRTSRep (fromIntegral $7) $
529
                                   mkHeapRep profile False 0 0 ty
530
                      return (mkCmmEntryLabel pkg $3,
531
                              Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
Simon Marlow's avatar
untab  
Simon Marlow committed
532
                                           , cit_rep = rep
533
                                           , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },
Simon Marlow's avatar
untab  
Simon Marlow committed
534
                              []) }
535 536

        | 'INFO_TABLE_RET' '(' NAME ',' INT ')'
Simon Marlow's avatar
untab  
Simon Marlow committed
537
                -- closure type (no live regs)
Sylvain Henry's avatar
Sylvain Henry committed
538
                {% liftP . withHomeUnitId $ \pkg ->
Simon Marlow's avatar
untab  
Simon Marlow committed
539
                   do let prof = NoProfilingInfo
540
                          rep  = mkRTSRep (fromIntegral $5) $ mkStackRep []
541
                      return (mkCmmRetLabel pkg $3,
542
                              Just $ CmmInfoTable { cit_lbl = mkCmmRetInfoLabel pkg $3
Simon Marlow's avatar
untab  
Simon Marlow committed
543
                                           , cit_rep = rep
544
                                           , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },
Simon Marlow's avatar
untab  
Simon Marlow committed
545
                              []) }
546 547

        | 'INFO_TABLE_RET' '(' NAME ',' INT ',' formals0 ')'
Simon Marlow's avatar
untab  
Simon Marlow committed
548
                -- closure type, live regs
Sylvain Henry's avatar
Sylvain Henry committed
549
                {% liftP . withHomeUnitId $ \pkg ->
550
                   do platform <- getPlatform
551
                      live <- sequence $7
Simon Marlow's avatar
untab  
Simon Marlow committed
552
                      let prof = NoProfilingInfo
553
                          -- drop one for the info pointer
Sylvain Henry's avatar
Sylvain Henry committed
554
                          bitmap = mkLiveness platform (drop 1 live)
555
                          rep  = mkRTSRep (fromIntegral $5) $ mkStackRep bitmap
556
                      return (mkCmmRetLabel pkg $3,
557
                              Just $ CmmInfoTable { cit_lbl = mkCmmRetInfoLabel pkg $3
Simon Marlow's avatar
untab  
Simon Marlow committed
558
                                           , cit_rep = rep
559
                                           , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },
560
                              live) }
561

562
body    :: { CmmParse () }
Simon Marlow's avatar
untab  
Simon Marlow committed
563 564 565
        : {- empty -}                   { return () }
        | decl body                     { do $1; $2 }
        | stmt body                     { do $1; $2 }
566

567
decl    :: { CmmParse () }
Simon Marlow's avatar
untab  
Simon Marlow committed
568 569 570
        : type names ';'                { mapM_ (newLocal $1) $2 }
        | 'import' importNames ';'      { mapM_ newImport $2 }
        | 'export' names ';'            { return () }  -- ignore exports
571

572 573

-- an imported function name, with optional packageId
574 575 576 577 578
importNames
        :: { [(FastString, CLabel)] }
        : importName                    { [$1] }
        | importName ',' importNames    { $1 : $3 }

579
importName
580 581
        :: { (FastString,  CLabel) }

Simon Marlow's avatar
untab  
Simon Marlow committed
582
        -- A label imported without an explicit packageId.
583
        --      These are taken to come from some foreign, unnamed package.
584
        : NAME
Simon Marlow's avatar
untab  
Simon Marlow committed
585 586
        { ($1, mkForeignLabel $1 Nothing ForeignLabelInExternalPackage IsFunction) }

587 588 589 590
        -- as previous 'NAME', but 'IsData'
        | 'CLOSURE' NAME
        { ($2, mkForeignLabel $2 Nothing ForeignLabelInExternalPackage IsData) }

Sylvain Henry's avatar
Sylvain Henry committed
591
        -- A label imported with an explicit UnitId.
Simon Marlow's avatar
untab  
Simon Marlow committed
592
        | STRING NAME
Sylvain Henry's avatar
Sylvain Henry committed
593
        { ($2, mkCmmCodeLabel (UnitId (mkFastString $1)) $2) }
594 595


Simon Marlow's avatar
untab  
Simon Marlow committed
596 597 598 599 600
names   :: { [FastString] }
        : NAME                          { [$1] }
        | NAME ',' names                { $1 : $3 }

stmt    :: { CmmParse () }
601 602
        : ';'                                   { return () }

Simon Marlow's avatar
untab  
Simon Marlow committed
603
        | NAME ':'
604 605 606 607
                { do l <- newLabel $1; emitLabel l }



Simon Marlow's avatar
untab  
Simon Marlow committed
608
        | lreg '=' expr ';'
609
                { do reg <- $1; e <- $3; withSourceNote $2 $4 (emitAssign reg e) }
Simon Marlow's avatar
untab  
Simon Marlow committed
610
        | type '[' expr ']' '=' expr ';'
611
                { withSourceNote $2 $7 (doStore $1 $3 $6) }
612 613

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

unwind_regs
655 656
        :: { CmmParse [(GlobalReg, Maybe CmmExpr)] }
        : GLOBALREG '=' expr_or_unknown ',' unwind_regs
657
                { do e <- $3; rest <- $5; return (($1, e) : rest) }
658
        | GLOBALREG '=' expr_or_unknown
659
                { do e <- $3; return [($1, e)] }
660

661 662 663 664 665 666 667 668
-- | 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) }

669
foreignLabel     :: { CmmParse CmmExpr }
670
        : NAME                          { return (CmmLit (CmmLabel (mkForeignLabel $1 Nothing ForeignLabelInThisPackage IsFunction))) }
671

672 673 674
opt_never_returns :: { CmmReturnInfo }
        :                               { CmmMayReturn }
        | 'never' 'returns'             { CmmNeverReturns }
675

676
bool_expr :: { CmmParse BoolExpr }
Simon Marlow's avatar
untab  
Simon Marlow committed
677 678
        : bool_op                       { $1 }
        | expr                          { do e <- $1; return (BoolTest e) }
679 680

bool_op :: { CmmParse BoolExpr }
681
        : bool_expr '&&' bool_expr      { do e1 <- $1; e2 <- $3;
Simon Marlow's avatar
untab  
Simon Marlow committed
682
                                          return (BoolAnd e1 e2) }
683
        | bool_expr '||' bool_expr      { do e1 <- $1; e2 <- $3;
Simon Marlow's avatar
untab  
Simon Marlow committed
684 685 686
                                          return (BoolOr e1 e2)  }
        | '!' bool_expr                 { do e <- $2; return (BoolNot e) }
        | '(' bool_op ')'               { $2 }
687 688 689

safety  :: { Safety }
        : {- empty -}                   { PlayRisky }
Simon Marlow's avatar
untab  
Simon Marlow committed
690
        | STRING                        {% parseSafety $1 }
691 692 693

vols    :: { [GlobalReg] }
        : '[' ']'                       { [] }
694 695
        | '[' '*' ']'                   {% do platform <- PD.getPlatform
                                         ; return (realArgRegsCover platform) }
696 697
                                           -- All of them. See comment attached
                                           -- to realArgRegsCover
698
        | '[' globals ']'               { $2 }
699 700

globals :: { [GlobalReg] }
701 702
        : GLOBALREG                     { [$1] }
        | GLOBALREG ',' globals         { $1 : $3 }
703

704 705
maybe_range :: { Maybe (Integer,Integer) }
        : '[' INT '..' INT ']'  { Just ($2, $4) }
706
        | {- empty -}           { Nothing }
707

708
arms    :: { [CmmParse ([Integer],Either BlockId (CmmParse ()))] }
Simon Marlow's avatar
untab  
Simon Marlow committed
709 710
        : {- empty -}                   { [] }
        | arm arms                      { $1 : $2 }
711

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

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

719 720 721
ints    :: { [Integer] }
        : INT                           { [ $1 ] }
        | INT ',' ints                  { $1 : $3 }
722

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

729 730
-- Note: OldCmm doesn't support a first class 'else' statement, though
-- CmmNode does.
731 732
else    :: { CmmParse () }
        : {- empty -}                   { return () }
Peter Wortmann's avatar
Peter Wortmann committed
733
        | 'else' '{' body '}'           { withSourceNote $2 $4 $3 }
734

735 736 737 738 739 740
cond_likely :: { Maybe Bool }
        : '(' 'likely' ':' 'True'  ')'  { Just True  }
        | '(' 'likely' ':' 'False' ')'  { Just False }
        | {- empty -}                   { Nothing }


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


-- leaving out the type of a literal gives you the native word size in C--
778
maybe_ty :: { CmmType }
779
        : {- empty -}                   {% do platform <- PD.getPlatform; return $ bWord platform }
780
        | '::' type                     { $2 }
781

782
cmm_hint_exprs0 :: { [CmmParse (CmmExpr, ForeignHint)] }
Simon Marlow's avatar
untab  
Simon Marlow committed
783
        : {- empty -}                   { [] }
784
        | cmm_hint_exprs                { $1 }
785

786
cmm_hint_exprs :: { [CmmParse (CmmExpr, ForeignHint)] }
Simon Marlow's avatar
untab  
Simon Marlow committed
787 788
        : cmm_hint_expr                 { [$1] }
        | cmm_hint_expr ',' cmm_hint_exprs      { $1 : $3 }
789

790 791 792
cmm_hint_expr :: { CmmParse (CmmExpr, ForeignHint) }
        : expr                          { do e <- $1;
                                             return (e, inferCmmHint e) }
Simon Marlow's avatar
untab  
Simon Marlow committed
793 794
        | expr STRING                   {% do h <- parseCmmHint $2;
                                              return $ do
795
                                                e <- $1; return (e, h) }
796

797
exprs0  :: { [CmmParse CmmExpr] }
Simon Marlow's avatar
untab  
Simon Marlow committed
798 799
        : {- empty -}                   { [] }
        | exprs                         { $1 }
800

801
exprs   :: { [CmmParse CmmExpr] }
Simon Marlow's avatar
untab  
Simon Marlow committed
802 803
        : expr                          { [ $1 ] }
        | expr ',' exprs                { $1 : $3 }
804

805
reg     :: { CmmParse CmmExpr }
Simon Marlow's avatar
untab  
Simon Marlow committed
806 807
        : NAME                  { lookupName $1 }
        | GLOBALREG             { return (CmmReg (CmmGlobal $1)) }
808 809 810 811 812 813

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

foreign_formals :: { [CmmParse (LocalReg, ForeignHint)] }
Simon Marlow's avatar
untab  
Simon Marlow committed
814
        : foreign_formal                        { [$1] }
815 816 817 818
        | foreign_formal ','                    { [$1] }
        | foreign_formal ',' foreign_formals    { $1 : $3 }

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

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

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

formals0 :: { [CmmParse LocalReg] }
Simon Marlow's avatar
untab  
Simon Marlow committed
844
        : {- empty -}           { [] }
845 846 847 848 849 850 851 852
        | formals               { $1 }

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

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

Simon Marlow's avatar
Simon Marlow committed
855
type    :: { CmmType }
856 857
        : 'bits8'               { b8 }
        | typenot8              { $1 }
858

859
typenot8 :: { CmmType }
860 861 862
        : 'bits16'              { b16 }
        | 'bits32'              { b32 }
        | 'bits64'              { b64 }
863
        | 'bits128'             { b128 }
864
        | 'bits256'             { b256 }
865
        | 'bits512'             { b512 }
866 867
        | 'float32'             { f32 }
        | 'float64'             { f64 }
868
        | 'gcptr'               {% do platform <- PD.getPlatform; return $ gcWord platform }
869

870
{
871
section :: String -> SectionType
872 873 874
section "text"      = Text
section "data"      = Data
section "rodata"    = ReadOnlyData
875
section "relrodata" = RelocatableReadOnlyData
876 877
section "bss"       = UninitialisedData
section s           = OtherSection s
878

879
mkString :: String -> CmmStatic
880
mkString s = CmmString (BS8.pack s)
881

882 883 884 885
-- 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.
886
mkMachOp :: (Width -> MachOp) -> [CmmParse CmmExpr] -> CmmParse CmmExpr
887
mkMachOp fn args = do
888
  platform <- getPlatform
889
  arg_exprs <- sequence args
890
  return (CmmMachOp (fn (typeWidth (cmmExprType platform (head arg_exprs)))) arg_exprs)
891 892 893 894 895 896

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

897
nameToMachOp :: FastString -> PD (Width -> MachOp)
898
nameToMachOp name =
899
  case lookupUFM machOps name of
900
        Nothing -> failMsgPD ("unknown primitive " ++ unpackFS name)
901
        Just m  -> return m
902

903
exprOp :: FastString -> [CmmParse CmmExpr] -> PD (CmmParse CmmExpr)
904
exprOp name args_code = do
905 906
  ptr_opts <- PD.getPtrOpts
  case lookupUFM (exprMacros ptr_opts) name of
907 908
     Just f  -> return $ do
        args <- sequence args_code
909
        return (f args)
910
     Nothing -> do
911 912
        mo <- nameToMachOp name
        return $ mkMachOp mo args_code
913

914 915
exprMacros :: PtrOpts -> UniqFM FastString ([CmmExpr] -> CmmExpr)
exprMacros ptr_opts = listToUFM [
916
  ( fsLit "ENTRY_CODE",   \ [x] -> entryCode platform x ),
917 918 919 920 921 922 923 924 925
  ( fsLit "INFO_PTR",     \ [x] -> closureInfoPtr ptr_opts x ),
  ( fsLit "STD_INFO",     \ [x] -> infoTable profile x ),
  ( fsLit "FUN_INFO",     \ [x] -> funInfoTable profile x ),
  ( fsLit "GET_ENTRY",    \ [x] -> entryCode platform (closureInfoPtr ptr_opts x) ),
  ( fsLit "GET_STD_INFO", \ [x] -> infoTable profile (closureInfoPtr ptr_opts x) ),
  ( fsLit "GET_FUN_INFO", \ [x] -> funInfoTable profile (closureInfoPtr ptr_opts x) ),
  ( fsLit "INFO_TYPE",    \ [x] -> infoTableClosureType profile x ),
  ( fsLit "INFO_PTRS",    \ [x] -> infoTablePtrs profile x ),
  ( fsLit "INFO_NPTRS",   \ [x] -> infoTableNonPtrs profile x )
926
  ]
927 928 929
  where
    profile  = po_profile ptr_opts
    platform = profilePlatform profile
930 931 932

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

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

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

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

1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031
        ("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,)),
1032 1033 1034 1035 1036 1037
        ( "cmpxchg64", (MO_Cmpxchg W64,)),

        ( "xchg8",  (MO_Xchg W8,)),
        ( "xchg16", (MO_Xchg W16,)),
        ( "xchg32", (MO_Xchg W32,)),
        ( "xchg64", (MO_Xchg W64,))
1038

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

1058
parseSafety :: String -> PD Safety
1059 1060 1061
parseSafety "safe"   = return PlaySafe
parseSafety "unsafe" = return PlayRisky
parseSafety "interruptible" = return PlayInterruptible
1062
parseSafety str      = failMsgPD ("unrecognised safety: " ++ str)
1063

1064
parseCmmHint :: String -> PD ForeignHint
1065 1066
parseCmmHint "ptr"    = return AddrHint
parseCmmHint "signed" = return SignedHint
1067