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