CmmParse.y 53.3 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
193
194
195
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
convention.

----------------------------------------------------------------------------- -}
196

197
198
199
{
module CmmParse ( parseCmmFile ) where

200
201
202
203
import StgCmmExtCode
import CmmCallConv
import StgCmmProf
import StgCmmHeap
Peter Wortmann's avatar
Peter Wortmann committed
204
import StgCmmMonad hiding ( getCode, getCodeR, getCodeScoped, emitLabel, emit, emitStore
205
206
207
208
209
210
211
                          , emitAssign, emitOutOfLine, withUpdFrameOff
                          , getUpdFrameOff )
import qualified StgCmmMonad as F
import StgCmmUtils
import StgCmmForeign
import StgCmmExpr
import StgCmmClosure
Simon Marlow's avatar
Simon Marlow committed
212
import StgCmmLayout     hiding (ArgRep(..))
213
214
import StgCmmTicky
import StgCmmBind       ( emitBlackHoleCode, emitUpdateFrame )
Peter Wortmann's avatar
Peter Wortmann committed
215
import CoreSyn          ( Tickish(SourceNote) )
216

217
import CmmOpt
218
219
import MkGraph
import Cmm
Simon Marlow's avatar
Simon Marlow committed
220
import CmmUtils
221
import CmmSwitch        ( mkSwitchTargets )
222
import CmmInfo
223
import BlockId
224
225
import CmmLex
import CLabel
Simon Marlow's avatar
Simon Marlow committed
226
import SMRep
227
228
import Lexer

229
import CostCentre
Simon Marlow's avatar
Simon Marlow committed
230
import ForeignCall
231
import Module
232
import Platform
Simon Marlow's avatar
Simon Marlow committed
233
import Literal
234
235
236
import Unique
import UniqFM
import SrcLoc
Simon Marlow's avatar
Simon Marlow committed
237
238
239
240
import DynFlags
import StaticFlags
import ErrUtils
import StringBuffer
241
import FastString
Simon Marlow's avatar
Simon Marlow committed
242
243
import Panic
import Constants
244
import Outputable
245
import BasicTypes
246
import Bag              ( emptyBag, unitBag )
247
import Var
248

249
import Control.Monad
250
import Data.Array
251
import Data.Char        ( ord )
252
import System.Exit
253
import Data.Maybe
254
import qualified Data.Map as M
255
256

#include "HsVersions.h"
257
258
}

259
260
%expect 0

261
%token
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
        ':'     { 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) }
294
295
296
        '&&'    { L _ (CmmT_BoolAnd) }
        '||'    { L _ (CmmT_BoolOr) }

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

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

-- C-- operator precedences, taken from the C-- spec
345
346
%right '||'     -- non-std extension, called %disjoin in C--
%right '&&'     -- non-std extension, called %conjoin in C--
347
348
349
350
351
352
353
354
355
356
357
358
%right '!'
%nonassoc '>=' '>' '<=' '<' '!=' '=='
%left '|'
%left '^'
%left '&'
%left '>>' '<<'
%left '-' '+'
%left '/' '*' '%'
%right '~'

%%

359
cmm     :: { CmmParse () }
Simon Marlow's avatar
untab    
Simon Marlow committed
360
361
        : {- empty -}                   { return () }
        | cmmtop cmm                    { do $1; $2 }
362

363
cmmtop  :: { CmmParse () }
Simon Marlow's avatar
untab    
Simon Marlow committed
364
365
366
        : cmmproc                       { $1 }
        | cmmdata                       { $1 }
        | decl                          { $1 } 
367
        | 'CLOSURE' '(' NAME ',' NAME lits ')' ';'  
Simon Marlow's avatar
untab    
Simon Marlow committed
368
                {% withThisPackage $ \pkg -> 
369
370
                   do lits <- sequence $6;
                      staticClosure pkg $3 $5 (map getLit lits) }
371
372
373
374
375

-- 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:
376
377
378
379
--      * 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
380

381
cmmdata :: { CmmParse () }
Simon Marlow's avatar
untab    
Simon Marlow committed
382
383
384
385
        : 'section' STRING '{' data_label statics '}' 
                { do lbl <- $4;
                     ss <- sequence $5;
                     code (emitDecl (CmmData (section $2) (Statics lbl $ concat ss))) }
386
387

data_label :: { CmmParse CLabel }
Simon Marlow's avatar
untab    
Simon Marlow committed
388
389
390
    : NAME ':'  
                {% withThisPackage $ \pkg -> 
                   return (mkCmmDataLabel pkg $1) }
391

Simon Marlow's avatar
untab    
Simon Marlow committed
392
393
394
statics :: { [CmmParse [CmmStatic]] }
        : {- empty -}                   { [] }
        | static statics                { $1 : $2 }
395
    
396
397
-- Strings aren't used much in the RTS HC code, so it doesn't seem
-- worth allowing inline strings.  C-- doesn't allow them anyway.
398
static  :: { CmmParse [CmmStatic] }
Simon Marlow's avatar
untab    
Simon Marlow committed
399
400
401
402
403
404
405
406
407
408
        : type expr ';' { do e <- $2;
                             return [CmmStaticLit (getLit e)] }
        | type ';'                      { return [CmmUninitialised
                                                        (widthInBytes (typeWidth $1))] }
        | 'bits8' '[' ']' STRING ';'    { return [mkString $4] }
        | 'bits8' '[' INT ']' ';'       { return [CmmUninitialised 
                                                        (fromIntegral $3)] }
        | typenot8 '[' INT ']' ';'      { return [CmmUninitialised 
                                                (widthInBytes (typeWidth $1) * 
                                                        fromIntegral $3)] }
