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