1bdf0e6a7e93a825a2212307c4b2e23eb24ebf1c
[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         'True'  { L _ (CmmT_True ) }
303         'False' { L _ (CmmT_False) }
304         'likely'{ L _ (CmmT_likely)}
305
306         'CLOSURE'       { L _ (CmmT_CLOSURE) }
307         'INFO_TABLE'    { L _ (CmmT_INFO_TABLE) }
308         'INFO_TABLE_RET'{ L _ (CmmT_INFO_TABLE_RET) }
309         'INFO_TABLE_FUN'{ L _ (CmmT_INFO_TABLE_FUN) }
310         'INFO_TABLE_CONSTR'{ L _ (CmmT_INFO_TABLE_CONSTR) }
311         'INFO_TABLE_SELECTOR'{ L _ (CmmT_INFO_TABLE_SELECTOR) }
312         'else'          { L _ (CmmT_else) }
313         'export'        { L _ (CmmT_export) }
314         'section'       { L _ (CmmT_section) }
315         'goto'          { L _ (CmmT_goto) }
316         'if'            { L _ (CmmT_if) }
317         'call'          { L _ (CmmT_call) }
318         'jump'          { L _ (CmmT_jump) }
319         'foreign'       { L _ (CmmT_foreign) }
320         'never'         { L _ (CmmT_never) }
321         'prim'          { L _ (CmmT_prim) }
322         'reserve'       { L _ (CmmT_reserve) }
323         'return'        { L _ (CmmT_return) }
324         'returns'       { L _ (CmmT_returns) }
325         'import'        { L _ (CmmT_import) }
326         'switch'        { L _ (CmmT_switch) }
327         'case'          { L _ (CmmT_case) }
328         'default'       { L _ (CmmT_default) }
329         'push'          { L _ (CmmT_push) }
330         'unwind'        { L _ (CmmT_unwind) }
331         'bits8'         { L _ (CmmT_bits8) }
332         'bits16'        { L _ (CmmT_bits16) }
333         'bits32'        { L _ (CmmT_bits32) }
334         'bits64'        { L _ (CmmT_bits64) }
335         'bits128'       { L _ (CmmT_bits128) }
336         'bits256'       { L _ (CmmT_bits256) }
337         'bits512'       { L _ (CmmT_bits512) }
338         'float32'       { L _ (CmmT_float32) }
339         'float64'       { L _ (CmmT_float64) }
340         'gcptr'         { L _ (CmmT_gcptr) }
341
342         GLOBALREG       { L _ (CmmT_GlobalReg   $$) }
343         NAME            { L _ (CmmT_Name        $$) }
344         STRING          { L _ (CmmT_String      $$) }
345         INT             { L _ (CmmT_Int         $$) }
346         FLOAT           { L _ (CmmT_Float       $$) }
347
348 %monad { PD } { >>= } { return }
349 %lexer { cmmlex } { L _ CmmT_EOF }
350 %name cmmParse cmm
351 %tokentype { Located CmmToken }
352
353 -- C-- operator precedences, taken from the C-- spec
354 %right '||'     -- non-std extension, called %disjoin in C--
355 %right '&&'     -- non-std extension, called %conjoin in C--
356 %right '!'
357 %nonassoc '>=' '>' '<=' '<' '!=' '=='
358 %left '|'
359 %left '^'
360 %left '&'
361 %left '>>' '<<'
362 %left '-' '+'
363 %left '/' '*' '%'
364 %right '~'
365
366 %%
367
368 cmm     :: { CmmParse () }
369         : {- empty -}                   { return () }
370         | cmmtop cmm                    { do $1; $2 }
371
372 cmmtop  :: { CmmParse () }
373         : cmmproc                       { $1 }
374         | cmmdata                       { $1 }
375         | decl                          { $1 } 
376         | 'CLOSURE' '(' NAME ',' NAME lits ')' ';'  
377                 {% liftP . withThisPackage $ \pkg ->
378                    do lits <- sequence $6;
379                       staticClosure pkg $3 $5 (map getLit lits) }
380
381 -- The only static closures in the RTS are dummy closures like
382 -- stg_END_TSO_QUEUE_closure and stg_dummy_ret.  We don't need
383 -- to provide the full generality of static closures here.
384 -- In particular:
385 --      * CCS can always be CCS_DONT_CARE
386 --      * closure is always extern
387 --      * payload is always empty
388 --      * we can derive closure and info table labels from a single NAME
389
390 cmmdata :: { CmmParse () }
391         : 'section' STRING '{' data_label statics '}' 
392                 { do lbl <- $4;
393                      ss <- sequence $5;
394                      code (emitDecl (CmmData (Section (section $2) lbl) (Statics lbl $ concat ss))) }
395
396 data_label :: { CmmParse CLabel }
397     : NAME ':'  
398                 {% liftP . withThisPackage $ \pkg ->
399                    return (mkCmmDataLabel pkg $1) }
400
401 statics :: { [CmmParse [CmmStatic]] }
402         : {- empty -}                   { [] }
403         | static statics                { $1 : $2 }
404     
405 -- Strings aren't used much in the RTS HC code, so it doesn't seem
406 -- worth allowing inline strings.  C-- doesn't allow them anyway.
407 static  :: { CmmParse [CmmStatic] }
408         : type expr ';' { do e <- $2;
409                              return [CmmStaticLit (getLit e)] }
410         | type ';'                      { return [CmmUninitialised
411                                                         (widthInBytes (typeWidth $1))] }
412         | 'bits8' '[' ']' STRING ';'    { return [mkString $4] }
413         | 'bits8' '[' INT ']' ';'       { return [CmmUninitialised 
414                                                         (fromIntegral $3)] }
415         | typenot8 '[' INT ']' ';'      { return [CmmUninitialised 
416                                                 (widthInBytes (typeWidth $1) * 
417                                                         fromIntegral $3)] }
418         | 'CLOSURE' '(' NAME lits ')'
419                 { do { lits <- sequence $4
420                 ; dflags <- getDynFlags
421                      ; return $ map CmmStaticLit $
422                         mkStaticClosure dflags (mkForeignLabel $3 Nothing ForeignLabelInExternalPackage IsData)
423                          -- mkForeignLabel because these are only used
424                          -- for CHARLIKE and INTLIKE closures in the RTS.
425                         dontCareCCS (map getLit lits) [] [] [] } }
426         -- arrays of closures required for the CHARLIKE & INTLIKE arrays
427
428 lits    :: { [CmmParse CmmExpr] }
429         : {- empty -}           { [] }
430         | ',' expr lits         { $2 : $3 }
431
432 cmmproc :: { CmmParse () }
433         : info maybe_conv maybe_formals maybe_body
434                 { do ((entry_ret_label, info, stk_formals, formals), agraph) <-
435                        getCodeScoped $ loopDecls $ do {
436                          (entry_ret_label, info, stk_formals) <- $1;
437                          dflags <- getDynFlags;
438                          formals <- sequence (fromMaybe [] $3);
439                          withName (showSDoc dflags (ppr entry_ret_label))
440                            $4;
441                          return (entry_ret_label, info, stk_formals, formals) }
442                      let do_layout = isJust $3
443                      code (emitProcWithStackFrame $2 info
444                                 entry_ret_label stk_formals formals agraph
445                                 do_layout ) }
446
447 maybe_conv :: { Convention }
448            : {- empty -}        { NativeNodeCall }
449            | 'return'           { NativeReturn }
450
451 maybe_body :: { CmmParse () }
452            : ';'                { return () }
453            | '{' body '}'       { withSourceNote $1 $3 $2 }
454
455 info    :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }
456         : NAME
457                 {% liftP . withThisPackage $ \pkg ->
458                    do   newFunctionName $1 pkg
459                         return (mkCmmCodeLabel pkg $1, Nothing, []) }
460
461
462         | 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
463                 -- ptrs, nptrs, closure type, description, type
464                 {% liftP . withThisPackage $ \pkg ->
465                    do dflags <- getDynFlags
466                       let prof = profilingInfo dflags $11 $13
467                           rep  = mkRTSRep (fromIntegral $9) $
468                                    mkHeapRep dflags False (fromIntegral $5)
469                                                    (fromIntegral $7) Thunk
470                               -- not really Thunk, but that makes the info table
471                               -- we want.
472                       return (mkCmmEntryLabel pkg $3,
473                               Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
474                                            , cit_rep = rep
475                                            , cit_prof = prof, cit_srt = Nothing },
476                               []) }
477         
478         | 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ')'
479                 -- ptrs, nptrs, closure type, description, type, fun type
480                 {% liftP . withThisPackage $ \pkg ->
481                    do dflags <- getDynFlags
482                       let prof = profilingInfo dflags $11 $13
483                           ty   = Fun 0 (ArgSpec (fromIntegral $15))
484                                 -- Arity zero, arg_type $15
485                           rep = mkRTSRep (fromIntegral $9) $
486                                     mkHeapRep dflags False (fromIntegral $5)
487                                                     (fromIntegral $7) ty
488                       return (mkCmmEntryLabel pkg $3,
489                               Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
490                                            , cit_rep = rep
491                                            , cit_prof = prof, cit_srt = Nothing },
492                               []) }
493                 -- we leave most of the fields zero here.  This is only used
494                 -- to generate the BCO info table in the RTS at the moment.
495
496         | 'INFO_TABLE_CONSTR' '(' NAME ',' INT ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
497                 -- ptrs, nptrs, tag, closure type, description, type
498                 {% liftP . withThisPackage $ \pkg ->
499                    do dflags <- getDynFlags
500                       let prof = profilingInfo dflags $13 $15
501                           ty  = Constr (fromIntegral $9)  -- Tag
502                                        (stringToWord8s $13)
503                           rep = mkRTSRep (fromIntegral $11) $
504                                   mkHeapRep dflags False (fromIntegral $5)
505                                                   (fromIntegral $7) ty
506                       return (mkCmmEntryLabel pkg $3,
507                               Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
508                                            , cit_rep = rep
509                                            , cit_prof = prof, cit_srt = Nothing },
510                               []) }
511
512                      -- If profiling is on, this string gets duplicated,
513                      -- but that's the way the old code did it we can fix it some other time.
514         
515         | 'INFO_TABLE_SELECTOR' '(' NAME ',' INT ',' INT ',' STRING ',' STRING ')'
516                 -- selector, closure type, description, type
517                 {% liftP . withThisPackage $ \pkg ->
518                    do dflags <- getDynFlags
519                       let prof = profilingInfo dflags $9 $11
520                           ty  = ThunkSelector (fromIntegral $5)
521                           rep = mkRTSRep (fromIntegral $7) $
522                                    mkHeapRep dflags False 0 0 ty
523                       return (mkCmmEntryLabel pkg $3,
524                               Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
525                                            , cit_rep = rep
526                                            , cit_prof = prof, cit_srt = Nothing },
527                               []) }
528
529         | 'INFO_TABLE_RET' '(' NAME ',' INT ')'
530                 -- closure type (no live regs)
531                 {% liftP . withThisPackage $ \pkg ->
532                    do let prof = NoProfilingInfo
533                           rep  = mkRTSRep (fromIntegral $5) $ mkStackRep []
534                       return (mkCmmRetLabel pkg $3,
535                               Just $ CmmInfoTable { cit_lbl = mkCmmRetInfoLabel pkg $3
536                                            , cit_rep = rep
537                                            , cit_prof = prof, cit_srt = Nothing },
538                               []) }
539
540         | 'INFO_TABLE_RET' '(' NAME ',' INT ',' formals0 ')'
541                 -- closure type, live regs
542                 {% liftP . withThisPackage $ \pkg ->
543                    do dflags <- getDynFlags
544                       live <- sequence $7
545                       let prof = NoProfilingInfo
546                           -- drop one for the info pointer
547                           bitmap = mkLiveness dflags (map Just (drop 1 live))
548                           rep  = mkRTSRep (fromIntegral $5) $ mkStackRep bitmap
549                       return (mkCmmRetLabel pkg $3,
550                               Just $ CmmInfoTable { cit_lbl = mkCmmRetInfoLabel pkg $3
551                                            , cit_rep = rep
552                                            , cit_prof = prof, cit_srt = Nothing },
553                               live) }
554
555 body    :: { CmmParse () }
556         : {- empty -}                   { return () }
557         | decl body                     { do $1; $2 }
558         | stmt body                     { do $1; $2 }
559
560 decl    :: { CmmParse () }
561         : type names ';'                { mapM_ (newLocal $1) $2 }
562         | 'import' importNames ';'      { mapM_ newImport $2 }
563         | 'export' names ';'            { return () }  -- ignore exports
564
565
566 -- an imported function name, with optional packageId
567 importNames
568         :: { [(FastString, CLabel)] }
569         : importName                    { [$1] }
570         | importName ',' importNames    { $1 : $3 }
571
572 importName
573         :: { (FastString,  CLabel) }
574
575         -- A label imported without an explicit packageId.
576         --      These are taken to come frome some foreign, unnamed package.
577         : NAME  
578         { ($1, mkForeignLabel $1 Nothing ForeignLabelInExternalPackage IsFunction) }
579
580         -- as previous 'NAME', but 'IsData'
581         | 'CLOSURE' NAME
582         { ($2, mkForeignLabel $2 Nothing ForeignLabelInExternalPackage IsData) }
583
584         -- A label imported with an explicit packageId.
585         | STRING NAME
586         { ($2, mkCmmCodeLabel (fsToUnitId (mkFastString $1)) $2) }
587         
588         
589 names   :: { [FastString] }
590         : NAME                          { [$1] }
591         | NAME ',' names                { $1 : $3 }
592
593 stmt    :: { CmmParse () }
594         : ';'                                   { return () }
595
596         | NAME ':'
597                 { do l <- newLabel $1; emitLabel l }
598
599
600
601         | lreg '=' expr ';'
602                 { do reg <- $1; e <- $3; withSourceNote $2 $4 (emitAssign reg e) }
603         | type '[' expr ']' '=' expr ';'
604                 { withSourceNote $2 $7 (doStore $1 $3 $6) }
605
606         -- Gah! We really want to say "foreign_results" but that causes
607         -- a shift/reduce conflict with assignment.  We either
608         -- we expand out the no-result and single result cases or
609         -- we tweak the syntax to avoid the conflict.  The later
610         -- option is taken here because the other way would require
611         -- multiple levels of expanding and get unwieldy.
612         | foreign_results 'foreign' STRING foreignLabel '(' cmm_hint_exprs0 ')' safety opt_never_returns ';'
613                 {% foreignCall $3 $1 $4 $6 $8 $9 }
614         | foreign_results 'prim' '%' NAME '(' exprs0 ')' ';'
615                 {% primCall $1 $4 $6 }
616         -- stmt-level macros, stealing syntax from ordinary C-- function calls.
617         -- Perhaps we ought to use the %%-form?
618         | NAME '(' exprs0 ')' ';'
619                 {% stmtMacro $1 $3  }
620         | 'switch' maybe_range expr '{' arms default '}'
621                 { do as <- sequence $5; doSwitch $2 $3 as $6 }
622         | 'goto' NAME ';'
623                 { do l <- lookupLabel $2; emit (mkBranch l) }
624         | 'return' '(' exprs0 ')' ';'
625                 { doReturn $3 }
626         | 'jump' expr vols ';'
627                 { doRawJump $2 $3 }
628         | 'jump' expr '(' exprs0 ')' ';'
629                 { doJumpWithStack $2 [] $4 }
630         | 'jump' expr '(' exprs0 ')' '(' exprs0 ')' ';'
631                 { doJumpWithStack $2 $4 $7 }
632         | 'call' expr '(' exprs0 ')' ';'
633                 { doCall $2 [] $4 }
634         | '(' formals ')' '=' 'call' expr '(' exprs0 ')' ';'
635                 { doCall $6 $2 $8 }
636         | 'if' bool_expr cond_likely 'goto' NAME
637                 { do l <- lookupLabel $5; cmmRawIf $2 l $3 }
638         | 'if' bool_expr cond_likely '{' body '}' else
639                 { cmmIfThenElse $2 (withSourceNote $4 $6 $5) $7 $3 }
640         | 'push' '(' exprs0 ')' maybe_body
641                 { pushStackFrame $3 $5 }
642         | 'reserve' expr '=' lreg maybe_body
643                 { reserveStackFrame $2 $4 $5 }
644         | 'unwind' unwind_regs ';'
645                 { $2 >>= code . emitUnwind }
646
647 unwind_regs
648         :: { CmmParse [(GlobalReg, Maybe CmmExpr)] }
649         : GLOBALREG '=' expr_or_unknown ',' unwind_regs
650                 { do e <- $3; rest <- $5; return (($1, e) : rest) }
651         | GLOBALREG '=' expr_or_unknown
652                 { do e <- $3; return [($1, e)] }
653
654 -- | Used by unwind to indicate unknown unwinding values.
655 expr_or_unknown
656         :: { CmmParse (Maybe CmmExpr) }
657         : 'return'
658                 { do return Nothing }
659         | expr
660                 { do e <- $1; return (Just e) }
661
662 foreignLabel     :: { CmmParse CmmExpr }
663         : NAME                          { return (CmmLit (CmmLabel (mkForeignLabel $1 Nothing ForeignLabelInThisPackage IsFunction))) }
664
665 opt_never_returns :: { CmmReturnInfo }
666         :                               { CmmMayReturn }
667         | 'never' 'returns'             { CmmNeverReturns }
668
669 bool_expr :: { CmmParse BoolExpr }
670         : bool_op                       { $1 }
671         | expr                          { do e <- $1; return (BoolTest e) }
672
673 bool_op :: { CmmParse BoolExpr }
674         : bool_expr '&&' bool_expr      { do e1 <- $1; e2 <- $3; 
675                                           return (BoolAnd e1 e2) }
676         | bool_expr '||' bool_expr      { do e1 <- $1; e2 <- $3; 
677                                           return (BoolOr e1 e2)  }
678         | '!' bool_expr                 { do e <- $2; return (BoolNot e) }
679         | '(' bool_op ')'               { $2 }
680
681 safety  :: { Safety }
682         : {- empty -}                   { PlayRisky }
683         | STRING                        {% parseSafety $1 }
684
685 vols    :: { [GlobalReg] }
686         : '[' ']'                       { [] }
687         | '[' '*' ']'                   {% do df <- getDynFlags
688                                          ; return (realArgRegsCover df) }
689                                            -- All of them. See comment attached
690                                            -- to realArgRegsCover
691         | '[' globals ']'               { $2 }
692
693 globals :: { [GlobalReg] }
694         : GLOBALREG                     { [$1] }
695         | GLOBALREG ',' globals         { $1 : $3 }
696
697 maybe_range :: { Maybe (Integer,Integer) }
698         : '[' INT '..' INT ']'  { Just ($2, $4) }
699         | {- empty -}           { Nothing }
700
701 arms    :: { [CmmParse ([Integer],Either BlockId (CmmParse ()))] }
702         : {- empty -}                   { [] }
703         | arm arms                      { $1 : $2 }
704
705 arm     :: { CmmParse ([Integer],Either BlockId (CmmParse ())) }
706         : 'case' ints ':' arm_body      { do b <- $4; return ($2, b) }
707
708 arm_body :: { CmmParse (Either BlockId (CmmParse ())) }
709         : '{' body '}'                  { return (Right (withSourceNote $1 $3 $2)) }
710         | 'goto' NAME ';'               { do l <- lookupLabel $2; return (Left l) }
711
712 ints    :: { [Integer] }
713         : INT                           { [ $1 ] }
714         | INT ',' ints                  { $1 : $3 }
715
716 default :: { Maybe (CmmParse ()) }
717         : 'default' ':' '{' body '}'    { Just (withSourceNote $3 $5 $4) }
718         -- taking a few liberties with the C-- syntax here; C-- doesn't have
719         -- 'default' branches
720         | {- empty -}                   { Nothing }
721
722 -- Note: OldCmm doesn't support a first class 'else' statement, though
723 -- CmmNode does.
724 else    :: { CmmParse () }
725         : {- empty -}                   { return () }
726         | 'else' '{' body '}'           { withSourceNote $2 $4 $3 }
727
728 cond_likely :: { Maybe Bool }
729         : '(' 'likely' ':' 'True'  ')'  { Just True  }
730         | '(' 'likely' ':' 'False' ')'  { Just False }
731         | {- empty -}                   { Nothing }
732
733
734 -- we have to write this out longhand so that Happy's precedence rules
735 -- can kick in.
736 expr    :: { CmmParse CmmExpr }
737         : expr '/' expr                 { mkMachOp MO_U_Quot [$1,$3] }
738         | expr '*' expr                 { mkMachOp MO_Mul [$1,$3] }
739         | expr '%' expr                 { mkMachOp MO_U_Rem [$1,$3] }
740         | expr '-' expr                 { mkMachOp MO_Sub [$1,$3] }
741         | expr '+' expr                 { mkMachOp MO_Add [$1,$3] }
742         | expr '>>' expr                { mkMachOp MO_U_Shr [$1,$3] }
743         | expr '<<' expr                { mkMachOp MO_Shl [$1,$3] }
744         | expr '&' expr                 { mkMachOp MO_And [$1,$3] }
745         | expr '^' expr                 { mkMachOp MO_Xor [$1,$3] }
746         | expr '|' expr                 { mkMachOp MO_Or [$1,$3] }
747         | expr '>=' expr                { mkMachOp MO_U_Ge [$1,$3] }
748         | expr '>' expr                 { mkMachOp MO_U_Gt [$1,$3] }
749         | expr '<=' expr                { mkMachOp MO_U_Le [$1,$3] }
750         | expr '<' expr                 { mkMachOp MO_U_Lt [$1,$3] }
751         | expr '!=' expr                { mkMachOp MO_Ne [$1,$3] }
752         | expr '==' expr                { mkMachOp MO_Eq [$1,$3] }
753         | '~' expr                      { mkMachOp MO_Not [$2] }
754         | '-' expr                      { mkMachOp MO_S_Neg [$2] }
755         | expr0 '`' NAME '`' expr0      {% do { mo <- nameToMachOp $3 ;
756                                                 return (mkMachOp mo [$1,$5]) } }
757         | expr0                         { $1 }
758
759 expr0   :: { CmmParse CmmExpr }
760         : INT   maybe_ty         { return (CmmLit (CmmInt $1 (typeWidth $2))) }
761         | FLOAT maybe_ty         { return (CmmLit (CmmFloat $1 (typeWidth $2))) }
762         | STRING                 { do s <- code (newStringCLit $1); 
763                                       return (CmmLit s) }
764         | reg                    { $1 }
765         | type '[' expr ']'      { do e <- $3; return (CmmLoad e $1) }
766         | '%' NAME '(' exprs0 ')' {% exprOp $2 $4 }
767         | '(' expr ')'           { $2 }
768
769
770 -- leaving out the type of a literal gives you the native word size in C--
771 maybe_ty :: { CmmType }
772         : {- empty -}                   {% do dflags <- getDynFlags; return $ bWord dflags }
773         | '::' type                     { $2 }
774
775 cmm_hint_exprs0 :: { [CmmParse (CmmExpr, ForeignHint)] }
776         : {- empty -}                   { [] }
777         | cmm_hint_exprs                { $1 }
778
779 cmm_hint_exprs :: { [CmmParse (CmmExpr, ForeignHint)] }
780         : cmm_hint_expr                 { [$1] }
781         | cmm_hint_expr ',' cmm_hint_exprs      { $1 : $3 }
782
783 cmm_hint_expr :: { CmmParse (CmmExpr, ForeignHint) }
784         : expr                          { do e <- $1;
785                                              return (e, inferCmmHint e) }
786         | expr STRING                   {% do h <- parseCmmHint $2;
787                                               return $ do
788                                                 e <- $1; return (e, h) }
789
790 exprs0  :: { [CmmParse CmmExpr] }
791         : {- empty -}                   { [] }
792         | exprs                         { $1 }
793
794 exprs   :: { [CmmParse CmmExpr] }
795         : expr                          { [ $1 ] }
796         | expr ',' exprs                { $1 : $3 }
797
798 reg     :: { CmmParse CmmExpr }
799         : NAME                  { lookupName $1 }
800         | GLOBALREG             { return (CmmReg (CmmGlobal $1)) }
801
802 foreign_results :: { [CmmParse (LocalReg, ForeignHint)] }
803         : {- empty -}                   { [] }
804         | '(' foreign_formals ')' '='   { $2 }
805
806 foreign_formals :: { [CmmParse (LocalReg, ForeignHint)] }
807         : foreign_formal                        { [$1] }
808         | foreign_formal ','                    { [$1] }
809         | foreign_formal ',' foreign_formals    { $1 : $3 }
810
811 foreign_formal :: { CmmParse (LocalReg, ForeignHint) }
812         : local_lreg            { do e <- $1; return (e, (inferCmmHint (CmmReg (CmmLocal e)))) }
813         | STRING local_lreg     {% do h <- parseCmmHint $1;
814                                       return $ do
815                                          e <- $2; return (e,h) }
816
817 local_lreg :: { CmmParse LocalReg }
818         : NAME                  { do e <- lookupName $1;
819                                      return $
820                                        case e of 
821                                         CmmReg (CmmLocal r) -> r
822                                         other -> pprPanic "CmmParse:" (ftext $1 <> text " not a local register") }
823
824 lreg    :: { CmmParse CmmReg }
825         : NAME                  { do e <- lookupName $1;
826                                      return $
827                                        case e of 
828                                         CmmReg r -> r
829                                         other -> pprPanic "CmmParse:" (ftext $1 <> text " not a register") }
830         | GLOBALREG             { return (CmmGlobal $1) }
831
832 maybe_formals :: { Maybe [CmmParse LocalReg] }
833         : {- empty -}           { Nothing }
834         | '(' formals0 ')'      { Just $2 }
835
836 formals0 :: { [CmmParse LocalReg] }
837         : {- empty -}           { [] }
838         | formals               { $1 }
839
840 formals :: { [CmmParse LocalReg] }
841         : formal ','            { [$1] }
842         | formal                { [$1] }
843         | formal ',' formals       { $1 : $3 }
844
845 formal :: { CmmParse LocalReg }
846         : type NAME             { newLocal $1 $2 }
847
848 type    :: { CmmType }
849         : 'bits8'               { b8 }
850         | typenot8              { $1 }
851
852 typenot8 :: { CmmType }
853         : 'bits16'              { b16 }
854         | 'bits32'              { b32 }
855         | 'bits64'              { b64 }
856         | 'bits128'             { b128 }
857         | 'bits256'             { b256 }
858         | 'bits512'             { b512 }
859         | 'float32'             { f32 }
860         | 'float64'             { f64 }
861         | 'gcptr'               {% do dflags <- getDynFlags; return $ gcWord dflags }
862
863 {
864 section :: String -> SectionType
865 section "text"      = Text
866 section "data"      = Data
867 section "rodata"    = ReadOnlyData
868 section "relrodata" = RelocatableReadOnlyData
869 section "bss"       = UninitialisedData
870 section s           = OtherSection s
871
872 mkString :: String -> CmmStatic
873 mkString s = CmmString (map (fromIntegral.ord) s)
874
875 -- |
876 -- Given an info table, decide what the entry convention for the proc
877 -- is.  That is, for an INFO_TABLE_RET we want the return convention,
878 -- otherwise it is a NativeNodeCall.
879 --
880 infoConv :: Maybe CmmInfoTable -> Convention
881 infoConv Nothing = NativeNodeCall
882 infoConv (Just info)
883   | isStackRep (cit_rep info) = NativeReturn
884   | otherwise                 = NativeNodeCall
885
886 -- mkMachOp infers the type of the MachOp from the type of its first
887 -- argument.  We assume that this is correct: for MachOps that don't have
888 -- symmetrical args (e.g. shift ops), the first arg determines the type of
889 -- the op.
890 mkMachOp :: (Width -> MachOp) -> [CmmParse CmmExpr] -> CmmParse CmmExpr
891 mkMachOp fn args = do
892   dflags <- getDynFlags
893   arg_exprs <- sequence args
894   return (CmmMachOp (fn (typeWidth (cmmExprType dflags (head arg_exprs)))) arg_exprs)
895
896 getLit :: CmmExpr -> CmmLit
897 getLit (CmmLit l) = l
898 getLit (CmmMachOp (MO_S_Neg _) [CmmLit (CmmInt i r)])  = CmmInt (negate i) r
899 getLit _ = panic "invalid literal" -- TODO messy failure
900
901 nameToMachOp :: FastString -> PD (Width -> MachOp)
902 nameToMachOp name =
903   case lookupUFM machOps name of
904         Nothing -> fail ("unknown primitive " ++ unpackFS name)
905         Just m  -> return m
906
907 exprOp :: FastString -> [CmmParse CmmExpr] -> PD (CmmParse CmmExpr)
908 exprOp name args_code = do
909   dflags <- getDynFlags
910   case lookupUFM (exprMacros dflags) name of
911      Just f  -> return $ do
912         args <- sequence args_code
913         return (f args)
914      Nothing -> do
915         mo <- nameToMachOp name
916         return $ mkMachOp mo args_code
917
918 exprMacros :: DynFlags -> UniqFM ([CmmExpr] -> CmmExpr)
919 exprMacros dflags = listToUFM [
920   ( fsLit "ENTRY_CODE",   \ [x] -> entryCode dflags x ),
921   ( fsLit "INFO_PTR",     \ [x] -> closureInfoPtr dflags x ),
922   ( fsLit "STD_INFO",     \ [x] -> infoTable dflags x ),
923   ( fsLit "FUN_INFO",     \ [x] -> funInfoTable dflags x ),
924   ( fsLit "GET_ENTRY",    \ [x] -> entryCode dflags (closureInfoPtr dflags x) ),
925   ( fsLit "GET_STD_INFO", \ [x] -> infoTable dflags (closureInfoPtr dflags x) ),
926   ( fsLit "GET_FUN_INFO", \ [x] -> funInfoTable dflags (closureInfoPtr dflags x) ),
927   ( fsLit "INFO_TYPE",    \ [x] -> infoTableClosureType dflags x ),
928   ( fsLit "INFO_PTRS",    \ [x] -> infoTablePtrs dflags x ),
929   ( fsLit "INFO_NPTRS",   \ [x] -> infoTableNonPtrs dflags x )
930   ]
931
932 -- we understand a subset of C-- primitives:
933 machOps = listToUFM $
934         map (\(x, y) -> (mkFastString x, y)) [
935         ( "add",        MO_Add ),
936         ( "sub",        MO_Sub ),
937         ( "eq",         MO_Eq ),
938         ( "ne",         MO_Ne ),
939         ( "mul",        MO_Mul ),
940         ( "neg",        MO_S_Neg ),
941         ( "quot",       MO_S_Quot ),
942         ( "rem",        MO_S_Rem ),
943         ( "divu",       MO_U_Quot ),
944         ( "modu",       MO_U_Rem ),
945
946         ( "ge",         MO_S_Ge ),
947         ( "le",         MO_S_Le ),
948         ( "gt",         MO_S_Gt ),
949         ( "lt",         MO_S_Lt ),
950
951         ( "geu",        MO_U_Ge ),
952         ( "leu",        MO_U_Le ),
953         ( "gtu",        MO_U_Gt ),
954         ( "ltu",        MO_U_Lt ),
955
956         ( "and",        MO_And ),
957         ( "or",         MO_Or ),
958         ( "xor",        MO_Xor ),
959         ( "com",        MO_Not ),
960         ( "shl",        MO_Shl ),
961         ( "shrl",       MO_U_Shr ),
962         ( "shra",       MO_S_Shr ),
963
964         ( "fadd",       MO_F_Add ),
965         ( "fsub",       MO_F_Sub ),
966         ( "fneg",       MO_F_Neg ),
967         ( "fmul",       MO_F_Mul ),
968         ( "fquot",      MO_F_Quot ),
969
970         ( "feq",        MO_F_Eq ),
971         ( "fne",        MO_F_Ne ),
972         ( "fge",        MO_F_Ge ),
973         ( "fle",        MO_F_Le ),
974         ( "fgt",        MO_F_Gt ),
975         ( "flt",        MO_F_Lt ),
976
977         ( "lobits8",  flip MO_UU_Conv W8  ),
978         ( "lobits16", flip MO_UU_Conv W16 ),
979         ( "lobits32", flip MO_UU_Conv W32 ),
980         ( "lobits64", flip MO_UU_Conv W64 ),
981
982         ( "zx16",     flip MO_UU_Conv W16 ),
983         ( "zx32",     flip MO_UU_Conv W32 ),
984         ( "zx64",     flip MO_UU_Conv W64 ),
985
986         ( "sx16",     flip MO_SS_Conv W16 ),
987         ( "sx32",     flip MO_SS_Conv W32 ),
988         ( "sx64",     flip MO_SS_Conv W64 ),
989
990         ( "f2f32",    flip MO_FF_Conv W32 ),  -- TODO; rounding mode
991         ( "f2f64",    flip MO_FF_Conv W64 ),  -- TODO; rounding mode
992         ( "f2i8",     flip MO_FS_Conv W8 ),
993         ( "f2i16",    flip MO_FS_Conv W16 ),
994         ( "f2i32",    flip MO_FS_Conv W32 ),
995         ( "f2i64",    flip MO_FS_Conv W64 ),
996         ( "i2f32",    flip MO_SF_Conv W32 ),
997         ( "i2f64",    flip MO_SF_Conv W64 )
998         ]
999
1000 callishMachOps :: UniqFM ([CmmExpr] -> (CallishMachOp, [CmmExpr]))
1001 callishMachOps = listToUFM $
1002         map (\(x, y) -> (mkFastString x, y)) [
1003         ( "write_barrier", (,) MO_WriteBarrier ),
1004         ( "memcpy", memcpyLikeTweakArgs MO_Memcpy ),
1005         ( "memset", memcpyLikeTweakArgs MO_Memset ),
1006         ( "memmove", memcpyLikeTweakArgs MO_Memmove ),
1007         ( "memcmp", memcpyLikeTweakArgs MO_Memcmp ),
1008
1009         ("prefetch0", (,) $ MO_Prefetch_Data 0),
1010         ("prefetch1", (,) $ MO_Prefetch_Data 1),
1011         ("prefetch2", (,) $ MO_Prefetch_Data 2),
1012         ("prefetch3", (,) $ MO_Prefetch_Data 3),
1013
1014         ( "popcnt8",  (,) $ MO_PopCnt W8  ),
1015         ( "popcnt16", (,) $ MO_PopCnt W16 ),
1016         ( "popcnt32", (,) $ MO_PopCnt W32 ),
1017         ( "popcnt64", (,) $ MO_PopCnt W64 ),
1018
1019         ( "pdep8",  (,) $ MO_Pdep W8  ),
1020         ( "pdep16", (,) $ MO_Pdep W16 ),
1021         ( "pdep32", (,) $ MO_Pdep W32 ),
1022         ( "pdep64", (,) $ MO_Pdep W64 ),
1023
1024         ( "pext8",  (,) $ MO_Pext W8  ),
1025         ( "pext16", (,) $ MO_Pext W16 ),
1026         ( "pext32", (,) $ MO_Pext W32 ),
1027         ( "pext64", (,) $ MO_Pext W64 ),
1028
1029         ( "cmpxchg8",  (,) $ MO_Cmpxchg W8  ),
1030         ( "cmpxchg16", (,) $ MO_Cmpxchg W16 ),
1031         ( "cmpxchg32", (,) $ MO_Cmpxchg W32 ),
1032         ( "cmpxchg64", (,) $ MO_Cmpxchg W64 )
1033
1034         -- ToDo: the rest, maybe
1035         -- edit: which rest?
1036         -- also: how do we tell CMM Lint how to type check callish macops?
1037     ]
1038   where
1039     memcpyLikeTweakArgs :: (Int -> CallishMachOp) -> [CmmExpr] -> (CallishMachOp, [CmmExpr])
1040     memcpyLikeTweakArgs op [] = pgmError "memcpy-like function requires at least one argument"
1041     memcpyLikeTweakArgs op args@(_:_) =
1042         (op align, args')
1043       where
1044         args' = init args
1045         align = case last args of
1046           CmmLit (CmmInt alignInteger _) -> fromInteger alignInteger
1047           e -> pprPgmError "Non-constant alignment in memcpy-like function:" (ppr e)
1048         -- The alignment of memcpy-ish operations must be a
1049         -- compile-time constant. We verify this here, passing it around
1050         -- in the MO_* constructor. In order to do this, however, we
1051         -- must intercept the arguments in primCall.
1052
1053 parseSafety :: String -> PD Safety
1054 parseSafety "safe"   = return PlaySafe
1055 parseSafety "unsafe" = return PlayRisky
1056 parseSafety "interruptible" = return PlayInterruptible
1057 parseSafety str      = fail ("unrecognised safety: " ++ str)
1058
1059 parseCmmHint :: String -> PD ForeignHint
1060 parseCmmHint "ptr"    = return AddrHint
1061 parseCmmHint "signed" = return SignedHint
1062 parseCmmHint str      = fail ("unrecognised hint: " ++ str)
1063
1064 -- labels are always pointers, so we might as well infer the hint
1065 inferCmmHint :: CmmExpr -> ForeignHint
1066 inferCmmHint (CmmLit (CmmLabel _)) = AddrHint
1067 inferCmmHint (CmmReg (CmmGlobal g)) | isPtrGlobalReg g = AddrHint
1068 inferCmmHint _ = NoHint
1069
1070 isPtrGlobalReg Sp                    = True
1071 isPtrGlobalReg SpLim                 = True
1072 isPtrGlobalReg Hp                    = True
1073 isPtrGlobalReg HpLim                 = True
1074 isPtrGlobalReg CCCS                  = True
1075 isPtrGlobalReg CurrentTSO            = True
1076 isPtrGlobalReg CurrentNursery        = True
1077 isPtrGlobalReg (VanillaReg _ VGcPtr) = True
1078 isPtrGlobalReg _                     = False
1079
1080 happyError :: PD a
1081 happyError = PD $ \_ s -> unP srcParseFail s
1082
1083 -- -----------------------------------------------------------------------------
1084 -- Statement-level macros
1085
1086 stmtMacro :: FastString -> [CmmParse CmmExpr] -> PD (CmmParse ())
1087 stmtMacro fun args_code = do
1088   case lookupUFM stmtMacros fun of
1089     Nothing -> fail ("unknown macro: " ++ unpackFS fun)
1090     Just fcode -> return $ do
1091         args <- sequence args_code
1092         code (fcode args)
1093
1094 stmtMacros :: UniqFM ([CmmExpr] -> FCode ())
1095 stmtMacros = listToUFM [
1096   ( fsLit "CCS_ALLOC",             \[words,ccs]  -> profAlloc words ccs ),
1097   ( fsLit "ENTER_CCS_THUNK",       \[e] -> enterCostCentreThunk e ),
1098
1099   ( fsLit "CLOSE_NURSERY",         \[]  -> emitCloseNursery ),
1100   ( fsLit "OPEN_NURSERY",          \[]  -> emitOpenNursery ),
1101
1102   -- completely generic heap and stack checks, for use in high-level cmm.
1103   ( fsLit "HP_CHK_GEN",            \[bytes] ->
1104                                       heapStackCheckGen Nothing (Just bytes) ),
1105   ( fsLit "STK_CHK_GEN",           \[] ->
1106                                       heapStackCheckGen (Just (CmmLit CmmHighStackMark)) Nothing ),
1107
1108   -- A stack check for a fixed amount of stack.  Sounds a bit strange, but
1109   -- we use the stack for a bit of temporary storage in a couple of primops
1110   ( fsLit "STK_CHK_GEN_N",         \[bytes] ->
1111                                       heapStackCheckGen (Just bytes) Nothing ),
1112
1113   -- A stack check on entry to a thunk, where the argument is the thunk pointer.
1114   ( fsLit "STK_CHK_NP"   ,         \[node] -> entryHeapCheck' False node 0 [] (return ())),
1115
1116   ( fsLit "LOAD_THREAD_STATE",     \[] -> emitLoadThreadState ),
1117   ( fsLit "SAVE_THREAD_STATE",     \[] -> emitSaveThreadState ),
1118
1119   ( fsLit "LDV_ENTER",             \[e] -> ldvEnter e ),
1120   ( fsLit "LDV_RECORD_CREATE",     \[e] -> ldvRecordCreate e ),
1121
1122   ( fsLit "PUSH_UPD_FRAME",        \[sp,e] -> emitPushUpdateFrame sp e ),
1123   ( fsLit "SET_HDR",               \[ptr,info,ccs] ->
1124                                         emitSetDynHdr ptr info ccs ),
1125   ( fsLit "TICK_ALLOC_PRIM",       \[hdr,goods,slop] ->
1126                                         tickyAllocPrim hdr goods slop ),
1127   ( fsLit "TICK_ALLOC_PAP",        \[goods,slop] ->
1128                                         tickyAllocPAP goods slop ),
1129   ( fsLit "TICK_ALLOC_UP_THK",     \[goods,slop] ->
1130                                         tickyAllocThunk goods slop ),
1131   ( fsLit "UPD_BH_UPDATABLE",      \[reg] -> emitBlackHoleCode reg )
1132  ]
1133
1134 emitPushUpdateFrame :: CmmExpr -> CmmExpr -> FCode ()
1135 emitPushUpdateFrame sp e = do
1136   dflags <- getDynFlags
1137   emitUpdateFrame dflags sp mkUpdInfoLabel e
1138
1139 pushStackFrame :: [CmmParse CmmExpr] -> CmmParse () -> CmmParse ()
1140 pushStackFrame fields body = do
1141   dflags <- getDynFlags
1142   exprs <- sequence fields
1143   updfr_off <- getUpdFrameOff
1144   let (new_updfr_off, _, g) = copyOutOflow dflags NativeReturn Ret Old
1145                                            [] updfr_off exprs
1146   emit g
1147   withUpdFrameOff new_updfr_off body
1148
1149 reserveStackFrame
1150   :: CmmParse CmmExpr
1151   -> CmmParse CmmReg
1152   -> CmmParse ()
1153   -> CmmParse ()
1154 reserveStackFrame psize preg body = do
1155   dflags <- getDynFlags
1156   old_updfr_off <- getUpdFrameOff
1157   reg <- preg
1158   esize <- psize
1159   let size = case constantFoldExpr dflags esize of
1160                CmmLit (CmmInt n _) -> n
1161                _other -> pprPanic "CmmParse: not a compile-time integer: "
1162                             (ppr esize)
1163   let frame = old_updfr_off + wORD_SIZE dflags * fromIntegral size
1164   emitAssign reg (CmmStackSlot Old frame)
1165   withUpdFrameOff frame body
1166
1167 profilingInfo dflags desc_str ty_str
1168   = if not (gopt Opt_SccProfilingOn dflags)
1169     then NoProfilingInfo
1170     else ProfilingInfo (stringToWord8s desc_str)
1171                        (stringToWord8s ty_str)
1172
1173 staticClosure :: UnitId -> FastString -> FastString -> [CmmLit] -> CmmParse ()
1174 staticClosure pkg cl_label info payload
1175   = do dflags <- getDynFlags
1176        let lits = mkStaticClosure dflags (mkCmmInfoLabel pkg info) dontCareCCS payload [] [] []
1177        code $ emitDataLits (mkCmmDataLabel pkg cl_label) lits
1178
1179 foreignCall
1180         :: String
1181         -> [CmmParse (LocalReg, ForeignHint)]
1182         -> CmmParse CmmExpr
1183         -> [CmmParse (CmmExpr, ForeignHint)]
1184         -> Safety
1185         -> CmmReturnInfo
1186         -> PD (CmmParse ())
1187 foreignCall conv_string results_code expr_code args_code safety ret
1188   = do  conv <- case conv_string of
1189           "C" -> return CCallConv
1190           "stdcall" -> return StdCallConv
1191           _ -> fail ("unknown calling convention: " ++ conv_string)
1192         return $ do
1193           dflags <- getDynFlags
1194           results <- sequence results_code
1195           expr <- expr_code
1196           args <- sequence args_code
1197           let
1198                   expr' = adjCallTarget dflags conv expr args
1199                   (arg_exprs, arg_hints) = unzip args
1200                   (res_regs,  res_hints) = unzip results
1201                   fc = ForeignConvention conv arg_hints res_hints ret
1202                   target = ForeignTarget expr' fc
1203           _ <- code $ emitForeignCall safety res_regs target arg_exprs
1204           return ()
1205
1206
1207 doReturn :: [CmmParse CmmExpr] -> CmmParse ()
1208 doReturn exprs_code = do
1209   dflags <- getDynFlags
1210   exprs <- sequence exprs_code
1211   updfr_off <- getUpdFrameOff
1212   emit (mkReturnSimple dflags exprs updfr_off)
1213
1214 mkReturnSimple  :: DynFlags -> [CmmActual] -> UpdFrameOffset -> CmmAGraph
1215 mkReturnSimple dflags actuals updfr_off =
1216   mkReturn dflags e actuals updfr_off
1217   where e = entryCode dflags (CmmLoad (CmmStackSlot Old updfr_off)
1218                              (gcWord dflags))
1219
1220 doRawJump :: CmmParse CmmExpr -> [GlobalReg] -> CmmParse ()
1221 doRawJump expr_code vols = do
1222   dflags <- getDynFlags
1223   expr <- expr_code
1224   updfr_off <- getUpdFrameOff
1225   emit (mkRawJump dflags expr updfr_off vols)
1226
1227 doJumpWithStack :: CmmParse CmmExpr -> [CmmParse CmmExpr]
1228                 -> [CmmParse CmmExpr] -> CmmParse ()
1229 doJumpWithStack expr_code stk_code args_code = do
1230   dflags <- getDynFlags
1231   expr <- expr_code
1232   stk_args <- sequence stk_code
1233   args <- sequence args_code
1234   updfr_off <- getUpdFrameOff
1235   emit (mkJumpExtra dflags NativeNodeCall expr args updfr_off stk_args)
1236
1237 doCall :: CmmParse CmmExpr -> [CmmParse LocalReg] -> [CmmParse CmmExpr]
1238        -> CmmParse ()
1239 doCall expr_code res_code args_code = do
1240   dflags <- getDynFlags
1241   expr <- expr_code
1242   args <- sequence args_code
1243   ress <- sequence res_code
1244   updfr_off <- getUpdFrameOff
1245   c <- code $ mkCall expr (NativeNodeCall,NativeReturn) ress args updfr_off []
1246   emit c
1247
1248 adjCallTarget :: DynFlags -> CCallConv -> CmmExpr -> [(CmmExpr, ForeignHint) ]
1249               -> CmmExpr
1250 -- On Windows, we have to add the '@N' suffix to the label when making
1251 -- a call with the stdcall calling convention.
1252 adjCallTarget dflags StdCallConv (CmmLit (CmmLabel lbl)) args
1253  | platformOS (targetPlatform dflags) == OSMinGW32
1254   = CmmLit (CmmLabel (addLabelSize lbl (sum (map size args))))
1255   where size (e, _) = max (wORD_SIZE dflags) (widthInBytes (typeWidth (cmmExprType dflags e)))
1256                  -- c.f. CgForeignCall.emitForeignCall
1257 adjCallTarget _ _ expr _
1258   = expr
1259
1260 primCall
1261         :: [CmmParse (CmmFormal, ForeignHint)]
1262         -> FastString
1263         -> [CmmParse CmmExpr]
1264         -> PD (CmmParse ())
1265 primCall results_code name args_code
1266   = case lookupUFM callishMachOps name of
1267         Nothing -> fail ("unknown primitive " ++ unpackFS name)
1268         Just f  -> return $ do
1269                 results <- sequence results_code
1270                 args <- sequence args_code
1271                 let (p, args') = f args
1272                 code (emitPrimCall (map fst results) p args')
1273
1274 doStore :: CmmType -> CmmParse CmmExpr  -> CmmParse CmmExpr -> CmmParse ()
1275 doStore rep addr_code val_code
1276   = do dflags <- getDynFlags
1277        addr <- addr_code
1278        val <- val_code
1279         -- if the specified store type does not match the type of the expr
1280         -- on the rhs, then we insert a coercion that will cause the type
1281         -- mismatch to be flagged by cmm-lint.  If we don't do this, then
1282         -- the store will happen at the wrong type, and the error will not
1283         -- be noticed.
1284        let val_width = typeWidth (cmmExprType dflags val)
1285            rep_width = typeWidth rep
1286        let coerce_val
1287                 | val_width /= rep_width = CmmMachOp (MO_UU_Conv val_width rep_width) [val]
1288                 | otherwise              = val
1289        emitStore addr coerce_val
1290
1291 -- -----------------------------------------------------------------------------
1292 -- If-then-else and boolean expressions
1293
1294 data BoolExpr
1295   = BoolExpr `BoolAnd` BoolExpr
1296   | BoolExpr `BoolOr`  BoolExpr
1297   | BoolNot BoolExpr
1298   | BoolTest CmmExpr
1299
1300 -- ToDo: smart constructors which simplify the boolean expression.
1301
1302 cmmIfThenElse cond then_part else_part likely = do
1303      then_id <- newBlockId
1304      join_id <- newBlockId
1305      c <- cond
1306      emitCond c then_id likely
1307      else_part
1308      emit (mkBranch join_id)
1309      emitLabel then_id
1310      then_part
1311      -- fall through to join
1312      emitLabel join_id
1313
1314 cmmRawIf cond then_id likely = do
1315     c <- cond
1316     emitCond c then_id likely
1317
1318 -- 'emitCond cond true_id'  emits code to test whether the cond is true,
1319 -- branching to true_id if so, and falling through otherwise.
1320 emitCond (BoolTest e) then_id likely = do
1321   else_id <- newBlockId
1322   emit (mkCbranch e then_id else_id likely)
1323   emitLabel else_id
1324 emitCond (BoolNot (BoolTest (CmmMachOp op args))) then_id likely
1325   | Just op' <- maybeInvertComparison op
1326   = emitCond (BoolTest (CmmMachOp op' args)) then_id (not <$> likely)
1327 emitCond (BoolNot e) then_id likely = do
1328   else_id <- newBlockId
1329   emitCond e else_id likely
1330   emit (mkBranch then_id)
1331   emitLabel else_id
1332 emitCond (e1 `BoolOr` e2) then_id likely = do
1333   emitCond e1 then_id likely
1334   emitCond e2 then_id likely
1335 emitCond (e1 `BoolAnd` e2) then_id likely = do
1336         -- we'd like to invert one of the conditionals here to avoid an
1337         -- extra branch instruction, but we can't use maybeInvertComparison
1338         -- here because we can't look too closely at the expression since
1339         -- we're in a loop.
1340   and_id <- newBlockId
1341   else_id <- newBlockId
1342   emitCond e1 and_id likely
1343   emit (mkBranch else_id)
1344   emitLabel and_id
1345   emitCond e2 then_id likely
1346   emitLabel else_id
1347
1348 -- -----------------------------------------------------------------------------
1349 -- Source code notes
1350
1351 -- | Generate a source note spanning from "a" to "b" (inclusive), then
1352 -- proceed with parsing. This allows debugging tools to reason about
1353 -- locations in Cmm code.
1354 withSourceNote :: Located a -> Located b -> CmmParse c -> CmmParse c
1355 withSourceNote a b parse = do
1356   name <- getName
1357   case combineSrcSpans (getLoc a) (getLoc b) of
1358     RealSrcSpan span -> code (emitTick (SourceNote span name)) >> parse
1359     _other           -> parse
1360
1361 -- -----------------------------------------------------------------------------
1362 -- Table jumps
1363
1364 -- We use a simplified form of C-- switch statements for now.  A
1365 -- switch statement always compiles to a table jump.  Each arm can
1366 -- specify a list of values (not ranges), and there can be a single
1367 -- default branch.  The range of the table is given either by the
1368 -- optional range on the switch (eg. switch [0..7] {...}), or by
1369 -- the minimum/maximum values from the branches.
1370
1371 doSwitch :: Maybe (Integer,Integer)
1372          -> CmmParse CmmExpr
1373          -> [([Integer],Either BlockId (CmmParse ()))]
1374          -> Maybe (CmmParse ()) -> CmmParse ()
1375 doSwitch mb_range scrut arms deflt
1376    = do
1377         -- Compile code for the default branch
1378         dflt_entry <- 
1379                 case deflt of
1380                   Nothing -> return Nothing
1381                   Just e  -> do b <- forkLabelledCode e; return (Just b)
1382
1383         -- Compile each case branch
1384         table_entries <- mapM emitArm arms
1385         let table = M.fromList (concat table_entries)
1386
1387         dflags <- getDynFlags
1388         let range = fromMaybe (0, tARGET_MAX_WORD dflags) mb_range
1389
1390         expr <- scrut
1391         -- ToDo: check for out of range and jump to default if necessary
1392         emit $ mkSwitch expr (mkSwitchTargets False range dflt_entry table)
1393    where
1394         emitArm :: ([Integer],Either BlockId (CmmParse ())) -> CmmParse [(Integer,BlockId)]
1395         emitArm (ints,Left blockid) = return [ (i,blockid) | i <- ints ]
1396         emitArm (ints,Right code) = do
1397            blockid <- forkLabelledCode code
1398            return [ (i,blockid) | i <- ints ]
1399
1400 forkLabelledCode :: CmmParse () -> CmmParse BlockId
1401 forkLabelledCode p = do
1402   (_,ag) <- getCodeScoped p
1403   l <- newBlockId
1404   emitOutOfLine l ag
1405   return l
1406
1407 -- -----------------------------------------------------------------------------
1408 -- Putting it all together
1409
1410 -- The initial environment: we define some constants that the compiler
1411 -- knows about here.
1412 initEnv :: DynFlags -> Env
1413 initEnv dflags = listToUFM [
1414   ( fsLit "SIZEOF_StgHeader",
1415     VarN (CmmLit (CmmInt (fromIntegral (fixedHdrSize dflags)) (wordWidth dflags)) )),
1416   ( fsLit "SIZEOF_StgInfoTable",
1417     VarN (CmmLit (CmmInt (fromIntegral (stdInfoTableSizeB dflags)) (wordWidth dflags)) ))
1418   ]
1419
1420 parseCmmFile :: DynFlags -> FilePath -> IO (Messages, Maybe CmmGroup)
1421 parseCmmFile dflags filename = withTiming (pure dflags) (text "ParseCmm"<+>brackets (text filename)) (\_ -> ()) $ do
1422   buf <- hGetStringBuffer filename
1423   let
1424         init_loc = mkRealSrcLoc (mkFastString filename) 1 1
1425         init_state = (mkPState dflags buf init_loc) { lex_state = [0] }
1426                 -- reset the lex_state: the Lexer monad leaves some stuff
1427                 -- in there we don't want.
1428   case unPD cmmParse dflags init_state of
1429     PFailed warnFn span err -> do
1430         let msg = mkPlainErrMsg dflags span err
1431             errMsgs = (emptyBag, unitBag msg)
1432             warnMsgs = warnFn dflags
1433         return (unionMessages warnMsgs errMsgs, Nothing)
1434     POk pst code -> do
1435         st <- initC
1436         let fcode = getCmm $ unEC code "global" (initEnv dflags) [] >> return ()
1437             (cmm,_) = runC dflags no_module st fcode
1438         let ms = getMessages pst dflags
1439         if (errorsFound dflags ms)
1440          then return (ms, Nothing)
1441          else return (ms, Just cmm)
1442   where
1443         no_module = panic "parseCmmFile: no module"
1444 }