409
        | 'CLOSURE' '(' NAME lits ')'
Simon Marlow's avatar
untab    
Simon Marlow committed
410
                { do { lits <- sequence $4
411
                ; dflags <- getDynFlags
412
                     ; return $ map CmmStaticLit $
413
                        mkStaticClosure dflags (mkForeignLabel $3 Nothing ForeignLabelInExternalPackage IsData)
414
415
                         -- mkForeignLabel because these are only used
                         -- for CHARLIKE and INTLIKE closures in the RTS.
416
                        dontCareCCS (map getLit lits) [] [] [] } }
417
        -- arrays of closures required for the CHARLIKE & INTLIKE arrays
418

419
lits    :: { [CmmParse CmmExpr] }
Simon Marlow's avatar
untab    
Simon Marlow committed
420
421
        : {- empty -}           { [] }
        | ',' expr lits         { $2 : $3 }
422
423
424
425

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
426
                       getCodeScoped $ loopDecls $ do {
427
                         (entry_ret_label, info, stk_formals) <- $1;
Peter Wortmann's avatar
Peter Wortmann committed
428
                         dflags <- getDynFlags;
429
                         formals <- sequence (fromMaybe [] $3);
Peter Wortmann's avatar
Peter Wortmann committed
430
431
                         withName (showSDoc dflags (ppr entry_ret_label))
                           $4;
432
433
434
435
436
                         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 ) }
437

438
439
440
maybe_conv :: { Convention }
           : {- empty -}        { NativeNodeCall }
           | 'return'           { NativeReturn }
441

442
443
maybe_body :: { CmmParse () }
           : ';'                { return () }
Peter Wortmann's avatar
Peter Wortmann committed
444
           | '{' body '}'       { withSourceNote $1 $3 $2 }
445
446
447

info    :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }
        : NAME
Simon Marlow's avatar
untab    
Simon Marlow committed
448
449
                {% withThisPackage $ \pkg ->
                   do   newFunctionName $1 pkg
450
451
452
453
                        return (mkCmmCodeLabel pkg $1, Nothing, []) }


        | 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
Simon Marlow's avatar
untab    
Simon Marlow committed
454
455
                -- ptrs, nptrs, closure type, description, type
                {% withThisPackage $ \pkg ->
456
457
                   do dflags <- getDynFlags
                      let prof = profilingInfo dflags $11 $13
458
                          rep  = mkRTSRep (fromIntegral $9) $
459
                                   mkHeapRep dflags False (fromIntegral $5)
460
461
462
463
                                                   (fromIntegral $7) Thunk
                              -- not really Thunk, but that makes the info table
                              -- we want.
                      return (mkCmmEntryLabel pkg $3,
464
                              Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
Simon Marlow's avatar
untab    
Simon Marlow committed
465
466
467
468
                                           , cit_rep = rep
                                           , cit_prof = prof, cit_srt = NoC_SRT },
                              []) }
        
469
        | 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ')'
Simon Marlow's avatar
untab    
Simon Marlow committed
470
471
                -- ptrs, nptrs, closure type, description, type, fun type
                {% withThisPackage $ \pkg -> 
472
473
                   do dflags <- getDynFlags
                      let prof = profilingInfo dflags $11 $13
474
                          ty   = Fun 0 (ArgSpec (fromIntegral $15))
475
                                -- Arity zero, arg_type $15
476
                          rep = mkRTSRep (fromIntegral $9) $
477
                                    mkHeapRep dflags False (fromIntegral $5)
478
479
                                                    (fromIntegral $7) ty
                      return (mkCmmEntryLabel pkg $3,
480
                              Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
Simon Marlow's avatar
untab    
Simon Marlow committed
481
482
483
484
485
                                           , cit_rep = rep
                                           , cit_prof = prof, cit_srt = NoC_SRT },
                              []) }
                -- we leave most of the fields zero here.  This is only used
                -- to generate the BCO info table in the RTS at the moment.
486
487

        | 'INFO_TABLE_CONSTR' '(' NAME ',' INT ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
488
489
                -- ptrs, nptrs, tag, closure type, description, type
                {% withThisPackage $ \pkg ->
490
491
                   do dflags <- getDynFlags
                      let prof = profilingInfo dflags $13 $15
492
                          ty  = Constr (fromIntegral $9)  -- Tag
493
                                       (stringToWord8s $13)
494
                          rep = mkRTSRep (fromIntegral $11) $
495
                                  mkHeapRep dflags False (fromIntegral $5)
496
497
                                                  (fromIntegral $7) ty
                      return (mkCmmEntryLabel pkg $3,
498
                              Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
Simon Marlow's avatar
untab    
Simon Marlow committed
499
500
501
                                           , cit_rep = rep
                                           , cit_prof = prof, cit_srt = NoC_SRT },
                              []) }
502

Simon Marlow's avatar
untab    
Simon Marlow committed
503
504
505
                     -- 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.
        
506
        | 'INFO_TABLE_SELECTOR' '(' NAME ',' INT ',' INT ',' STRING ',' STRING ')'
