Revert "Add new mbmi and mbmi2 compiler flags"
[ghc.git] / compiler / cmm / CmmParse.y
1 -----------------------------------------------------------------------------
2 --
3 -- (c) The University of Glasgow, 2004-2012
4 --
5 -- Parser for concrete Cmm.
6 --
7 -----------------------------------------------------------------------------
8
9 {- -----------------------------------------------------------------------------
10 Note [Syntax of .cmm files]
11
12 NOTE: You are very much on your own in .cmm.  There is very little
13 error checking at all:
14
15   * Type errors are detected by the (optional) -dcmm-lint pass, if you
16     don't turn this on then a type error will likely result in a panic
17     from the native code generator.
18
19   * Passing the wrong number of arguments or arguments of the wrong
20     type is not detected.
21
22 There are two ways to write .cmm code:
23
24  (1) High-level Cmm code delegates the stack handling to GHC, and
25      never explicitly mentions Sp or registers.
26
27  (2) Low-level Cmm manages the stack itself, and must know about
28      calling conventions.
29
30 Whether you want high-level or low-level Cmm is indicated by the
31 presence of an argument list on a procedure.  For example:
32
33 foo ( gcptr a, bits32 b )
34 {
35   // this is high-level cmm code
36
37   if (b > 0) {
38      // we can make tail calls passing arguments:
39      jump stg_ap_0_fast(a);
40   }
41
42   push (stg_upd_frame_info, a) {
43     // stack frames can be explicitly pushed
44
45     (x,y) = call wibble(a,b,3,4);
46       // calls pass arguments and return results using the native
47       // Haskell calling convention.  The code generator will automatically
48       // construct a stack frame and an info table for the continuation.
49
50     return (x,y);
51       // we can return multiple values from the current proc
52   }
53 }
54
55 bar
56 {
57   // this is low-level cmm code, indicated by the fact that we did not
58   // put an argument list on bar.
59
60   x = R1;  // the calling convention is explicit: better be careful
61            // that this works on all platforms!
62
63   jump %ENTRY_CODE(Sp(0))
64 }
65
66 Here is a list of rules for high-level and low-level code.  If you
67 break the rules, you get a panic (for using a high-level construct in
68 a low-level proc), or wrong code (when using low-level code in a
69 high-level proc).  This stuff isn't checked! (TODO!)
70
71 High-level only:
72
73   - tail-calls with arguments, e.g.
74     jump stg_fun (arg1, arg2);
75
76   - function calls:
77     (ret1,ret2) = call stg_fun (arg1, arg2);
78
79     This makes a call with the NativeNodeCall convention, and the
80     values are returned to the following code using the NativeReturn
81     convention.
82
83   - returning:
84     return (ret1, ret2)
85
86     These use the NativeReturn convention to return zero or more
87     results to the caller.
88
89   - pushing stack frames:
90     push (info_ptr, field1, ..., fieldN) { ... statements ... }
91
92   - reserving temporary stack space:
93
94       reserve N = x { ... }
95
96     this reserves an area of size N (words) on the top of the stack,
97     and binds its address to x (a local register).  Typically this is
98     used for allocating temporary storage for passing to foreign
99     functions.
100
101     Note that if you make any native calls or invoke the GC in the
102     scope of the reserve block, you are responsible for ensuring that
103     the stack you reserved is laid out correctly with an info table.
104
105 Low-level only:
106
107   - References to Sp, R1-R8, F1-F4 etc.
108
109     NB. foreign calls may clobber the argument registers R1-R8, F1-F4
110     etc., so ensure they are saved into variables around foreign
111     calls.
112
113   - SAVE_THREAD_STATE() and LOAD_THREAD_STATE(), which modify Sp
114     directly.
115
116 Both high-level and low-level code can use a raw tail-call:
117
118     jump stg_fun [R1,R2]
119
120 NB. you *must* specify the list of GlobalRegs that are passed via a
121 jump, otherwise the register allocator will assume that all the
122 GlobalRegs are dead at the jump.
123
124
125 Calling Conventions
126 -------------------
127
128 High-level procedures use the NativeNode calling convention, or the
129 NativeReturn convention if the 'return' keyword is used (see Stack
130 Frames below).
131
132 Low-level procedures implement their own calling convention, so it can
133 be anything at all.
134
135 If a low-level procedure implements the NativeNode calling convention,
136 then it can be called by high-level code using an ordinary function
137 call.  In general this is hard to arrange because the calling
138 convention depends on the number of physical registers available for
139 parameter passing, but there are two cases where the calling
140 convention is platform-independent:
141
142  - Zero arguments.
143
144  - One argument of pointer or non-pointer word type; this is always
145    passed in R1 according to the NativeNode convention.
146
147  - Returning a single value; these conventions are fixed and platform
148    independent.
149
150
151 Stack Frames
152 ------------
153
154 A stack frame is written like this:
155
156 INFO_TABLE_RET ( label, FRAME_TYPE, info_ptr, field1, ..., fieldN )
157                return ( arg1, ..., argM )
158 {
159   ... code ...
160 }
161
162 where field1 ... fieldN are the fields of the stack frame (with types)
163 arg1...argN are the values returned to the stack frame (with types).
164 The return values are assumed to be passed according to the
165 NativeReturn convention.
166
167 On entry to the code, the stack frame looks like:
168
169    |----------|
170    | fieldN   |
171    |   ...    |
172    | field1   |
173    |----------|
174    | info_ptr |
175    |----------|
176    |  argN    |
177    |   ...    | <- Sp
178
179 and some of the args may be in registers.
180
181 We prepend the code by a copyIn of the args, and assign all the stack
182 frame fields to their formals.  The initial "arg offset" for stack
183 layout purposes consists of the whole stack frame plus any args that
184 might be on the stack.
185
186 A tail-call may pass a stack frame to the callee using the following
187 syntax:
188
189 jump f (info_ptr, field1,..,fieldN) (arg1,..,argN)
190
191 where info_ptr and field1..fieldN describe the stack frame, and
192 arg1..argN are the arguments passed to f using the NativeNodeCall
193 convention. Note if a field is longer than a word (e.g. a D_ on
194 a 32-bit machine) then the call will push as many words as
195 necessary to the stack to accommodate it (e.g. 2).
196
197
198 ----------------------------------------------------------------------------- -}
199
200 {
201 module CmmParse ( parseCmmFile ) where
202
203 import GhcPrelude
204
205 import StgCmmExtCode
206 import CmmCallConv
207 import StgCmmProf
208 import StgCmmHeap
209 import StgCmmMonad hiding ( getCode, getCodeR, getCodeScoped, emitLabel, emit, emitStore
210                           , emitAssign, emitOutOfLine, withUpdFrameOff
211                           , getUpdFrameOff )
212 import qualified StgCmmMonad as F
213 import StgCmmUtils
214 import StgCmmForeign
215 import StgCmmExpr
216 import StgCmmClosure
217 import StgCmmLayout     hiding (ArgRep(..))
218 import StgCmmTicky
219 import StgCmmBind       ( emitBlackHoleCode, emitUpdateFrame )
220 import CoreSyn          ( Tickish(SourceNote) )
221
222 import CmmOpt
223 import MkGraph
224 import Cmm
225 import CmmUtils
226 import CmmSwitch        ( mkSwitchTargets )
227 import CmmInfo
228 import BlockId
229 import CmmLex
230 import CLabel
231 import SMRep
232 import Lexer
233 import CmmMonad
234
235 import CostCentre
236 import ForeignCall
237 import Module
238 import Platform
239 import Literal
240 import Unique
241 import UniqFM
242 import SrcLoc
243 import DynFlags
244 import ErrUtils
245 import StringBuffer
246 import FastString
247 import Panic
248 import Constants
249 import Outputable
250 import BasicTypes
251 import Bag              ( emptyBag, unitBag )
252 import Var
253
254 import Control.Monad
255 import Data.Array
256 import Data.Char        ( ord )
257 import System.Exit
258 import Data.Maybe
259 import qualified Data.Map as M
260
261 #include "HsVersions.h"
262 }
263
264 %expect 0
265
266 %token
267         ':'     { L _ (CmmT_SpecChar ':') }
268         ';'     { L _ (CmmT_SpecChar ';') }
269         '{'     { L _ (CmmT_SpecChar '{') }
270         '}'     { L _ (CmmT_SpecChar '}') }
271         '['     { L _ (CmmT_SpecChar '[') }
272         ']'     { L _ (CmmT_SpecChar ']') }
273         '('     { L _ (CmmT_SpecChar '(') }
274         ')'     { L _ (CmmT_SpecChar ')') }
275         '='     { L _ (CmmT_SpecChar '=') }
276         '`'     { L _ (CmmT_SpecChar '`') }
277         '~'     { L _ (CmmT_SpecChar '~') }
278         '/'     { L _ (CmmT_SpecChar '/') }
279         '*'     { L _ (CmmT_SpecChar '*') }
280         '%'     { L _ (CmmT_SpecChar '%') }
281         '-'     { L _ (CmmT_SpecChar '-') }
282         '+'     { L _ (CmmT_SpecChar '+') }
283         '&'     { L _ (CmmT_SpecChar '&') }
284         '^'     { L _ (CmmT_SpecChar '^') }
285         '|'     { L _ (CmmT_SpecChar '|') }
286         '>'     { L _ (CmmT_SpecChar '>') }
287         '<'     { L _ (CmmT_SpecChar '<') }
288         ','     { L _ (CmmT_SpecChar ',') }
289         '!'     { L _ (CmmT_SpecChar '!') }
290
291         '..'    { L _ (CmmT_DotDot) }
292         '::'    { L _ (CmmT_DoubleColon) }
293         '>>'    { L _ (CmmT_Shr) }
294         '<<'    { L _ (CmmT_Shl) }
295         '>='    { L _ (CmmT_Ge) }
296         '<='    { L _ (CmmT_Le) }
297         '=='    { L _ (CmmT_Eq) }
298         '!='    { L _ (CmmT_Ne) }
299         '&&'    { L _ (CmmT_BoolAnd) }
300         '||'    { L _ (CmmT_BoolOr) }
301
302         'CLOSURE'       { L _ (CmmT_CLOSURE) }
303         'INFO_TABLE'    { L _ (CmmT_INFO_TABLE) }
304         'INFO_TABLE_RET'{ L _ (CmmT_INFO_TABLE_RET) }
305         'INFO_TABLE_FUN'{ L _ (CmmT_INFO_TABLE_FUN) }
306         'INFO_TABLE_CONSTR'{ L _ (CmmT_INFO_TABLE_CONSTR) }
307         'INFO_TABLE_SELECTOR'{ L _ (CmmT_INFO_TABLE_SELECTOR) }
308         'else'          { L _ (CmmT_else) }
309         'export'        { L _ (CmmT_export) }
310         'section'       { L _ (CmmT_section) }
311         'goto'          { L _ (CmmT_goto) }
312         'if'            { L _ (CmmT_if) }
313         'call'          { L _ (CmmT_call) }
314         'jump'          { L _ (CmmT_jump) }
315         'foreign'       { L _ (CmmT_foreign) }
316         'never'         { L _ (CmmT_never) }
317         'prim'          { L _ (CmmT_prim) }
318         'reserve'       { L _ (CmmT_reserve) }
319         'return'        { L _ (CmmT_return) }
320         'returns'       { L _ (CmmT_returns) }
321         'import'        { L _ (CmmT_import) }
322         'switch'        { L _ (CmmT_switch) }
323         'case'          { L _ (CmmT_case) }
324         'default'       { L _ (CmmT_default) }
325         'push'          { L _ (CmmT_push) }
326         'unwind'        { L _ (CmmT_unwind) }
327         'bits8'         { L _ (CmmT_bits8) }
328         'bits16'        { L _ (CmmT_bits16) }
329         'bits32'        { L _ (CmmT_bits32) }
330         'bits64'        { L _ (CmmT_bits64) }
331         'bits128'       { L _ (CmmT_bits128) }
332         'bits256'       { L _ (CmmT_bits256) }
333         'bits512'       { L _ (CmmT_bits512) }
334         'float32'       { L _ (CmmT_float32) }
335         'float64'       { L _ (CmmT_float64) }
336         'gcptr'         { L _ (CmmT_gcptr) }
337
338         GLOBALREG       { L _ (CmmT_GlobalReg   $$) }
339         NAME            { L _ (CmmT_Name        $$) }
340         STRING          { L _ (CmmT_String      $$) }
341         INT             { L _ (CmmT_Int         $$) }
342         FLOAT           { L _ (CmmT_Float       $$) }
343
344 %monad { PD } { >>= } { return }
345 %lexer { cmmlex } { L _ CmmT_EOF }
346 %name cmmParse cmm
347 %tokentype { Located CmmToken }
348
349 -- C-- operator precedences, taken from the C-- spec
350 %right '||'     -- non-std extension, called %disjoin in C--
351 %right '&&'     -- non-std extension, called %conjoin in C--
352 %right '!'
353 %nonassoc '>=' '>' '<=' '<' '!=' '=='
354 %left '|'
355 %left '^'
356 %left '&'
357 %left '>>' '<<'
358 %left '-' '+'
359 %left '/' '*' '%'
360 %right '~'
361
362 %%
363
364 cmm     :: { CmmParse () }
365         : {- empty -}                   { return () }
366         | cmmtop cmm                    { do $1; $2 }
367
368 cmmtop  :: { CmmParse () }
369         : cmmproc                       { $1 }
370         | cmmdata                       { $1 }
371         | decl                          { $1 } 
372         | 'CLOSURE' '(' NAME ',' NAME lits ')' ';'  
373                 {% liftP . withThisPackage $ \pkg ->
374                    do lits <- sequence $6;
375                       staticClosure pkg $3 $5 (map getLit lits) }
376
377 -- The only static closures in the RTS are dummy closures like
378 -- stg_END_TSO_QUEUE_closure and stg_dummy_ret.  We don't need
379 -- to provide the full generality of static closures here.
380 -- In particular:
381 --      * CCS can always be CCS_DONT_CARE
382 --      * closure is always extern
383 --      * payload is always empty
384 --      * we can derive closure and info table labels from a single NAME
385
386 cmmdata :: { CmmParse () }
387         : 'section' STRING '{' data_label statics '}' 
388                 { do lbl <- $4;
389                      ss <- sequence $5;
390                      code (emitDecl (CmmData (Section (section $2) lbl) (Statics lbl $ concat ss))) }
391
392 data_label :: { CmmParse CLabel }
393     : NAME ':'  
394                 {% liftP . withThisPackage $ \pkg ->
395                    return (mkCmmDataLabel pkg $1) }
396
397 statics :: { [CmmParse [CmmStatic]] }
398         : {- empty -}                   { [] }
399         | static statics                { $1 : $2 }
400     
401 -- Strings aren't used much in the RTS HC code, so it doesn't seem
402 -- worth allowing inline strings.  C-- doesn't allow them anyway.
403 static  :: { CmmParse [CmmStatic] }
404         : type expr ';' { do e <- $2;
405                              return [CmmStaticLit (getLit e)] }
406         | type ';'                      { return [CmmUninitialised
407                                                         (widthInBytes (typeWidth $1))] }
408         | 'bits8' '[' ']' STRING ';'    { return [mkString $4] }
409         | 'bits8' '[' INT ']' ';'       { return [CmmUninitialised 
410                                                         (fromIntegral $3)] }
411         | typenot8 '[' INT ']' ';'      { return [CmmUninitialised 
412                                                 (widthInBytes (typeWidth $1) * 
413                                                         fromIntegral $3)] }
414         | 'CLOSURE' '(' NAME lits ')'
415                 { do { lits <- sequence $4
416                 ; dflags <- getDynFlags
417                      ; return $ map CmmStaticLit $
418                         mkStaticClosure dflags (mkForeignLabel $3 Nothing ForeignLabelInExternalPackage IsData)
419                          -- mkForeignLabel because these are only used
420                          -- for CHARLIKE and INTLIKE closures in the RTS.
421                         dontCareCCS (map getLit lits) [] [] [] } }
422         -- arrays of closures required for the CHARLIKE & INTLIKE arrays
423
424 lits    :: { [CmmParse CmmExpr] }
425         : {- empty -}           { [] }
426         | ',' expr lits         { $2 : $3 }
427
428 cmmproc :: { CmmParse () }
429         : info maybe_conv maybe_formals maybe_body
430                 { do ((entry_ret_label, info, stk_formals, formals), agraph) <-
431                        getCodeScoped $ loopDecls $ do {
432                          (entry_ret_label, info, stk_formals) <- $1;
433                          dflags <- getDynFlags;
434                          formals <- sequence (fromMaybe [] $3);
435                          withName (showSDoc dflags (ppr entry_ret_label))
436                            $4;
437                          return (entry_ret_label, info, stk_formals, formals) }
438                      let do_layout = isJust $3
439                      code (emitProcWithStackFrame $2 info
440                                 entry_ret_label stk_formals formals agraph
441                                 do_layout ) }
442
443 maybe_conv :: { Convention }
444            : {- empty -}        { NativeNodeCall }
445            | 'return'           { NativeReturn }
446
447 maybe_body :: { CmmParse () }
448            : ';'                { return () }
449            | '{' body '}'       { withSourceNote $1 $3 $2 }
450
451 info    :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }
452         : NAME
453                 {% liftP . withThisPackage $ \pkg ->
454                    do   newFunctionName $1 pkg
455                         return (mkCmmCodeLabel pkg $1, Nothing, []) }
456
457
458         | 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
459                 -- ptrs, nptrs, closure type, description, type
460                 {% liftP . withThisPackage $ \pkg ->
461                    do dflags <- getDynFlags
462                       let prof = profilingInfo dflags $11 $13
463                           rep  = mkRTSRep (fromIntegral $9) $
464                                    mkHeapRep dflags False (fromIntegral $5)
465                                                    (fromIntegral $7) Thunk
466                               -- not really Thunk, but that makes the info table
467                               -- we want.
468                       return (mkCmmEntryLabel pkg $3,
469                               Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
470                                            , cit_rep = rep
471                                            , cit_prof = prof, cit_srt = NoC_SRT },
472                               []) }
473         
474         | 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ')'
475                 -- ptrs, nptrs, closure type, description, type, fun type
476                 {% liftP . withThisPackage $ \pkg ->
477                    do dflags <- getDynFlags
478                       let prof = profilingInfo dflags $11 $13
479                           ty   = Fun 0 (ArgSpec (fromIntegral $15))
480                                 -- Arity zero, arg_type $15
481                           rep = mkRTSRep (fromIntegral $9) $
482                                     mkHeapRep dflags False (fromIntegral $5)
483                                                     (fromIntegral $7) ty
484                       return (mkCmmEntryLabel pkg $3,
485                               Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
486                                            , cit_rep = rep
487                                            , cit_prof = prof, cit_srt = NoC_SRT },
488                               []) }
489                 -- we leave most of the fields zero here.  This is only used
490                 -- to generate the BCO info table in the RTS at the moment.
491
492         | 'INFO_TABLE_CONSTR' '(' NAME ',' INT ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
493                 -- ptrs, nptrs, tag, closure type, description, type
494                 {% liftP . withThisPackage $ \pkg ->
495                    do dflags <- getDynFlags
496                       let prof = profilingInfo dflags $13 $15
497                           ty  = Constr (fromIntegral $9)  -- Tag
498                                        (stringToWord8s $13)
499                           rep = mkRTSRep (fromIntegral $11) $
500                                   mkHeapRep dflags False (fromIntegral $5)
501                                                   (fromIntegral $7) ty
502                       return (mkCmmEntryLabel pkg $3,
503                               Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
504                                            , cit_rep = rep
505                                            , cit_prof = prof, cit_srt = NoC_SRT },
506                               []) }
507
508                      -- If profiling is on, this string gets duplicated,
509                      -- but that's the way the old code did it we can fix it some other time.
510         
511         | 'INFO_TABLE_SELECTOR' '(' NAME ',' INT ',' INT ',' STRING ',' STRING ')'
512                 -- selector, closure type, description, type
513                 {% liftP . withThisPackage $ \pkg ->
514                    do dflags <- getDynFlags
515                       let prof = profilingInfo dflags $9 $11
516                           ty  = ThunkSelector (fromIntegral $5)
517                           rep = mkRTSRep (fromIntegral $7) $
518                                    mkHeapRep dflags False 0 0 ty
519                       return (mkCmmEntryLabel pkg $3,
520                               Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
521                                            , cit_rep = rep
522                                            , cit_prof = prof, cit_srt = NoC_SRT },
523                               []) }
524
525         | 'INFO_TABLE_RET' '(' NAME ',' INT ')'
526                 -- closure type (no live regs)
527                 {% liftP . withThisPackage $ \pkg ->
528                    do let prof = NoProfilingInfo
529                           rep  = mkRTSRep (fromIntegral $5) $ mkStackRep []
530                       return (mkCmmRetLabel pkg $3,
531                               Just $ CmmInfoTable { cit_lbl = mkCmmRetInfoLabel pkg $3
532                                            , cit_rep = rep
533                                            , cit_prof = prof, cit_srt = NoC_SRT },
534                               []) }
535
536         | 'INFO_TABLE_RET' '(' NAME ',' INT ',' formals0 ')'
537                 -- closure type, live regs
538                 {% liftP . withThisPackage $ \pkg ->
539                    do dflags <- getDynFlags
540                       live <- sequence $7
541                       let prof = NoProfilingInfo
542                           -- drop one for the info pointer
543                           bitmap = mkLiveness dflags (map Just (drop 1 live))
544                           rep  = mkRTSRep (fromIntegral $5) $ mkStackRep bitmap
545                       return (mkCmmRetLabel pkg $3,
546                               Just $ CmmInfoTable { cit_lbl = mkCmmRetInfoLabel pkg $3
547                                            , cit_rep = rep
548                                            , cit_prof = prof, cit_srt = NoC_SRT },
549                               live) }
550
551 body    :: { CmmParse () }
552         : {- empty -}                   { return () }
553         | decl body                     { do $1; $2 }
554         | stmt body                     { do $1; $2 }
555
556 decl    :: { CmmParse () }
557         : type names ';'                { mapM_ (newLocal $1) $2 }
558         | 'import' importNames ';'      { mapM_ newImport $2 }
559         | 'export' names ';'            { return () }  -- ignore exports
560
561
562 -- an imported function name, with optional packageId
563 importNames
564         :: { [(FastString, CLabel)] }
565         : importName                    { [$1] }
566         | importName ',' importNames    { $1 : $3 }
567
568 importName
569         :: { (FastString,  CLabel) }
570
571         -- A label imported without an explicit packageId.
572         --      These are taken to come frome some foreign, unnamed package.
573         : NAME  
574         { ($1, mkForeignLabel $1 Nothing ForeignLabelInExternalPackage IsFunction) }
575
576         -- as previous 'NAME', but 'IsData'
577         | 'CLOSURE' NAME
578         { ($2, mkForeignLabel $2 Nothing ForeignLabelInExternalPackage IsData) }
579
580         -- A label imported with an explicit packageId.
581         | STRING NAME
582         { ($2, mkCmmCodeLabel (fsToUnitId (mkFastString $1)) $2) }
583         
584         
585 names   :: { [FastString] }
586         : NAME                          { [$1] }
587         | NAME ',' names                { $1 : $3 }
588
589 stmt    :: { CmmParse () }
590         : ';'                                   { return () }
591
592         | NAME ':'
593                 { do l <- newLabel $1; emitLabel l }
594
595
596
597         | lreg '=' expr ';'
598                 { do reg <- $1; e <- $3; withSourceNote $2 $4 (emitAssign reg e) }
599         | type '[' expr ']' '=' expr ';'
600                 { withSourceNote $2 $7 (doStore $1 $3 $6) }
601
602         -- Gah! We really want to say "foreign_results" but that causes
603         -- a shift/reduce conflict with assignment.  We either
604         -- we expand out the no-result and single result cases or
605         -- we tweak the syntax to avoid the conflict.  The later
606         -- option is taken here because the other way would require
607         -- multiple levels of expanding and get unwieldy.
608         | foreign_results 'foreign' STRING foreignLabel '(' cmm_hint_exprs0 ')' safety opt_never_returns ';'
609                 {% foreignCall $3 $1 $4 $6 $8 $9 }
610         | foreign_results 'prim' '%' NAME '(' exprs0 ')' ';'
611                 {% primCall $1 $4 $6 }
612         -- stmt-level macros, stealing syntax from ordinary C-- function calls.
613         -- Perhaps we ought to use the %%-form?
614         | NAME '(' exprs0 ')' ';'
615                 {% stmtMacro $1 $3  }
616         | 'switch' maybe_range expr '{' arms default '}'
617                 { do as <- sequence $5; doSwitch $2 $3 as $6 }
618         | 'goto' NAME ';'
619                 { do l <- lookupLabel $2; emit (mkBranch l) }
620         | 'return' '(' exprs0 ')' ';'
621                 { doReturn $3 }
622         | 'jump' expr vols ';'
623                 { doRawJump $2 $3 }
624         | 'jump' expr '(' exprs0 ')' ';'
625                 { doJumpWithStack $2 [] $4 }
626         | 'jump' expr '(' exprs0 ')' '(' exprs0 ')' ';'
627                 { doJumpWithStack $2 $4 $7 }
628         | 'call' expr '(' exprs0 ')' ';'
629                 { doCall $2 [] $4 }
630         | '(' formals ')' '=' 'call' expr '(' exprs0 ')' ';'
631                 { doCall $6 $2 $8 }
632         | 'if' bool_expr 'goto' NAME
633                 { do l <- lookupLabel $4; cmmRawIf $2 l }
634         | 'if' bool_expr '{' body '}' else      
635                 { cmmIfThenElse $2 (withSourceNote $3 $5 $4) $6 }
636         | 'push' '(' exprs0 ')' maybe_body
637                 { pushStackFrame $3 $5 }
638         | 'reserve' expr '=' lreg maybe_body
639                 { reserveStackFrame $2 $4 $5 }
640         | 'unwind' unwind_regs ';'
641                 { $2 >>= code . emitUnwind }
642
643 unwind_regs
644         :: { CmmParse [(GlobalReg, Maybe CmmExpr)] }
645         : GLOBALREG '=' expr_or_unknown ',' unwind_regs
646                 { do e <- $3; rest <- $5; return (($1, e) : rest) }
647         | GLOBALREG '=' expr_or_unknown
648                 { do e <- $3; return [($1, e)] }
649
650 -- | Used by unwind to indicate unknown unwinding values.
651 expr_or_unknown
652         :: { CmmParse (Maybe CmmExpr) }
653         : 'return'
654                 { do return Nothing }
655         | expr
656                 { do e <- $1; return (Just e) }
657
658 foreignLabel     :: { CmmParse CmmExpr }
659         : NAME                          { return (CmmLit (CmmLabel (mkForeignLabel $1 Nothing ForeignLabelInThisPackage IsFunction))) }
660
661 opt_never_returns :: { CmmReturnInfo }
662         :                               { CmmMayReturn }
663         | 'never' 'returns'             { CmmNeverReturns }
664
665 bool_expr :: { CmmParse BoolExpr }
666         : bool_op                       { $1 }
667         | expr                          { do e <- $1; return (BoolTest e) }
668
669 bool_op :: { CmmParse BoolExpr }
670         : bool_expr '&&' bool_expr      { do e1 <- $1; e2 <- $3; 
671                                           return (BoolAnd e1 e2) }
672         | bool_expr '||' bool_expr      { do e1 <- $1; e2 <- $3; 
673                                           return (BoolOr e1 e2)  }
674         | '!' bool_expr                 { do e <- $2; return (BoolNot e) }
675         | '(' bool_op ')'               { $2 }
676
677 safety  :: { Safety }
678         : {- empty -}                   { PlayRisky }
679         | STRING                        {% parseSafety $1 }
680
681 vols    :: { [GlobalReg] }
682         : '[' ']'                       { [] }
683         | '[' '*' ']'                   {% do df <- getDynFlags
684                                          ; return (realArgRegsCover df) }
685                                            -- All of them. See comment attached
686                                            -- to realArgRegsCover
687         | '[' globals ']'               { $2 }
688
689 globals :: { [GlobalReg] }
690         : GLOBALREG                     { [$1] }
691         | GLOBALREG ',' globals         { $1 : $3 }
692
693 maybe_range :: { Maybe (Integer,Integer) }
694         : '[' INT '..' INT ']'  { Just ($2, $4) }
695         | {- empty -}           { Nothing }
696
697 arms    :: { [CmmParse ([Integer],Either BlockId (CmmParse ()))] }
698         : {- empty -}                   { [] }
699         | arm arms                      { $1 : $2 }
700
701 arm     :: { CmmParse ([Integer],Either BlockId (CmmParse ())) }
702         : 'case' ints ':' arm_body      { do b <- $4; return ($2, b) }
703
704 arm_body :: { CmmParse (Either BlockId (CmmParse ())) }
705         : '{' body '}'                  { return (Right (withSourceNote $1 $3 $2)) }
706         | 'goto' NAME ';'               { do l <- lookupLabel $2; return (Left l) }
707
708 ints    :: { [Integer] }
709         : INT                           { [ $1 ] }
710         | INT ',' ints                  { $1 : $3 }
711
712 default :: { Maybe (CmmParse ()) }
713         : 'default' ':' '{' body '}'    { Just (withSourceNote $3 $5 $4) }
714         -- taking a few liberties with the C-- syntax here; C-- doesn't have
715         -- 'default' branches
716         | {- empty -}                   { Nothing }
717
718 -- Note: OldCmm doesn't support a first class 'else' statement, though
719 -- CmmNode does.
720 else    :: { CmmParse () }
721         : {- empty -}                   { return () }
722         | 'else' '{' body '}'           { withSourceNote $2 $4 $3 }
723
724 -- we have to write this out longhand so that Happy's precedence rules
725 -- can kick in.
726 expr    :: { CmmParse CmmExpr }
727         : expr '/' expr                 { mkMachOp MO_U_Quot [$1,$3] }
728         | expr '*' expr                 { mkMachOp MO_Mul [$1,$3] }
729         | expr '%' expr                 { mkMachOp MO_U_Rem [$1,$3] }
730         | expr '-' expr                 { mkMachOp MO_Sub [$1,$3] }
731         | expr '+' expr                 { mkMachOp MO_Add [$1,$3] }
732         | expr '>>' expr                { mkMachOp MO_U_Shr [$1,$3] }
733         | expr '<<' expr                { mkMachOp MO_Shl [$1,$3] }
734         | expr '&' expr                 { mkMachOp MO_And [$1,$3] }
735         | expr '^' expr                 { mkMachOp MO_Xor [$1,$3] }
736         | expr '|' expr                 { mkMachOp MO_Or [$1,$3] }
737         | expr '>=' expr                { mkMachOp MO_U_Ge [$1,$3] }
738         | expr '>' expr                 { mkMachOp MO_U_Gt [$1,$3] }
739         | expr '<=' expr                { mkMachOp MO_U_Le [$1,$3] }
740         | expr '<' expr                 { mkMachOp MO_U_Lt [$1,$3] }
741         | expr '!=' expr                { mkMachOp MO_Ne [$1,$3] }
742         | expr '==' expr                { mkMachOp MO_Eq [$1,$3] }
743         | '~' expr                      { mkMachOp MO_Not [$2] }
744         | '-' expr                      { mkMachOp MO_S_Neg [$2] }
745         | expr0 '`' NAME '`' expr0      {% do { mo <- nameToMachOp $3 ;
746                                                 return (mkMachOp mo [$1,$5]) } }
747         | expr0                         { $1 }
748
749 expr0   :: { CmmParse CmmExpr }
750         : INT   maybe_ty         { return (CmmLit (CmmInt $1 (typeWidth $2))) }
751         | FLOAT maybe_ty         { return (CmmLit (CmmFloat $1 (typeWidth $2))) }
752         | STRING                 { do s <- code (newStringCLit $1); 
753                                       return (CmmLit s) }
754         | reg                    { $1 }
755         | type '[' expr ']'      { do e <- $3; return (CmmLoad e $1) }
756         | '%' NAME '(' exprs0 ')' {% exprOp $2 $4 }
757         | '(' expr ')'           { $2 }
758
759
760 -- leaving out the type of a literal gives you the native word size in C--
761 maybe_ty :: { CmmType }
762         : {- empty -}                   {% do dflags <- getDynFlags; return $ bWord dflags }
763         | '::' type                     { $2 }
764
765 cmm_hint_exprs0 :: { [CmmParse (CmmExpr, ForeignHint)] }
766         : {- empty -}                   { [] }
767         | cmm_hint_exprs                { $1 }
768
769 cmm_hint_exprs :: { [CmmParse (CmmExpr, ForeignHint)] }
770         : cmm_hint_expr                 { [$1] }
771         | cmm_hint_expr ',' cmm_hint_exprs      { $1 : $3 }
772
773 cmm_hint_expr :: { CmmParse (CmmExpr, ForeignHint) }
774         : expr                          { do e <- $1;
775                                              return (e, inferCmmHint e) }
776         | expr STRING                   {% do h <- parseCmmHint $2;
777                                               return $ do
778                                                 e <- $1; return (e, h) }
779
780 exprs0  :: { [CmmParse CmmExpr] }
781         : {- empty -}                   { [] }
782         | exprs                         { $1 }
783
784 exprs   :: { [CmmParse CmmExpr] }
785         : expr                          { [ $1 ] }
786         | expr ',' exprs                { $1 : $3 }
787
788 reg     :: { CmmParse CmmExpr }
789         : NAME                  { lookupName $1 }
790         | GLOBALREG             { return (CmmReg (CmmGlobal $1)) }
791
792 foreign_results :: { [CmmParse (LocalReg, ForeignHint)] }
793         : {- empty -}                   { [] }
794         | '(' foreign_formals ')' '='   { $2 }
795
796 foreign_formals :: { [CmmParse (LocalReg, ForeignHint)] }
797         : foreign_formal                        { [$1] }
798         | foreign_formal ','                    { [$1] }
799         | foreign_formal ',' foreign_formals    { $1 : $3 }
800
801 foreign_formal :: { CmmParse (LocalReg, ForeignHint) }
802         : local_lreg            { do e <- $1; return (e, (inferCmmHint (CmmReg (CmmLocal e)))) }
803         | STRING local_lreg     {% do h <- parseCmmHint $1;
804                                       return $ do
805                                          e <- $2; return (e,h) }
806
807 local_lreg :: { CmmParse LocalReg }
808         : NAME                  { do e <- lookupName $1;
809                                      return $
810                                        case e of 
811                                         CmmReg (CmmLocal r) -> r
812                                         other -> pprPanic "CmmParse:" (ftext $1 <> text " not a local register") }
813
814 lreg    :: { CmmParse CmmReg }
815         : NAME                  { do e <- lookupName $1;
816                                      return $
817                                        case e of 
818                                         CmmReg r -> r
819                                         other -> pprPanic "CmmParse:" (ftext $1 <> text " not a register") }
820         | GLOBALREG             { return (CmmGlobal $1) }
821
822 maybe_formals :: { Maybe [CmmParse LocalReg] }
823         : {- empty -}           { Nothing }
824         | '(' formals0 ')'      { Just $2 }
825
826 formals0 :: { [CmmParse LocalReg] }
827         : {- empty -}           { [] }
828         | formals               { $1 }
829
830 formals :: { [CmmParse LocalReg] }
831         : formal ','            { [$1] }
832         | formal                { [$1] }
833         | formal ',' formals       { $1 : $3 }
834
835 formal :: { CmmParse LocalReg }
836         : type NAME             { newLocal $1 $2 }
837
838 type    :: { CmmType }
839         : 'bits8'               { b8 }
840         | typenot8              { $1 }
841
842 typenot8 :: { CmmType }
843         : 'bits16'              { b16 }
844         | 'bits32'              { b32 }
845         | 'bits64'              { b64 }
846         | 'bits128'             { b128 }
847         | 'bits256'             { b256 }
848         | 'bits512'             { b512 }
849         | 'float32'             { f32 }
850         | 'float64'             { f64 }
851         | 'gcptr'               {% do dflags <- getDynFlags; return $ gcWord dflags }
852
853 {
854 section :: String -> SectionType
855 section "text"      = Text
856 section "data"      = Data
857 section "rodata"    = ReadOnlyData
858 section "relrodata" = RelocatableReadOnlyData
859 section "bss"       = UninitialisedData
860 section s           = OtherSection s
861
862 mkString :: String -> CmmStatic
863 mkString s = CmmString (map (fromIntegral.ord) s)
864
865 -- |
866 -- Given an info table, decide what the entry convention for the proc
867 -- is.  That is, for an INFO_TABLE_RET we want the return convention,
868 -- otherwise it is a NativeNodeCall.
869 --
870 infoConv :: Maybe CmmInfoTable -> Convention
871 infoConv Nothing = NativeNodeCall
872 infoConv (Just info)
873   | isStackRep (cit_rep info) = NativeReturn
874   | otherwise                 = NativeNodeCall
875
876 -- mkMachOp infers the type of the MachOp from the type of its first
877 -- argument.  We assume that this is correct: for MachOps that don't have
878 -- symmetrical args (e.g. shift ops), the first arg determines the type of
879 -- the op.
880 mkMachOp :: (Width -> MachOp) -> [CmmParse CmmExpr] -> CmmParse CmmExpr
881 mkMachOp fn args = do
882   dflags <- getDynFlags
883   arg_exprs <- sequence args
884   return (CmmMachOp (fn (typeWidth (cmmExprType dflags (head arg_exprs)))) arg_exprs)
885
886 getLit :: CmmExpr -> CmmLit
887 getLit (CmmLit l) = l
888 getLit (CmmMachOp (MO_S_Neg _) [CmmLit (CmmInt i r)])  = CmmInt (negate i) r
889 getLit _ = panic "invalid literal" -- TODO messy failure
890
891 nameToMachOp :: FastString -> PD (Width -> MachOp)
892 nameToMachOp name =
893   case lookupUFM machOps name of
894         Nothing -> fail ("unknown primitive " ++ unpackFS name)
895         Just m  -> return m
896
897 exprOp :: FastString -> [CmmParse CmmExpr] -> PD (CmmParse CmmExpr)
898 exprOp name args_code = do
899   dflags <- getDynFlags
900   case lookupUFM (exprMacros dflags) name of
901      Just f  -> return $ do
902         args <- sequence args_code
903         return (f args)
904      Nothing -> do
905         mo <- nameToMachOp name
906         return $ mkMachOp mo args_code
907
908 exprMacros :: DynFlags -> UniqFM ([CmmExpr] -> CmmExpr)
909 exprMacros dflags = listToUFM [
910   ( fsLit "ENTRY_CODE",   \ [x] -> entryCode dflags x ),
911   ( fsLit "INFO_PTR",     \ [x] -> closureInfoPtr dflags x ),
912   ( fsLit "STD_INFO",     \ [x] -> infoTable dflags x ),
913   ( fsLit "FUN_INFO",     \ [x] -> funInfoTable dflags x ),
914   ( fsLit "GET_ENTRY",    \ [x] -> entryCode dflags (closureInfoPtr dflags x) ),
915   ( fsLit "GET_STD_INFO", \ [x] -> infoTable dflags (closureInfoPtr dflags x) ),
916   ( fsLit "GET_FUN_INFO", \ [x] -> funInfoTable dflags (closureInfoPtr dflags x) ),
917   ( fsLit "INFO_TYPE",    \ [x] -> infoTableClosureType dflags x ),
918   ( fsLit "INFO_PTRS",    \ [x] -> infoTablePtrs dflags x ),
919   ( fsLit "INFO_NPTRS",   \ [x] -> infoTableNonPtrs dflags x )
920   ]
921
922 -- we understand a subset of C-- primitives:
923 machOps = listToUFM $
924         map (\(x, y) -> (mkFastString x, y)) [
925         ( "add",        MO_Add ),
926         ( "sub",        MO_Sub ),
927         ( "eq",         MO_Eq ),
928         ( "ne",         MO_Ne ),
929         ( "mul",        MO_Mul ),
930         ( "neg",        MO_S_Neg ),
931         ( "quot",       MO_S_Quot ),
932         ( "rem",        MO_S_Rem ),
933         ( "divu",       MO_U_Quot ),
934         ( "modu",       MO_U_Rem ),
935
936         ( "ge",         MO_S_Ge ),
937         ( "le",         MO_S_Le ),
938         ( "gt",         MO_S_Gt ),
939         ( "lt",         MO_S_Lt ),
940
941         ( "geu",        MO_U_Ge ),
942         ( "leu",        MO_U_Le ),
943         ( "gtu",        MO_U_Gt ),
944         ( "ltu",        MO_U_Lt ),
945
946         ( "and",        MO_And ),
947         ( "or",         MO_Or ),
948         ( "xor",        MO_Xor ),
949         ( "com",        MO_Not ),
950         ( "shl",        MO_Shl ),
951         ( "shrl",       MO_U_Shr ),
952         ( "shra",       MO_S_Shr ),
953
954         ( "fadd",       MO_F_Add ),
955         ( "fsub",       MO_F_Sub ),
956         ( "fneg",       MO_F_Neg ),
957         ( "fmul",       MO_F_Mul ),
958         ( "fquot",      MO_F_Quot ),
959
960         ( "feq",        MO_F_Eq ),
961         ( "fne",        MO_F_Ne ),
962         ( "fge",        MO_F_Ge ),
963         ( "fle",        MO_F_Le ),
964         ( "fgt",        MO_F_Gt ),
965         ( "flt",        MO_F_Lt ),
966
967         ( "lobits8",  flip MO_UU_Conv W8  ),
968         ( "lobits16", flip MO_UU_Conv W16 ),
969         ( "lobits32", flip MO_UU_Conv W32 ),
970         ( "lobits64", flip MO_UU_Conv W64 ),
971
972         ( "zx16",     flip MO_UU_Conv W16 ),
973         ( "zx32",     flip MO_UU_Conv W32 ),
974         ( "zx64",     flip MO_UU_Conv W64 ),
975
976         ( "sx16",     flip MO_SS_Conv W16 ),
977         ( "sx32",     flip MO_SS_Conv W32 ),
978         ( "sx64",     flip MO_SS_Conv W64 ),
979
980         ( "f2f32",    flip MO_FF_Conv W32 ),  -- TODO; rounding mode
981         ( "f2f64",    flip MO_FF_Conv W64 ),  -- TODO; rounding mode
982         ( "f2i8",     flip MO_FS_Conv W8 ),
983         ( "f2i16",    flip MO_FS_Conv W16 ),
984         ( "f2i32",    flip MO_FS_Conv W32 ),
985         ( "f2i64",    flip MO_FS_Conv W64 ),
986         ( "i2f32",    flip MO_SF_Conv W32 ),
987         ( "i2f64",    flip MO_SF_Conv W64 )
988         ]
989
990 callishMachOps :: UniqFM ([CmmExpr] -> (CallishMachOp, [CmmExpr]))
991 callishMachOps = listToUFM $
992         map (\(x, y) -> (mkFastString x, y)) [
993         ( "write_barrier", (,) MO_WriteBarrier ),
994         ( "memcpy", memcpyLikeTweakArgs MO_Memcpy ),
995         ( "memset", memcpyLikeTweakArgs MO_Memset ),
996         ( "memmove", memcpyLikeTweakArgs MO_Memmove ),
997         ( "memcmp", memcpyLikeTweakArgs MO_Memcmp ),
998
999         ("prefetch0", (,) $ MO_Prefetch_Data 0),
1000         ("prefetch1", (,) $ MO_Prefetch_Data 1),
1001         ("prefetch2", (,) $ MO_Prefetch_Data 2),
1002         ("prefetch3", (,) $ MO_Prefetch_Data 3),
1003
1004         ( "popcnt8",  (,) $ MO_PopCnt W8  ),
1005         ( "popcnt16", (,) $ MO_PopCnt W16 ),
1006         ( "popcnt32", (,) $ MO_PopCnt W32 ),
1007         ( "popcnt64", (,) $ MO_PopCnt W64 ),
1008
1009         ( "cmpxchg8",  (,) $ MO_Cmpxchg W8  ),
1010         ( "cmpxchg16", (,) $ MO_Cmpxchg W16 ),
1011         ( "cmpxchg32", (,) $ MO_Cmpxchg W32 ),
1012         ( "cmpxchg64", (,) $ MO_Cmpxchg W64 )
1013
1014         -- ToDo: the rest, maybe
1015         -- edit: which rest?
1016         -- also: how do we tell CMM Lint how to type check callish macops?
1017     ]
1018   where
1019     memcpyLikeTweakArgs :: (Int -> CallishMachOp) -> [CmmExpr] -> (CallishMachOp, [CmmExpr])
1020     memcpyLikeTweakArgs op [] = pgmError "memcpy-like function requires at least one argument"
1021     memcpyLikeTweakArgs op args@(_:_) =
1022         (op align, args')
1023       where
1024         args' = init args
1025         align = case last args of
1026           CmmLit (CmmInt alignInteger _) -> fromInteger alignInteger
1027           e -> pprPgmError "Non-constant alignment in memcpy-like function:" (ppr e)
1028         -- The alignment of memcpy-ish operations must be a
1029         -- compile-time constant. We verify this here, passing it around
1030         -- in the MO_* constructor. In order to do this, however, we
1031         -- must intercept the arguments in primCall.
1032
1033 parseSafety :: String -> PD Safety
1034 parseSafety "safe"   = return PlaySafe
1035 parseSafety "unsafe" = return PlayRisky
1036 parseSafety "interruptible" = return PlayInterruptible
1037 parseSafety str      = fail ("unrecognised safety: " ++ str)
1038
1039 parseCmmHint :: String -> PD ForeignHint
1040 parseCmmHint "ptr"    = return AddrHint
1041 parseCmmHint "signed" = return SignedHint
1042 parseCmmHint str      = fail ("unrecognised hint: " ++ str)
1043
1044 -- labels are always pointers, so we might as well infer the hint
1045 inferCmmHint :: CmmExpr -> ForeignHint
1046 inferCmmHint (CmmLit (CmmLabel _)) = AddrHint
1047 inferCmmHint (CmmReg (CmmGlobal g)) | isPtrGlobalReg g = AddrHint
1048 inferCmmHint _ = NoHint
1049
1050 isPtrGlobalReg Sp                    = True
1051 isPtrGlobalReg SpLim                 = True
1052 isPtrGlobalReg Hp                    = True
1053 isPtrGlobalReg HpLim                 = True
1054 isPtrGlobalReg CCCS                  = True
1055 isPtrGlobalReg CurrentTSO            = True
1056 isPtrGlobalReg CurrentNursery        = True
1057 isPtrGlobalReg (VanillaReg _ VGcPtr) = True
1058 isPtrGlobalReg _                     = False
1059
1060 happyError :: PD a
1061 happyError = PD $ \_ s -> unP srcParseFail s
1062
1063 -- -----------------------------------------------------------------------------
1064 -- Statement-level macros
1065
1066 stmtMacro :: FastString -> [CmmParse CmmExpr] -> PD (CmmParse ())
1067 stmtMacro fun args_code = do
1068   case lookupUFM stmtMacros fun of
1069     Nothing -> fail ("unknown macro: " ++ unpackFS fun)
1070     Just fcode -> return $ do
1071         args <- sequence args_code
1072         code (fcode args)
1073
1074 stmtMacros :: UniqFM ([CmmExpr] -> FCode ())
1075 stmtMacros = listToUFM [
1076   ( fsLit "CCS_ALLOC",             \[words,ccs]  -> profAlloc words ccs ),
1077   ( fsLit "ENTER_CCS_THUNK",       \[e] -> enterCostCentreThunk e ),
1078
1079   ( fsLit "CLOSE_NURSERY",         \[]  -> emitCloseNursery ),
1080   ( fsLit "OPEN_NURSERY",          \[]  -> emitOpenNursery ),
1081
1082   -- completely generic heap and stack checks, for use in high-level cmm.
1083   ( fsLit "HP_CHK_GEN",            \[bytes] ->
1084                                       heapStackCheckGen Nothing (Just bytes) ),
1085   ( fsLit "STK_CHK_GEN",           \[] ->
1086                                       heapStackCheckGen (Just (CmmLit CmmHighStackMark)) Nothing ),
1087
1088   -- A stack check for a fixed amount of stack.  Sounds a bit strange, but
1089   -- we use the stack for a bit of temporary storage in a couple of primops
1090   ( fsLit "STK_CHK_GEN_N",         \[bytes] ->
1091                                       heapStackCheckGen (Just bytes) Nothing ),
1092
1093   -- A stack check on entry to a thunk, where the argument is the thunk pointer.
1094   ( fsLit "STK_CHK_NP"   ,         \[node] -> entryHeapCheck' False node 0 [] (return ())),
1095
1096   ( fsLit "LOAD_THREAD_STATE",     \[] -> emitLoadThreadState ),
1097   ( fsLit "SAVE_THREAD_STATE",     \[] -> emitSaveThreadState ),
1098
1099   ( fsLit "LDV_ENTER",             \[e] -> ldvEnter e ),
1100   ( fsLit "LDV_RECORD_CREATE",     \[e] -> ldvRecordCreate e ),
1101
1102   ( fsLit "PUSH_UPD_FRAME",        \[sp,e] -> emitPushUpdateFrame sp e ),
1103   ( fsLit "SET_HDR",               \[ptr,info,ccs] ->
1104                                         emitSetDynHdr ptr info ccs ),
1105   ( fsLit "TICK_ALLOC_PRIM",       \[hdr,goods,slop] ->
1106                                         tickyAllocPrim hdr goods slop ),
1107   ( fsLit "TICK_ALLOC_PAP",        \[goods,slop] ->
1108                                         tickyAllocPAP goods slop ),
1109   ( fsLit "TICK_ALLOC_UP_THK",     \[goods,slop] ->
1110                                         tickyAllocThunk goods slop ),
1111   ( fsLit "UPD_BH_UPDATABLE",      \[reg] -> emitBlackHoleCode reg )
1112  ]
1113
1114 emitPushUpdateFrame :: CmmExpr -> CmmExpr -> FCode ()
1115 emitPushUpdateFrame sp e = do
1116   dflags <- getDynFlags
1117   emitUpdateFrame dflags sp mkUpdInfoLabel e
1118
1119 pushStackFrame :: [CmmParse CmmExpr] -> CmmParse () -> CmmParse ()
1120 pushStackFrame fields body = do
1121   dflags <- getDynFlags
1122   exprs <- sequence fields
1123   updfr_off <- getUpdFrameOff
1124   let (new_updfr_off, _, g) = copyOutOflow dflags NativeReturn Ret Old
1125                                            [] updfr_off exprs
1126   emit g
1127   withUpdFrameOff new_updfr_off body
1128
1129 reserveStackFrame
1130   :: CmmParse CmmExpr
1131   -> CmmParse CmmReg
1132   -> CmmParse ()
1133   -> CmmParse ()
1134 reserveStackFrame psize preg body = do
1135   dflags <- getDynFlags
1136   old_updfr_off <- getUpdFrameOff
1137   reg <- preg
1138   esize <- psize
1139   let size = case constantFoldExpr dflags esize of
1140                CmmLit (CmmInt n _) -> n
1141                _other -> pprPanic "CmmParse: not a compile-time integer: "
1142                             (ppr esize)
1143   let frame = old_updfr_off + wORD_SIZE dflags * fromIntegral size
1144   emitAssign reg (CmmStackSlot Old frame)
1145   withUpdFrameOff frame body
1146
1147 profilingInfo dflags desc_str ty_str
1148   = if not (gopt Opt_SccProfilingOn dflags)
1149     then NoProfilingInfo
1150     else ProfilingInfo (stringToWord8s desc_str)
1151                        (stringToWord8s ty_str)
1152
1153 staticClosure :: UnitId -> FastString -> FastString -> [CmmLit] -> CmmParse ()
1154 staticClosure pkg cl_label info payload
1155   = do dflags <- getDynFlags
1156        let lits = mkStaticClosure dflags (mkCmmInfoLabel pkg info) dontCareCCS payload [] [] []
1157        code $ emitDataLits (mkCmmDataLabel pkg cl_label) lits
1158
1159 foreignCall
1160         :: String
1161         -> [CmmParse (LocalReg, ForeignHint)]
1162         -> CmmParse CmmExpr
1163         -> [CmmParse (CmmExpr, ForeignHint)]
1164         -> Safety
1165         -> CmmReturnInfo
1166         -> PD (CmmParse ())
1167 foreignCall conv_string results_code expr_code args_code safety ret
1168   = do  conv <- case conv_string of
1169           "C" -> return CCallConv
1170           "stdcall" -> return StdCallConv
1171           _ -> fail ("unknown calling convention: " ++ conv_string)
1172         return $ do
1173           dflags <- getDynFlags
1174           results <- sequence results_code
1175           expr <- expr_code
1176           args <- sequence args_code
1177           let
1178                   expr' = adjCallTarget dflags conv expr args
1179                   (arg_exprs, arg_hints) = unzip args
1180                   (res_regs,  res_hints) = unzip results
1181                   fc = ForeignConvention conv arg_hints res_hints ret
1182                   target = ForeignTarget expr' fc
1183           _ <- code $ emitForeignCall safety res_regs target arg_exprs
1184           return ()
1185
1186
1187 doReturn :: [CmmParse CmmExpr] -> CmmParse ()
1188 doReturn exprs_code = do
1189   dflags <- getDynFlags
1190   exprs <- sequence exprs_code
1191   updfr_off <- getUpdFrameOff
1192   emit (mkReturnSimple dflags exprs updfr_off)
1193
1194 mkReturnSimple  :: DynFlags -> [CmmActual] -> UpdFrameOffset -> CmmAGraph
1195 mkReturnSimple dflags actuals updfr_off =
1196   mkReturn dflags e actuals updfr_off
1197   where e = entryCode dflags (CmmLoad (CmmStackSlot Old updfr_off)
1198                              (gcWord dflags))
1199
1200 doRawJump :: CmmParse CmmExpr -> [GlobalReg] -> CmmParse ()
1201 doRawJump expr_code vols = do
1202   dflags <- getDynFlags
1203   expr <- expr_code
1204   updfr_off <- getUpdFrameOff
1205   emit (mkRawJump dflags expr updfr_off vols)
1206
1207 doJumpWithStack :: CmmParse CmmExpr -> [CmmParse CmmExpr]
1208                 -> [CmmParse CmmExpr] -> CmmParse ()
1209 doJumpWithStack expr_code stk_code args_code = do
1210   dflags <- getDynFlags
1211   expr <- expr_code
1212   stk_args <- sequence stk_code
1213   args <- sequence args_code
1214   updfr_off <- getUpdFrameOff
1215   emit (mkJumpExtra dflags NativeNodeCall expr args updfr_off stk_args)
1216
1217 doCall :: CmmParse CmmExpr -> [CmmParse LocalReg] -> [CmmParse CmmExpr]
1218        -> CmmParse ()
1219 doCall expr_code res_code args_code = do
1220   dflags <- getDynFlags
1221   expr <- expr_code
1222   args <- sequence args_code
1223   ress <- sequence res_code
1224   updfr_off <- getUpdFrameOff
1225   c <- code $ mkCall expr (NativeNodeCall,NativeReturn) ress args updfr_off []
1226   emit c
1227
1228 adjCallTarget :: DynFlags -> CCallConv -> CmmExpr -> [(CmmExpr, ForeignHint) ]
1229               -> CmmExpr
1230 -- On Windows, we have to add the '@N' suffix to the label when making
1231 -- a call with the stdcall calling convention.
1232 adjCallTarget dflags StdCallConv (CmmLit (CmmLabel lbl)) args
1233  | platformOS (targetPlatform dflags) == OSMinGW32
1234   = CmmLit (CmmLabel (addLabelSize lbl (sum (map size args))))
1235   where size (e, _) = max (wORD_SIZE dflags) (widthInBytes (typeWidth (cmmExprType dflags e)))
1236                  -- c.f. CgForeignCall.emitForeignCall
1237 adjCallTarget _ _ expr _
1238   = expr
1239
1240 primCall
1241         :: [CmmParse (CmmFormal, ForeignHint)]
1242         -> FastString
1243         -> [CmmParse CmmExpr]
1244         -> PD (CmmParse ())
1245 primCall results_code name args_code
1246   = case lookupUFM callishMachOps name of
1247         Nothing -> fail ("unknown primitive " ++ unpackFS name)
1248         Just f  -> return $ do
1249                 results <- sequence results_code
1250                 args <- sequence args_code
1251                 let (p, args') = f args
1252                 code (emitPrimCall (map fst results) p args')
1253
1254 doStore :: CmmType -> CmmParse CmmExpr  -> CmmParse CmmExpr -> CmmParse ()
1255 doStore rep addr_code val_code
1256   = do dflags <- getDynFlags
1257        addr <- addr_code
1258        val <- val_code
1259         -- if the specified store type does not match the type of the expr
1260         -- on the rhs, then we insert a coercion that will cause the type
1261         -- mismatch to be flagged by cmm-lint.  If we don't do this, then
1262         -- the store will happen at the wrong type, and the error will not
1263         -- be noticed.
1264        let val_width = typeWidth (cmmExprType dflags val)
1265            rep_width = typeWidth rep
1266        let coerce_val
1267                 | val_width /= rep_width = CmmMachOp (MO_UU_Conv val_width rep_width) [val]
1268                 | otherwise              = val
1269        emitStore addr coerce_val
1270
1271 -- -----------------------------------------------------------------------------
1272 -- If-then-else and boolean expressions
1273
1274 data BoolExpr
1275   = BoolExpr `BoolAnd` BoolExpr
1276   | BoolExpr `BoolOr`  BoolExpr
1277   | BoolNot BoolExpr
1278   | BoolTest CmmExpr
1279
1280 -- ToDo: smart constructors which simplify the boolean expression.
1281
1282 cmmIfThenElse cond then_part else_part = do
1283      then_id <- newBlockId
1284      join_id <- newBlockId
1285      c <- cond
1286      emitCond c then_id
1287      else_part
1288      emit (mkBranch join_id)
1289      emitLabel then_id
1290      then_part
1291      -- fall through to join
1292      emitLabel join_id
1293
1294 cmmRawIf cond then_id = do
1295     c <- cond
1296     emitCond c then_id
1297
1298 -- 'emitCond cond true_id'  emits code to test whether the cond is true,
1299 -- branching to true_id if so, and falling through otherwise.
1300 emitCond (BoolTest e) then_id = do
1301   else_id <- newBlockId
1302   emit (mkCbranch e then_id else_id Nothing)
1303   emitLabel else_id
1304 emitCond (BoolNot (BoolTest (CmmMachOp op args))) then_id
1305   | Just op' <- maybeInvertComparison op
1306   = emitCond (BoolTest (CmmMachOp op' args)) then_id
1307 emitCond (BoolNot e) then_id = do
1308   else_id <- newBlockId
1309   emitCond e else_id
1310   emit (mkBranch then_id)
1311   emitLabel else_id
1312 emitCond (e1 `BoolOr` e2) then_id = do
1313   emitCond e1 then_id
1314   emitCond e2 then_id
1315 emitCond (e1 `BoolAnd` e2) then_id = do
1316         -- we'd like to invert one of the conditionals here to avoid an
1317         -- extra branch instruction, but we can't use maybeInvertComparison
1318         -- here because we can't look too closely at the expression since
1319         -- we're in a loop.
1320   and_id <- newBlockId
1321   else_id <- newBlockId
1322   emitCond e1 and_id
1323   emit (mkBranch else_id)
1324   emitLabel and_id
1325   emitCond e2 then_id
1326   emitLabel else_id
1327
1328 -- -----------------------------------------------------------------------------
1329 -- Source code notes
1330
1331 -- | Generate a source note spanning from "a" to "b" (inclusive), then
1332 -- proceed with parsing. This allows debugging tools to reason about
1333 -- locations in Cmm code.
1334 withSourceNote :: Located a -> Located b -> CmmParse c -> CmmParse c
1335 withSourceNote a b parse = do
1336   name <- getName
1337   case combineSrcSpans (getLoc a) (getLoc b) of
1338     RealSrcSpan span -> code (emitTick (SourceNote span name)) >> parse
1339     _other           -> parse
1340
1341 -- -----------------------------------------------------------------------------
1342 -- Table jumps
1343
1344 -- We use a simplified form of C-- switch statements for now.  A
1345 -- switch statement always compiles to a table jump.  Each arm can
1346 -- specify a list of values (not ranges), and there can be a single
1347 -- default branch.  The range of the table is given either by the
1348 -- optional range on the switch (eg. switch [0..7] {...}), or by
1349 -- the minimum/maximum values from the branches.
1350
1351 doSwitch :: Maybe (Integer,Integer)
1352          -> CmmParse CmmExpr
1353          -> [([Integer],Either BlockId (CmmParse ()))]
1354          -> Maybe (CmmParse ()) -> CmmParse ()
1355 doSwitch mb_range scrut arms deflt
1356    = do
1357         -- Compile code for the default branch
1358         dflt_entry <- 
1359                 case deflt of
1360                   Nothing -> return Nothing
1361                   Just e  -> do b <- forkLabelledCode e; return (Just b)
1362
1363         -- Compile each case branch
1364         table_entries <- mapM emitArm arms
1365         let table = M.fromList (concat table_entries)
1366
1367         dflags <- getDynFlags
1368         let range = fromMaybe (0, tARGET_MAX_WORD dflags) mb_range
1369
1370         expr <- scrut
1371         -- ToDo: check for out of range and jump to default if necessary
1372         emit $ mkSwitch expr (mkSwitchTargets False range dflt_entry table)
1373    where
1374         emitArm :: ([Integer],Either BlockId (CmmParse ())) -> CmmParse [(Integer,BlockId)]
1375         emitArm (ints,Left blockid) = return [ (i,blockid) | i <- ints ]
1376         emitArm (ints,Right code) = do
1377            blockid <- forkLabelledCode code
1378            return [ (i,blockid) | i <- ints ]
1379
1380 forkLabelledCode :: CmmParse () -> CmmParse BlockId
1381 forkLabelledCode p = do
1382   (_,ag) <- getCodeScoped p
1383   l <- newBlockId
1384   emitOutOfLine l ag
1385   return l
1386
1387 -- -----------------------------------------------------------------------------
1388 -- Putting it all together
1389
1390 -- The initial environment: we define some constants that the compiler
1391 -- knows about here.
1392 initEnv :: DynFlags -> Env
1393 initEnv dflags = listToUFM [
1394   ( fsLit "SIZEOF_StgHeader",
1395     VarN (CmmLit (CmmInt (fromIntegral (fixedHdrSize dflags)) (wordWidth dflags)) )),
1396   ( fsLit "SIZEOF_StgInfoTable",
1397     VarN (CmmLit (CmmInt (fromIntegral (stdInfoTableSizeB dflags)) (wordWidth dflags)) ))
1398   ]
1399
1400 parseCmmFile :: DynFlags -> FilePath -> IO (Messages, Maybe CmmGroup)
1401 parseCmmFile dflags filename = withTiming (pure dflags) (text "ParseCmm"<+>brackets (text filename)) (\_ -> ()) $ do
1402   buf <- hGetStringBuffer filename
1403   let
1404         init_loc = mkRealSrcLoc (mkFastString filename) 1 1
1405         init_state = (mkPState dflags buf init_loc) { lex_state = [0] }
1406                 -- reset the lex_state: the Lexer monad leaves some stuff
1407                 -- in there we don't want.
1408   case unPD cmmParse dflags init_state of
1409     PFailed warnFn span err -> do
1410         let msg = mkPlainErrMsg dflags span err
1411             errMsgs = (emptyBag, unitBag msg)
1412             warnMsgs = warnFn dflags
1413         return (unionMessages warnMsgs errMsgs, Nothing)
1414     POk pst code -> do
1415         st <- initC
1416         let fcode = getCmm $ unEC code "global" (initEnv dflags) [] >> return ()
1417             (cmm,_) = runC dflags no_module st fcode
1418         let ms = getMessages pst dflags
1419         if (errorsFound dflags ms)
1420          then return (ms, Nothing)
1421          else return (ms, Just cmm)
1422   where
1423         no_module = panic "parseCmmFile: no module"
1424 }