Simon Marlow's avatar
untab    
Simon Marlow committed
507
508
                -- selector, closure type, description, type
                {% withThisPackage $ \pkg ->
509
510
                   do dflags <- getDynFlags
                      let prof = profilingInfo dflags $9 $11
511
512
                          ty  = ThunkSelector (fromIntegral $5)
                          rep = mkRTSRep (fromIntegral $7) $
513
                                   mkHeapRep dflags False 0 0 ty
514
                      return (mkCmmEntryLabel pkg $3,
515
                              Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
Simon Marlow's avatar
untab    
Simon Marlow committed
516
517
518
                                           , cit_rep = rep
                                           , cit_prof = prof, cit_srt = NoC_SRT },
                              []) }
519
520

        | 'INFO_TABLE_RET' '(' NAME ',' INT ')'
Simon Marlow's avatar
untab    
Simon Marlow committed
521
522
523
                -- closure type (no live regs)
                {% withThisPackage $ \pkg ->
                   do let prof = NoProfilingInfo
524
                          rep  = mkRTSRep (fromIntegral $5) $ mkStackRep []
525
                      return (mkCmmRetLabel pkg $3,
526
                              Just $ CmmInfoTable { cit_lbl = mkCmmRetInfoLabel pkg $3
Simon Marlow's avatar
untab    
Simon Marlow committed
527
528
529
                                           , cit_rep = rep
                                           , cit_prof = prof, cit_srt = NoC_SRT },
                              []) }
530
531

        | 'INFO_TABLE_RET' '(' NAME ',' INT ',' formals0 ')'
Simon Marlow's avatar
untab    
Simon Marlow committed
532
533
                -- closure type, live regs
                {% withThisPackage $ \pkg ->
534
                   do dflags <- getDynFlags
535
                      live <- sequence $7
Simon Marlow's avatar
untab    
Simon Marlow committed
536
                      let prof = NoProfilingInfo
537
538
539
                          -- drop one for the info pointer
                          bitmap = mkLiveness dflags (map Just (drop 1 live))
                          rep  = mkRTSRep (fromIntegral $5) $ mkStackRep bitmap
540
                      return (mkCmmRetLabel pkg $3,
541
                              Just $ CmmInfoTable { cit_lbl = mkCmmRetInfoLabel pkg $3
Simon Marlow's avatar
untab    
Simon Marlow committed
542
543
                                           , cit_rep = rep
                                           , cit_prof = prof, cit_srt = NoC_SRT },
544
                              live) }
545

546
body    :: { CmmParse () }
Simon Marlow's avatar
untab    
Simon Marlow committed
547
548
549
        : {- empty -}                   { return () }
        | decl body                     { do $1; $2 }
        | stmt body                     { do $1; $2 }
550

551
decl    :: { CmmParse () }
Simon Marlow's avatar
untab    
Simon Marlow committed
552
553
554
        : type names ';'                { mapM_ (newLocal $1) $2 }
        | 'import' importNames ';'      { mapM_ newImport $2 }
        | 'export' names ';'            { return () }  -- ignore exports
555

556
557

-- an imported function name, with optional packageId
558
559
560
561
562
importNames
        :: { [(FastString, CLabel)] }
        : importName                    { [$1] }
        | importName ',' importNames    { $1 : $3 }

563
importName
564
565
        :: { (FastString,  CLabel) }

Simon Marlow's avatar
untab    
Simon Marlow committed
566
567
568
569
570
        -- A label imported without an explicit packageId.
        --      These are taken to come frome some foreign, unnamed package.
        : NAME  
        { ($1, mkForeignLabel $1 Nothing ForeignLabelInExternalPackage IsFunction) }

571
572
573
574
        -- as previous 'NAME', but 'IsData'
        | 'CLOSURE' NAME
        { ($2, mkForeignLabel $2 Nothing ForeignLabelInExternalPackage IsData) }

Simon Marlow's avatar
untab    
Simon Marlow committed
575
576
        -- A label imported with an explicit packageId.
        | STRING NAME
577
        { ($2, mkCmmCodeLabel (fsToPackageKey (mkFastString $1)) $2) }
Simon Marlow's avatar
untab    
Simon Marlow committed
578
579
580
581
582
583
584
        
        
names   :: { [FastString] }
        : NAME                          { [$1] }
        | NAME ',' names                { $1 : $3 }

stmt    :: { CmmParse () }
585
586
        : ';'                                   { return () }

Simon Marlow's avatar
untab    
Simon Marlow committed
587
        | NAME ':'
588
589
590
591
                { do l <- newLabel $1; emitLabel l }



Simon Marlow's avatar
untab    
Simon Marlow committed
592
        | lreg '=' expr ';'
593
                { do reg <- $1; e <- $3; emitAssign reg e }
Simon Marlow's avatar
untab    
Simon Marlow committed
594
595
        | type '[' expr ']' '=' expr ';'
                { doStore $1 $3 $6 }
596
597

        -- Gah! We really want to say "foreign_results" but that causes
Simon Marlow's avatar
untab    
Simon Marlow committed
598
599
600
601
602
        -- 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.
603
        | foreign_results 'foreign' STRING foreignLabel '(' cmm_hint_exprs0 ')' safety opt_never_returns ';'
604
605
606
                {% foreignCall $3 $1 $4 $6 $8 $9 }
        | foreign_results 'prim' '%' NAME '(' exprs0 ')' ';'
                {% primCall $1 $4 $6 }
Simon Marlow's avatar
untab    
Simon Marlow committed
607
608
609
610
611
612
613
        -- 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 ';'
614
615
616
                { do l <- lookupLabel $2; emit (mkBranch l) }
        | 'return' '(' exprs0 ')' ';'
                { doReturn $3 }
617
        | 'jump' expr vols ';'
618
619
620
621
622
623
624
625
626
                { 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 }
627
        | 'if' bool_expr 'goto' NAME
Simon Marlow's avatar
untab    
Simon Marlow committed
628
629
                { do l <- lookupLabel $4; cmmRawIf $2 l }
        | 'if' bool_expr '{' body '}' else      
Peter Wortmann's avatar
Peter Wortmann committed
630
                { cmmIfThenElse $2 (withSourceNote $3 $5 $4) $6 }
631
632
        | 'push' '(' exprs0 ')' maybe_body
                { pushStackFrame $3 $5 }
633
634
        | 'reserve' expr '=' lreg maybe_body
                { reserveStackFrame $2 $4 $5 }
Peter Wortmann's avatar
Peter Wortmann committed
635
636
        | 'unwind' GLOBALREG '=' expr
                { $4 >>= code . emitUnwind $2 }
637

638
foreignLabel     :: { CmmParse CmmExpr }
639
        : NAME                          { return (CmmLit (CmmLabel (mkForeignLabel $1 Nothing ForeignLabelInThisPackage IsFunction))) }
640

641
642
643
opt_never_returns :: { CmmReturnInfo }
        :                               { CmmMayReturn }
        | 'never' 'returns'             { CmmNeverReturns }
644

645
bool_expr :: { CmmParse BoolExpr }
Simon Marlow's avatar
untab    
Simon Marlow committed
646
647
        : bool_op                       { $1 }
        | expr                          { do e <- $1; return (BoolTest e) }
648
649

bool_op :: { CmmParse BoolExpr }
Simon Marlow's avatar
untab    
Simon Marlow committed
650
651
652
653
654
655
        : bool_expr '&&' bool_expr      { do e1 <- $1; e2 <- $3; 
                                          return (BoolAnd e1 e2) }
        | bool_expr '||' bool_expr      { do e1 <- $1; e2 <- $3; 
                                          return (BoolOr e1 e2)  }
        | '!' bool_expr                 { do e <- $2; return (BoolNot e) }
        | '(' bool_op ')'               { $2 }
656
657
658

safety  :: { Safety }
        : {- empty -}                   { PlayRisky }
Simon Marlow's avatar
untab    
Simon Marlow committed
659
        | STRING                        {% parseSafety $1 }
660
661
662
663

vols    :: { [GlobalReg] }
        : '[' ']'                       { [] }
        | '[' '*' ']'                   {% do df <- getDynFlags
664
665
666
                                         ; return (realArgRegsCover df) }
                                           -- All of them. See comment attached
                                           -- to realArgRegsCover
667
        | '[' globals ']'               { $2 }
668
669

globals :: { [GlobalReg] }
670
671
        : GLOBALREG                     { [$1] }
        | GLOBALREG ',' globals         { $1 : $3 }
672

673
674
maybe_range :: { Maybe (Integer,Integer) }
        : '[' INT '..' INT ']'  { Just ($2, $4) }
675
        | {- empty -}           { Nothing }
676

677
arms    :: { [CmmParse ([Integer],Either BlockId (CmmParse ()))] }
Simon Marlow's avatar
untab    
Simon Marlow committed
678
679
        : {- empty -}                   { [] }
        | arm arms                      { $1 : $2 }
680

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

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

688
689
690
ints    :: { [Integer] }
        : INT                           { [ $1 ] }
        | INT ',' ints                  { $1 : $3 }
691

692
default :: { Maybe (CmmParse ()) }
Peter Wortmann's avatar
Peter Wortmann committed
693
        : 'default' ':' '{' body '}'    { Just (withSourceNote $3 $5 $4) }
Simon Marlow's avatar
untab    
Simon Marlow committed
694
695
696
        -- taking a few liberties with the C-- syntax here; C-- doesn't have
        -- 'default' branches
        | {- empty -}                   { Nothing }
697

698
699
-- Note: OldCmm doesn't support a first class 'else' statement, though
-- CmmNode does.
700
701
else    :: { CmmParse () }
        : {- empty -}                   { return () }
Peter Wortmann's avatar
Peter Wortmann committed
702
        | 'else' '{' body '}'           { withSourceNote $2 $4 $3 }
703
704
705

-- we have to write this out longhand so that Happy's precedence rules
-- can kick in.
706
expr    :: { CmmParse CmmExpr }
Simon Marlow's avatar
untab    
Simon Marlow committed
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
        : 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))) }
        | STRING                 { do s <- code (newStringCLit $1); 
                                      return (CmmLit s) }
        | reg                    { $1 }
        | type '[' expr ']'      { do e <- $3; return (CmmLoad e $1) }
        | '%' NAME '(' exprs0 ')' {% exprOp $2 $4 }
        | '(' expr ')'           { $2 }
738
739
740


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

745
cmm_hint_exprs0 :: { [CmmParse (CmmExpr, ForeignHint)] }
Simon Marlow's avatar
untab    
Simon Marlow committed
746
        : {- empty -}                   { [] }
747
        | cmm_hint_exprs                { $1 }
748

749
cmm_hint_exprs :: { [CmmParse (CmmExpr, ForeignHint)] }
Simon Marlow's avatar
untab    
Simon Marlow committed
750
751
        : cmm_hint_expr                 { [$1] }
        | cmm_hint_expr ',' cmm_hint_exprs      { $1 : $3 }
752

753
754
755
cmm_hint_expr :: { CmmParse (CmmExpr, ForeignHint) }
        : expr                          { do e <- $1;
                                             return (e, inferCmmHint e) }
Simon Marlow's avatar
untab    
Simon Marlow committed
756
757
        | expr STRING                   {% do h <- parseCmmHint $2;
                                              return $ do
758
                                                e <- $1; return (e, h) }
759

760
exprs0  :: { [CmmParse CmmExpr] }
Simon Marlow's avatar
untab    
Simon Marlow committed
761
762
        : {- empty -}                   { [] }
        | exprs                         { $1 }
763

764
exprs   :: { [CmmParse CmmExpr] }
Simon Marlow's avatar
untab    
Simon Marlow committed
765
766
        : expr                          { [ $1 ] }
        | expr ',' exprs                { $1 : $3 }
767

768
reg     :: { CmmParse CmmExpr }
Simon Marlow's avatar
untab    
Simon Marlow committed
769
770
        : NAME                  { lookupName $1 }
        | GLOBALREG             { return (CmmReg (CmmGlobal $1)) }
771
772
773
774
775
776

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

foreign_formals :: { [CmmParse (LocalReg, ForeignHint)] }
Simon Marlow's avatar
untab    
Simon Marlow committed
777
        : foreign_formal                        { [$1] }
778
779
780
781
782
783
784
785
786
787
        | foreign_formal ','                    { [$1] }
        | foreign_formal ',' foreign_formals    { $1 : $3 }

foreign_formal :: { CmmParse (LocalReg, ForeignHint) }
        : local_lreg            { do e <- $1; return (e, (inferCmmHint (CmmReg (CmmLocal e)))) }
        | 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
788
789
790
791
792
793
794
795
796
797
798
799
800
        : NAME                  { do e <- lookupName $1;
                                     return $
                                       case e of 
                                        CmmReg (CmmLocal r) -> r
                                        other -> pprPanic "CmmParse:" (ftext $1 <> text " not a local register") }

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

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

formals0 :: { [CmmParse LocalReg] }
Simon Marlow's avatar
untab    
Simon Marlow committed
807
        : {- empty -}           { [] }
808
809
810
811
812
813
814
815
        | formals               { $1 }

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

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

Simon Marlow's avatar
Simon Marlow committed
818
type    :: { CmmType }
819
820
        : 'bits8'               { b8 }
        | typenot8              { $1 }
821

822
typenot8 :: { CmmType }
823
824
825
        : 'bits16'              { b16 }
        | 'bits32'              { b32 }
        | 'bits64'              { b64 }
826
        | 'bits128'             { b128 }
827
        | 'bits256'             { b256 }
828
        | 'bits512'             { b512 }
829
830
        | 'float32'             { f32 }
        | 'float64'             { f64 }
831
        | 'gcptr'               {% do dflags <- getDynFlags; return $ gcWord dflags }
832

833
834
{
section :: String -> Section
835
836
837
section "text"      = Text
section "data"      = Data
section "rodata"    = ReadOnlyData
838
section "relrodata" = RelocatableReadOnlyData
839
840
section "bss"       = UninitialisedData
section s           = OtherSection s
841

842
843
844
mkString :: String -> CmmStatic
mkString s = CmmString (map (fromIntegral.ord) s)

845
846
847
848
849
850
851
852
853
854
855
-- |
-- Given an info table, decide what the entry convention for the proc
-- is.  That is, for an INFO_TABLE_RET we want the return convention,
-- otherwise it is a NativeNodeCall.
--
infoConv :: Maybe CmmInfoTable -> Convention
infoConv Nothing = NativeNodeCall
infoConv (Just info)
  | isStackRep (cit_rep info) = NativeReturn
  | otherwise                 = NativeNodeCall

856
857
858
859
-- 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.
860
mkMachOp :: (Width -> MachOp) -> [CmmParse CmmExpr] -> CmmParse CmmExpr
861
mkMachOp fn args = do
862
  dflags <- getDynFlags
863
  arg_exprs <- sequence args
864
  return (CmmMachOp (fn (typeWidth (cmmExprType dflags (head arg_exprs)))) arg_exprs)
865
866
867
868
869
870

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

871
nameToMachOp :: FastString -> P (Width -> MachOp)
872
nameToMachOp name =
873
  case lookupUFM machOps name of
874
875
        Nothing -> fail ("unknown primitive " ++ unpackFS name)
        Just m  -> return m
876

877
exprOp :: FastString -> [CmmParse CmmExpr] -> P (CmmParse CmmExpr)
878
879
880
exprOp name args_code = do
  dflags <- getDynFlags
  case lookupUFM (exprMacros dflags) name of
881
882
     Just f  -> return $ do
        args <- sequence args_code
883
        return (f args)
884
     Nothing -> do
885
886
        mo <- nameToMachOp name
        return $ mkMachOp mo args_code
887

888
889
exprMacros :: DynFlags -> UniqFM ([CmmExpr] -> CmmExpr)
exprMacros dflags = listToUFM [
890
  ( fsLit "ENTRY_CODE",   \ [x] -> entryCode dflags x ),
891
  ( fsLit "INFO_PTR",     \ [x] -> closureInfoPtr dflags x ),
892
893
  ( fsLit "STD_INFO",     \ [x] -> infoTable dflags x ),
  ( fsLit "FUN_INFO",     \ [x] -> funInfoTable dflags x ),
894
895
896
  ( 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) ),
897
898
899
  ( fsLit "INFO_TYPE",    \ [x] -> infoTableClosureType dflags x ),
  ( fsLit "INFO_PTRS",    \ [x] -> infoTablePtrs dflags x ),
  ( fsLit "INFO_NPTRS",   \ [x] -> infoTableNonPtrs dflags x )
900
901
902
903
  ]

-- we understand a subset of C-- primitives:
machOps = listToUFM $
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
        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 ),
925

926
        ( "and",        MO_And ),
927
928
929
930
931
932
        ( "or",         MO_Or ),
        ( "xor",        MO_Xor ),
        ( "com",        MO_Not ),
        ( "shl",        MO_Shl ),
        ( "shrl",       MO_U_Shr ),
        ( "shra",       MO_S_Shr ),
933

934
935
936
937
938
939
940
941
942
943
944
945
946
947
        ( "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  ),
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
        ( "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 )
        ]
969

970
callishMachOps :: UniqFM ([CmmExpr] -> (CallishMachOp, [CmmExpr]))
971
callishMachOps = listToUFM $
972
        map (\(x, y) -> (mkFastString x, y)) [
973
974
975
976
        ( "write_barrier", (,) MO_WriteBarrier ),
        ( "memcpy", memcpyLikeTweakArgs MO_Memcpy ),
        ( "memset", memcpyLikeTweakArgs MO_Memset ),
        ( "memmove", memcpyLikeTweakArgs MO_Memmove ),
977

978
979
980
981
        ("prefetch0", (,) $ MO_Prefetch_Data 0),
        ("prefetch1", (,) $ MO_Prefetch_Data 1),
        ("prefetch2", (,) $ MO_Prefetch_Data 2),
        ("prefetch3", (,) $ MO_Prefetch_Data 3)
982

983
        -- ToDo: the rest, maybe
984
985
        -- edit: which rest?
        -- also: how do we tell CMM Lint how to type check callish macops?
986
    ]
987
988
989
990
  where
    memcpyLikeTweakArgs :: (Int -> CallishMachOp) -> [CmmExpr] -> (CallishMachOp, [CmmExpr])
    memcpyLikeTweakArgs op [] = pgmError "memcpy-like function requires at least one argument"
    memcpyLikeTweakArgs op args@(_:_) =
991
        (op align, args')
992
993
994
995
996
997
998
999
1000
      where
        args' = init args
        align = case last args of
          CmmLit (CmmInt alignInteger _) -> fromInteger alignInteger
          e -> pprPgmError "Non-constant alignment in memcpy-like function:" (ppr e)
        -- The alignment of memcpy-ish operations must be a
        -- compile-time constant. We verify this here, passing it around
        -- in the MO_* constructor. In order to do this, however, we
        -- must intercept the arguments in primCall.
1001

1002
1003
1004
1005
parseSafety :: String -> P Safety
parseSafety "safe"   = return PlaySafe
parseSafety "unsafe" = return PlayRisky
parseSafety "interruptible" = return PlayInterruptible
1006
1007
parseSafety str      = fail ("unrecognised safety: " ++ str)

1008
1009
1010
1011
parseCmmHint :: String -> P ForeignHint
parseCmmHint "ptr"    = return AddrHint
parseCmmHint "signed" = return SignedHint
parseCmmHint str      = fail ("unrecognised hint: " ++ str)
1012

1013
-- labels are always pointers, so we might as well infer the hint
1014
1015
1016
1017
1018
inferCmmHint :: CmmExpr -> ForeignHint
inferCmmHint (CmmLit (CmmLabel _)) = AddrHint
inferCmmHint (CmmReg (CmmGlobal g)) | isPtrGlobalReg g = AddrHint
inferCmmHint _ = NoHint

1019
1020
1021
1022
isPtrGlobalReg Sp                    = True
isPtrGlobalReg SpLim                 = True
isPtrGlobalReg Hp                    = True
isPtrGlobalReg HpLim                 = True
1023
1024
1025
isPtrGlobalReg CCCS                  = True
isPtrGlobalReg CurrentTSO            = True
isPtrGlobalReg CurrentNursery        = True
1026
isPtrGlobalReg (VanillaReg _ VGcPtr) = True
1027
isPtrGlobalReg _                     = False
1028
1029
1030
1031
1032
1033
1034

happyError :: P a
happyError = srcParseFail

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

1035
stmtMacro :: FastString -> [CmmParse CmmExpr] -> P (CmmParse ())
1036
1037
1038
1039
stmtMacro fun args_code = do
  case lookupUFM stmtMacros fun of
    Nothing -> fail ("unknown macro: " ++ unpackFS fun)
    Just fcode -> return $ do
1040
1041
        args <- sequence args_code
        code (fcode args)
1042

1043
stmtMacros :: UniqFM ([CmmExpr] -> FCode ())
1044
stmtMacros = listToUFM [
1045
  ( fsLit "CCS_ALLOC",             \[words,ccs]  -> profAlloc words ccs ),
1046
1047
  ( fsLit "ENTER_CCS_THUNK",       \[e] -> enterCostCentreThunk e ),

1048
1049
  ( fsLit "CLOSE_NURSERY",         \[]  -> emitCloseNursery ),
  ( fsLit "OPEN_NURSERY",          \[]  -> emitOpenNursery ),
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070

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

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

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

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

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

1071
1072
  ( fsLit "PUSH_UPD_FRAME",        \[sp,e] -> emitPushUpdateFrame sp e ),
  ( fsLit "SET_HDR",               \[ptr,info,ccs] ->
Simon Marlow's avatar
untab    
Simon Marlow committed
1073
                                        emitSetDynHdr ptr info ccs ),
1074
  ( fsLit "TICK_ALLOC_PRIM",       \[hdr,goods,slop] ->
Simon Marlow's avatar
untab    
Simon Marlow committed
1075
                                        tickyAllocPrim hdr goods slop ),
1076
  ( fsLit "TICK_ALLOC_PAP",        \[goods,slop] ->
Simon Marlow's avatar
untab    
Simon Marlow committed
1077
                                        tickyAllocPAP goods slop ),
1078
  ( fsLit "TICK_ALLOC_UP_THK",     \[goods,slop] ->
Simon Marlow's avatar
untab    
Simon Marlow committed
1079
                                        tickyAllocThunk goods slop ),
1080
  ( fsLit "UPD_BH_UPDATABLE",      \[reg] -> emitBlackHoleCode reg )
1081
1082
 ]

1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
emitPushUpdateFrame :: CmmExpr -> CmmExpr -> FCode ()
emitPushUpdateFrame sp e = do
  dflags <- getDynFlags
  emitUpdateFrame dflags sp mkUpdInfoLabel e

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

1098
1099
1100
1101
1102
1103
reserveStackFrame
  :: CmmParse CmmExpr
  -> CmmParse CmmReg
  -> CmmParse ()
  -> CmmParse ()
reserveStackFrame psize preg body = do
1104
1105
1106
  dflags <- getDynFlags
  old_updfr_off <- getUpdFrameOff
  reg <- preg
1107
1108
1109
1110
1111
1112
  esize <- psize
  let size = case constantFoldExpr dflags esize of
               CmmLit (CmmInt n _) -> n
               _other -> pprPanic "CmmParse: not a compile-time integer: "
                            (ppr esize)
  let frame = old_updfr_off + wORD_SIZE dflags * fromIntegral size
1113
1114
1115
  emitAssign reg (CmmStackSlot Old frame)
  withUpdFrameOff frame body

1116
profilingInfo dflags desc_str ty_str
ian@well-typed.com's avatar
ian@well-typed.com committed
1117
  = if not (gopt Opt_SccProfilingOn dflags)
1118
1119
1120
    then NoProfilingInfo
    else ProfilingInfo (stringToWord8s desc_str)
                       (stringToWord8s ty_str)
1121

1122
1123
staticClosure :: PackageKey -> FastString -> FastString -> [CmmLit] -> CmmParse ()
staticClosure pkg cl_label info payload
1124
  = do dflags <- getDynFlags
1125
       let lits = mkStaticClosure dflags (mkCmmInfoLabel pkg info) dontCareCCS payload [] [] []
1126
       code $ emitDataLits (mkCmmDataLabel pkg cl_label) lits
1127
1128

foreignCall
1129
        :: String
1130
        -> [CmmParse (LocalReg, ForeignHint)]
Simon Marlow's avatar
untab    
Simon Marlow committed
1131
        -> CmmParse CmmExpr
1132
1133
        -> [CmmParse (CmmExpr, ForeignHint)]
        -> Safety
1134
        -> CmmReturnInfo
1135
1136
1137
        -> P (CmmParse ())
foreignCall conv_string results_code expr_code args_code safety ret
  = do  conv <- case conv_string of
1138
          "C" -> return CCallConv
1139
          "stdcall" -> return StdCallConv
1140
          _ -> fail ("unknown calling convention: " ++ conv_string)
1141
        return $ do
1142
          dflags <- getDynFlags
1143
          results <- sequence results_code
Simon Marlow's avatar
untab    
Simon Marlow committed
1144
1145
          expr <- expr_code
          args <- sequence args_code
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
          let
                  expr' = adjCallTarget dflags conv expr args
                  (arg_exprs, arg_hints) = unzip args
                  (res_regs,  res_hints) = unzip results
                  fc = ForeignConvention conv arg_hints res_hints ret
                  target = ForeignTarget expr' fc
          _ <- code $ emitForeignCall safety res_regs target arg_exprs
          return ()


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

1163
1164
1165
1166
1167
1168
mkReturnSimple  :: DynFlags -> [CmmActual] -> UpdFrameOffset -> CmmAGraph
mkReturnSimple dflags actuals updfr_off =
  mkReturn dflags e actuals updfr_off
  where e = entryCode dflags (CmmLoad (CmmStackSlot Old updfr_off)
                             (gcWord dflags))

1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
doRawJump :: CmmParse CmmExpr -> [GlobalReg] -> CmmParse ()
doRawJump expr_code vols = do
  dflags <- getDynFlags
  expr <- expr_code
  updfr_off <- getUpdFrameOff
  emit (mkRawJump dflags expr updfr_off vols)

doJumpWithStack :: CmmParse CmmExpr -> [CmmParse CmmExpr]
                -> [CmmParse CmmExpr] -> CmmParse ()
doJumpWithStack expr_code stk_code args_code = do
  dflags <- getDynFlags
  expr <- expr_code
  stk_args <- sequence stk_code
  args <- sequence args_code
  updfr_off <- getUpdFrameOff
1184
  emit (mkJumpExtra dflags NativeNodeCall expr args updfr_off stk_args)
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197

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

adjCallTarget :: DynFlags -> CCallConv -> CmmExpr -> [(CmmExpr, ForeignHint) ]
1198
              -> CmmExpr
1199
1200
-- On Windows, we have to add the '@N' suffix to the label when making
-- a call with the stdcall calling convention.
1201
1202
adjCallTarget dflags StdCallConv (CmmLit (CmmLabel lbl)) args
 | platformOS (targetPlatform dflags) == OSMinGW32
1203
  = CmmLit (CmmLabel (addLabelSize lbl (sum (map size args))))
1204
  where size (e, _) = max (wORD_SIZE dflags) (widthInBytes (typeWidth (cmmExprType dflags e)))
1205
                 -- c.f. CgForeignCall.emitForeignCall
1206
adjCallTarget _ _ expr _
1207
1208
  = expr

1209
primCall
1210
        :: [CmmParse (CmmFormal, ForeignHint)]
Simon Marlow's avatar
untab    
Simon Marlow committed
1211
        -> FastString
1212
1213
1214
        -> [CmmParse CmmExpr]
        -> P (CmmParse ())
primCall results_code name args_code
1215
  = case lookupUFM callishMachOps name of
1216
        Nothing -> fail ("unknown primitive " ++ unpackFS name)
1217
        Just f  -> return $ do
Simon Marlow's avatar
untab    
Simon Marlow committed
1218
1219
                results <- sequence results_code
                args <- sequence args_code
1220
1221
                let (p, args') = f args
                code (emitPrimCall (map fst results) p args')
1222
1223

doStore :: CmmType -> CmmParse CmmExpr  -> CmmParse CmmExpr -> CmmParse ()
1224
doStore rep addr_code val_code
1225
1226
  = do dflags <- getDynFlags
       addr <- addr_code
1227
       val <- val_code
1228
1229
1230
1231
1232
        -- if the specified store type does not match the type of the expr
        -- on the rhs, then we insert a coercion that will cause the type
        -- mismatch to be flagged by cmm-lint.  If we don't do this, then
        -- the store will happen at the wrong type, and the error will not
        -- be noticed.
1233
       let val_width = typeWidth (cmmExprType dflags val)
1234
           rep_width = typeWidth rep
1235
1236
1237
       let coerce_val
                | val_width /= rep_width = CmmMachOp (MO_UU_Conv val_width rep_width) [val]
                | otherwise              = val
1238
       emitStore addr coerce_val
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250

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

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

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

1251
cmmIfThenElse cond then_part else_part = do
1252
1253
     then_id <- newBlockId
     join_id <- newBlockId
1254
1255
1256
     c <- cond
     emitCond c then_id
     else_part
1257
1258
     emit (mkBranch join_id)
     emitLabel then_id
1259
1260
     then_part
     -- fall through to join
1261
     emitLabel join_id
1262

1263
1264
1265
1266
cmmRawIf cond then_id = do
    c <- cond
    emitCond c then_id

1267
1268
1269
-- 'emitCond cond true_id'  emits code to test whether the cond is true,
-- branching to true_id if so, and falling through otherwise.
emitCond (BoolTest e) then_id = do
1270
1271
1272
  else_id <- newBlockId
  emit (mkCbranch e then_id else_id)
  emitLabel else_id
1273
1274
1275
1276
emitCond (BoolNot (BoolTest (CmmMachOp op args))) then_id
  | Just op' <- maybeInvertComparison op
  = emitCond (BoolTest (CmmMachOp op' args)) then_id
emitCond (BoolNot e) then_id = do
1277
  else_id <- newBlockId
1278
  emitCond e else_id
1279
1280
  emit (mkBranch then_id)
  emitLabel else_id
1281
1282
1283
1284
emitCond (e1 `BoolOr` e2) then_id = do
  emitCond e1 then_id
  emitCond e2 then_id
emitCond (e1 `BoolAnd` e2) then_id = do
1285
        -- we'd like to invert one of the conditionals here to avoid an
Simon Marlow's avatar
untab    
Simon Marlow committed
1286
1287
1288
        -- extra branch instruction, but we can't use maybeInvertComparison
        -- here because we can't look too closely at the expression since
        -- we're in a loop.
1289
1290
  and_id <- newBlockId
  else_id <- newBlockId
1291
  emitCond e1 and_id
1292
1293
  emit (mkBranch else_id)
  emitLabel and_id
1294
  emitCond e2 then_id
1295
  emitLabel else_id
1296

Peter Wortmann's avatar
Peter Wortmann committed
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
-- -----------------------------------------------------------------------------
-- Source code notes

-- | Generate a source note spanning from "a" to "b" (inclusive), then
-- proceed with parsing. This allows debugging tools to reason about
-- locations in Cmm code.
withSourceNote :: Located a -> Located b -> CmmParse c -> CmmParse c