11e68bd4e105cfd72938de075307d3bfad9cc08e
[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 accomodate 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
232 import CostCentre
233 import ForeignCall
234 import Module
235 import Platform
236 import Literal
237 import Unique
238 import UniqFM
239 import SrcLoc
240 import DynFlags
241 import StaticFlags
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 { P } { >>= } { 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                 {% 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 $2) (Statics lbl $ concat ss))) }
389
390 data_label :: { CmmParse CLabel }
391     : NAME ':'  
392                 {% 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                 {% 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                 {% 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                 {% 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                 {% 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                 {% 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                 {% 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                 {% 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' GLOBALREG '=' expr
639                 { $4 >>= code . emitUnwind $2 }
640
641 foreignLabel     :: { CmmParse CmmExpr }
642         : NAME                          { return (CmmLit (CmmLabel (mkForeignLabel $1 Nothing ForeignLabelInThisPackage IsFunction))) }
643
644 opt_never_returns :: { CmmReturnInfo }
645         :                               { CmmMayReturn }
646         | 'never' 'returns'             { CmmNeverReturns }
647
648 bool_expr :: { CmmParse BoolExpr }
649         : bool_op                       { $1 }
650         | expr                          { do e <- $1; return (BoolTest e) }
651
652 bool_op :: { CmmParse BoolExpr }
653         : bool_expr '&&' bool_expr      { do e1 <- $1; e2 <- $3; 
654                                           return (BoolAnd e1 e2) }
655         | bool_expr '||' bool_expr      { do e1 <- $1; e2 <- $3; 
656                                           return (BoolOr e1 e2)  }
657         | '!' bool_expr                 { do e <- $2; return (BoolNot e) }
658         | '(' bool_op ')'               { $2 }
659
660 safety  :: { Safety }
661         : {- empty -}                   { PlayRisky }
662         | STRING                        {% parseSafety $1 }
663
664 vols    :: { [GlobalReg] }
665         : '[' ']'                       { [] }
666         | '[' '*' ']'                   {% do df <- getDynFlags
667                                          ; return (realArgRegsCover df) }
668                                            -- All of them. See comment attached
669                                            -- to realArgRegsCover
670         | '[' globals ']'               { $2 }
671
672 globals :: { [GlobalReg] }
673         : GLOBALREG                     { [$1] }
674         | GLOBALREG ',' globals         { $1 : $3 }
675
676 maybe_range :: { Maybe (Integer,Integer) }
677         : '[' INT '..' INT ']'  { Just ($2, $4) }
678         | {- empty -}           { Nothing }
679
680 arms    :: { [CmmParse ([Integer],Either BlockId (CmmParse ()))] }
681         : {- empty -}                   { [] }
682         | arm arms                      { $1 : $2 }
683
684 arm     :: { CmmParse ([Integer],Either BlockId (CmmParse ())) }
685         : 'case' ints ':' arm_body      { do b <- $4; return ($2, b) }
686
687 arm_body :: { CmmParse (Either BlockId (CmmParse ())) }
688         : '{' body '}'                  { return (Right (withSourceNote $1 $3 $2)) }
689         | 'goto' NAME ';'               { do l <- lookupLabel $2; return (Left l) }
690
691 ints    :: { [Integer] }
692         : INT                           { [ $1 ] }
693         | INT ',' ints                  { $1 : $3 }
694
695 default :: { Maybe (CmmParse ()) }
696         : 'default' ':' '{' body '}'    { Just (withSourceNote $3 $5 $4) }
697         -- taking a few liberties with the C-- syntax here; C-- doesn't have
698         -- 'default' branches
699         | {- empty -}                   { Nothing }
700
701 -- Note: OldCmm doesn't support a first class 'else' statement, though
702 -- CmmNode does.
703 else    :: { CmmParse () }
704         : {- empty -}                   { return () }
705         | 'else' '{' body '}'           { withSourceNote $2 $4 $3 }
706
707 -- we have to write this out longhand so that Happy's precedence rules
708 -- can kick in.
709 expr    :: { CmmParse CmmExpr }
710         : expr '/' expr                 { mkMachOp MO_U_Quot [$1,$3] }
711         | expr '*' expr                 { mkMachOp MO_Mul [$1,$3] }
712         | expr '%' expr                 { mkMachOp MO_U_Rem [$1,$3] }
713         | expr '-' expr                 { mkMachOp MO_Sub [$1,$3] }
714         | expr '+' expr                 { mkMachOp MO_Add [$1,$3] }
715         | expr '>>' expr                { mkMachOp MO_U_Shr [$1,$3] }
716         | expr '<<' expr                { mkMachOp MO_Shl [$1,$3] }
717         | expr '&' expr                 { mkMachOp MO_And [$1,$3] }
718         | expr '^' expr                 { mkMachOp MO_Xor [$1,$3] }
719         | expr '|' expr                 { mkMachOp MO_Or [$1,$3] }
720         | expr '>=' expr                { mkMachOp MO_U_Ge [$1,$3] }
721         | expr '>' expr                 { mkMachOp MO_U_Gt [$1,$3] }
722         | expr '<=' expr                { mkMachOp MO_U_Le [$1,$3] }
723         | expr '<' expr                 { mkMachOp MO_U_Lt [$1,$3] }
724         | expr '!=' expr                { mkMachOp MO_Ne [$1,$3] }
725         | expr '==' expr                { mkMachOp MO_Eq [$1,$3] }
726         | '~' expr                      { mkMachOp MO_Not [$2] }
727         | '-' expr                      { mkMachOp MO_S_Neg [$2] }
728         | expr0 '`' NAME '`' expr0      {% do { mo <- nameToMachOp $3 ;
729                                                 return (mkMachOp mo [$1,$5]) } }
730         | expr0                         { $1 }
731
732 expr0   :: { CmmParse CmmExpr }
733         : INT   maybe_ty         { return (CmmLit (CmmInt $1 (typeWidth $2))) }
734         | FLOAT maybe_ty         { return (CmmLit (CmmFloat $1 (typeWidth $2))) }
735         | STRING                 { do s <- code (newStringCLit $1); 
736                                       return (CmmLit s) }
737         | reg                    { $1 }
738         | type '[' expr ']'      { do e <- $3; return (CmmLoad e $1) }
739         | '%' NAME '(' exprs0 ')' {% exprOp $2 $4 }
740         | '(' expr ')'           { $2 }
741
742
743 -- leaving out the type of a literal gives you the native word size in C--
744 maybe_ty :: { CmmType }
745         : {- empty -}                   {% do dflags <- getDynFlags; return $ bWord dflags }
746         | '::' type                     { $2 }
747
748 cmm_hint_exprs0 :: { [CmmParse (CmmExpr, ForeignHint)] }
749         : {- empty -}                   { [] }
750         | cmm_hint_exprs                { $1 }
751
752 cmm_hint_exprs :: { [CmmParse (CmmExpr, ForeignHint)] }
753         : cmm_hint_expr                 { [$1] }
754         | cmm_hint_expr ',' cmm_hint_exprs      { $1 : $3 }
755
756 cmm_hint_expr :: { CmmParse (CmmExpr, ForeignHint) }
757         : expr                          { do e <- $1;
758                                              return (e, inferCmmHint e) }
759         | expr STRING                   {% do h <- parseCmmHint $2;
760                                               return $ do
761                                                 e <- $1; return (e, h) }
762
763 exprs0  :: { [CmmParse CmmExpr] }
764         : {- empty -}                   { [] }
765         | exprs                         { $1 }
766
767 exprs   :: { [CmmParse CmmExpr] }
768         : expr                          { [ $1 ] }
769         | expr ',' exprs                { $1 : $3 }
770
771 reg     :: { CmmParse CmmExpr }
772         : NAME                  { lookupName $1 }
773         | GLOBALREG             { return (CmmReg (CmmGlobal $1)) }
774
775 foreign_results :: { [CmmParse (LocalReg, ForeignHint)] }
776         : {- empty -}                   { [] }
777         | '(' foreign_formals ')' '='   { $2 }
778
779 foreign_formals :: { [CmmParse (LocalReg, ForeignHint)] }
780         : foreign_formal                        { [$1] }
781         | foreign_formal ','                    { [$1] }
782         | foreign_formal ',' foreign_formals    { $1 : $3 }
783
784 foreign_formal :: { CmmParse (LocalReg, ForeignHint) }
785         : local_lreg            { do e <- $1; return (e, (inferCmmHint (CmmReg (CmmLocal e)))) }
786         | STRING local_lreg     {% do h <- parseCmmHint $1;
787                                       return $ do
788                                          e <- $2; return (e,h) }
789
790 local_lreg :: { CmmParse LocalReg }
791         : NAME                  { do e <- lookupName $1;
792                                      return $
793                                        case e of 
794                                         CmmReg (CmmLocal r) -> r
795                                         other -> pprPanic "CmmParse:" (ftext $1 <> text " not a local register") }
796
797 lreg    :: { CmmParse CmmReg }
798         : NAME                  { do e <- lookupName $1;
799                                      return $
800                                        case e of 
801                                         CmmReg r -> r
802                                         other -> pprPanic "CmmParse:" (ftext $1 <> text " not a register") }
803         | GLOBALREG             { return (CmmGlobal $1) }
804
805 maybe_formals :: { Maybe [CmmParse LocalReg] }
806         : {- empty -}           { Nothing }
807         | '(' formals0 ')'      { Just $2 }
808
809 formals0 :: { [CmmParse LocalReg] }
810         : {- empty -}           { [] }
811         | formals               { $1 }
812
813 formals :: { [CmmParse LocalReg] }
814         : formal ','            { [$1] }
815         | formal                { [$1] }
816         | formal ',' formals       { $1 : $3 }
817
818 formal :: { CmmParse LocalReg }
819         : type NAME             { newLocal $1 $2 }
820
821 type    :: { CmmType }
822         : 'bits8'               { b8 }
823         | typenot8              { $1 }
824
825 typenot8 :: { CmmType }
826         : 'bits16'              { b16 }
827         | 'bits32'              { b32 }
828         | 'bits64'              { b64 }
829         | 'bits128'             { b128 }
830         | 'bits256'             { b256 }
831         | 'bits512'             { b512 }
832         | 'float32'             { f32 }
833         | 'float64'             { f64 }
834         | 'gcptr'               {% do dflags <- getDynFlags; return $ gcWord dflags }
835
836 {
837 section :: String -> Section
838 section "text"      = Text
839 section "data"      = Data
840 section "rodata"    = ReadOnlyData
841 section "relrodata" = RelocatableReadOnlyData
842 section "bss"       = UninitialisedData
843 section s           = OtherSection s
844
845 mkString :: String -> CmmStatic
846 mkString s = CmmString (map (fromIntegral.ord) s)
847
848 -- |
849 -- Given an info table, decide what the entry convention for the proc
850 -- is.  That is, for an INFO_TABLE_RET we want the return convention,
851 -- otherwise it is a NativeNodeCall.
852 --
853 infoConv :: Maybe CmmInfoTable -> Convention
854 infoConv Nothing = NativeNodeCall
855 infoConv (Just info)
856   | isStackRep (cit_rep info) = NativeReturn
857   | otherwise                 = NativeNodeCall
858
859 -- mkMachOp infers the type of the MachOp from the type of its first
860 -- argument.  We assume that this is correct: for MachOps that don't have
861 -- symmetrical args (e.g. shift ops), the first arg determines the type of
862 -- the op.
863 mkMachOp :: (Width -> MachOp) -> [CmmParse CmmExpr] -> CmmParse CmmExpr
864 mkMachOp fn args = do
865   dflags <- getDynFlags
866   arg_exprs <- sequence args
867   return (CmmMachOp (fn (typeWidth (cmmExprType dflags (head arg_exprs)))) arg_exprs)
868
869 getLit :: CmmExpr -> CmmLit
870 getLit (CmmLit l) = l
871 getLit (CmmMachOp (MO_S_Neg _) [CmmLit (CmmInt i r)])  = CmmInt (negate i) r
872 getLit _ = panic "invalid literal" -- TODO messy failure
873
874 nameToMachOp :: FastString -> P (Width -> MachOp)
875 nameToMachOp name =
876   case lookupUFM machOps name of
877         Nothing -> fail ("unknown primitive " ++ unpackFS name)
878         Just m  -> return m
879
880 exprOp :: FastString -> [CmmParse CmmExpr] -> P (CmmParse CmmExpr)
881 exprOp name args_code = do
882   dflags <- getDynFlags
883   case lookupUFM (exprMacros dflags) name of
884      Just f  -> return $ do
885         args <- sequence args_code
886         return (f args)
887      Nothing -> do
888         mo <- nameToMachOp name
889         return $ mkMachOp mo args_code
890
891 exprMacros :: DynFlags -> UniqFM ([CmmExpr] -> CmmExpr)
892 exprMacros dflags = listToUFM [
893   ( fsLit "ENTRY_CODE",   \ [x] -> entryCode dflags x ),
894   ( fsLit "INFO_PTR",     \ [x] -> closureInfoPtr dflags x ),
895   ( fsLit "STD_INFO",     \ [x] -> infoTable dflags x ),
896   ( fsLit "FUN_INFO",     \ [x] -> funInfoTable dflags x ),
897   ( fsLit "GET_ENTRY",    \ [x] -> entryCode dflags (closureInfoPtr dflags x) ),
898   ( fsLit "GET_STD_INFO", \ [x] -> infoTable dflags (closureInfoPtr dflags x) ),
899   ( fsLit "GET_FUN_INFO", \ [x] -> funInfoTable dflags (closureInfoPtr dflags x) ),
900   ( fsLit "INFO_TYPE",    \ [x] -> infoTableClosureType dflags x ),
901   ( fsLit "INFO_PTRS",    \ [x] -> infoTablePtrs dflags x ),
902   ( fsLit "INFO_NPTRS",   \ [x] -> infoTableNonPtrs dflags x )
903   ]
904
905 -- we understand a subset of C-- primitives:
906 machOps = listToUFM $
907         map (\(x, y) -> (mkFastString x, y)) [
908         ( "add",        MO_Add ),
909         ( "sub",        MO_Sub ),
910         ( "eq",         MO_Eq ),
911         ( "ne",         MO_Ne ),
912         ( "mul",        MO_Mul ),
913         ( "neg",        MO_S_Neg ),
914         ( "quot",       MO_S_Quot ),
915         ( "rem",        MO_S_Rem ),
916         ( "divu",       MO_U_Quot ),
917         ( "modu",       MO_U_Rem ),
918
919         ( "ge",         MO_S_Ge ),
920         ( "le",         MO_S_Le ),
921         ( "gt",         MO_S_Gt ),
922         ( "lt",         MO_S_Lt ),
923
924         ( "geu",        MO_U_Ge ),
925         ( "leu",        MO_U_Le ),
926         ( "gtu",        MO_U_Gt ),
927         ( "ltu",        MO_U_Lt ),
928
929         ( "and",        MO_And ),
930         ( "or",         MO_Or ),
931         ( "xor",        MO_Xor ),
932         ( "com",        MO_Not ),
933         ( "shl",        MO_Shl ),
934         ( "shrl",       MO_U_Shr ),
935         ( "shra",       MO_S_Shr ),
936
937         ( "fadd",       MO_F_Add ),
938         ( "fsub",       MO_F_Sub ),
939         ( "fneg",       MO_F_Neg ),
940         ( "fmul",       MO_F_Mul ),
941         ( "fquot",      MO_F_Quot ),
942
943         ( "feq",        MO_F_Eq ),
944         ( "fne",        MO_F_Ne ),
945         ( "fge",        MO_F_Ge ),
946         ( "fle",        MO_F_Le ),
947         ( "fgt",        MO_F_Gt ),
948         ( "flt",        MO_F_Lt ),
949
950         ( "lobits8",  flip MO_UU_Conv W8  ),
951         ( "lobits16", flip MO_UU_Conv W16 ),
952         ( "lobits32", flip MO_UU_Conv W32 ),
953         ( "lobits64", flip MO_UU_Conv W64 ),
954
955         ( "zx16",     flip MO_UU_Conv W16 ),
956         ( "zx32",     flip MO_UU_Conv W32 ),
957         ( "zx64",     flip MO_UU_Conv W64 ),
958
959         ( "sx16",     flip MO_SS_Conv W16 ),
960         ( "sx32",     flip MO_SS_Conv W32 ),
961         ( "sx64",     flip MO_SS_Conv W64 ),
962
963         ( "f2f32",    flip MO_FF_Conv W32 ),  -- TODO; rounding mode
964         ( "f2f64",    flip MO_FF_Conv W64 ),  -- TODO; rounding mode
965         ( "f2i8",     flip MO_FS_Conv W8 ),
966         ( "f2i16",    flip MO_FS_Conv W16 ),
967         ( "f2i32",    flip MO_FS_Conv W32 ),
968         ( "f2i64",    flip MO_FS_Conv W64 ),
969         ( "i2f32",    flip MO_SF_Conv W32 ),
970         ( "i2f64",    flip MO_SF_Conv W64 )
971         ]
972
973 callishMachOps :: UniqFM ([CmmExpr] -> (CallishMachOp, [CmmExpr]))
974 callishMachOps = listToUFM $
975         map (\(x, y) -> (mkFastString x, y)) [
976         ( "write_barrier", (,) MO_WriteBarrier ),
977         ( "memcpy", memcpyLikeTweakArgs MO_Memcpy ),
978         ( "memset", memcpyLikeTweakArgs MO_Memset ),
979         ( "memmove", memcpyLikeTweakArgs MO_Memmove ),
980
981         ("prefetch0", (,) $ MO_Prefetch_Data 0),
982         ("prefetch1", (,) $ MO_Prefetch_Data 1),
983         ("prefetch2", (,) $ MO_Prefetch_Data 2),
984         ("prefetch3", (,) $ MO_Prefetch_Data 3),
985
986         ( "popcnt8",  (,) $ MO_PopCnt W8  ),
987         ( "popcnt16", (,) $ MO_PopCnt W16 ),
988         ( "popcnt32", (,) $ MO_PopCnt W32 ),
989         ( "popcnt64", (,) $ MO_PopCnt W64 )
990
991         -- ToDo: the rest, maybe
992         -- edit: which rest?
993         -- also: how do we tell CMM Lint how to type check callish macops?
994     ]
995   where
996     memcpyLikeTweakArgs :: (Int -> CallishMachOp) -> [CmmExpr] -> (CallishMachOp, [CmmExpr])
997     memcpyLikeTweakArgs op [] = pgmError "memcpy-like function requires at least one argument"
998     memcpyLikeTweakArgs op args@(_:_) =
999         (op align, args')
1000       where
1001         args' = init args
1002         align = case last args of
1003           CmmLit (CmmInt alignInteger _) -> fromInteger alignInteger
1004           e -> pprPgmError "Non-constant alignment in memcpy-like function:" (ppr e)
1005         -- The alignment of memcpy-ish operations must be a
1006         -- compile-time constant. We verify this here, passing it around
1007         -- in the MO_* constructor. In order to do this, however, we
1008         -- must intercept the arguments in primCall.
1009
1010 parseSafety :: String -> P Safety
1011 parseSafety "safe"   = return PlaySafe
1012 parseSafety "unsafe" = return PlayRisky
1013 parseSafety "interruptible" = return PlayInterruptible
1014 parseSafety str      = fail ("unrecognised safety: " ++ str)
1015
1016 parseCmmHint :: String -> P ForeignHint
1017 parseCmmHint "ptr"    = return AddrHint
1018 parseCmmHint "signed" = return SignedHint
1019 parseCmmHint str      = fail ("unrecognised hint: " ++ str)
1020
1021 -- labels are always pointers, so we might as well infer the hint
1022 inferCmmHint :: CmmExpr -> ForeignHint
1023 inferCmmHint (CmmLit (CmmLabel _)) = AddrHint
1024 inferCmmHint (CmmReg (CmmGlobal g)) | isPtrGlobalReg g = AddrHint
1025 inferCmmHint _ = NoHint
1026
1027 isPtrGlobalReg Sp                    = True
1028 isPtrGlobalReg SpLim                 = True
1029 isPtrGlobalReg Hp                    = True
1030 isPtrGlobalReg HpLim                 = True
1031 isPtrGlobalReg CCCS                  = True
1032 isPtrGlobalReg CurrentTSO            = True
1033 isPtrGlobalReg CurrentNursery        = True
1034 isPtrGlobalReg (VanillaReg _ VGcPtr) = True
1035 isPtrGlobalReg _                     = False
1036
1037 happyError :: P a
1038 happyError = srcParseFail
1039
1040 -- -----------------------------------------------------------------------------
1041 -- Statement-level macros
1042
1043 stmtMacro :: FastString -> [CmmParse CmmExpr] -> P (CmmParse ())
1044 stmtMacro fun args_code = do
1045   case lookupUFM stmtMacros fun of
1046     Nothing -> fail ("unknown macro: " ++ unpackFS fun)
1047     Just fcode -> return $ do
1048         args <- sequence args_code
1049         code (fcode args)
1050
1051 stmtMacros :: UniqFM ([CmmExpr] -> FCode ())
1052 stmtMacros = listToUFM [
1053   ( fsLit "CCS_ALLOC",             \[words,ccs]  -> profAlloc words ccs ),
1054   ( fsLit "ENTER_CCS_THUNK",       \[e] -> enterCostCentreThunk e ),
1055
1056   ( fsLit "CLOSE_NURSERY",         \[]  -> emitCloseNursery ),
1057   ( fsLit "OPEN_NURSERY",          \[]  -> emitOpenNursery ),
1058
1059   -- completely generic heap and stack checks, for use in high-level cmm.
1060   ( fsLit "HP_CHK_GEN",            \[bytes] ->
1061                                       heapStackCheckGen Nothing (Just bytes) ),
1062   ( fsLit "STK_CHK_GEN",           \[] ->
1063                                       heapStackCheckGen (Just (CmmLit CmmHighStackMark)) Nothing ),
1064
1065   -- A stack check for a fixed amount of stack.  Sounds a bit strange, but
1066   -- we use the stack for a bit of temporary storage in a couple of primops
1067   ( fsLit "STK_CHK_GEN_N",         \[bytes] ->
1068                                       heapStackCheckGen (Just bytes) Nothing ),
1069
1070   -- A stack check on entry to a thunk, where the argument is the thunk pointer.
1071   ( fsLit "STK_CHK_NP"   ,         \[node] -> entryHeapCheck' False node 0 [] (return ())),
1072
1073   ( fsLit "LOAD_THREAD_STATE",     \[] -> emitLoadThreadState ),
1074   ( fsLit "SAVE_THREAD_STATE",     \[] -> emitSaveThreadState ),
1075
1076   ( fsLit "LDV_ENTER",             \[e] -> ldvEnter e ),
1077   ( fsLit "LDV_RECORD_CREATE",     \[e] -> ldvRecordCreate e ),
1078
1079   ( fsLit "PUSH_UPD_FRAME",        \[sp,e] -> emitPushUpdateFrame sp e ),
1080   ( fsLit "SET_HDR",               \[ptr,info,ccs] ->
1081                                         emitSetDynHdr ptr info ccs ),
1082   ( fsLit "TICK_ALLOC_PRIM",       \[hdr,goods,slop] ->
1083                                         tickyAllocPrim hdr goods slop ),
1084   ( fsLit "TICK_ALLOC_PAP",        \[goods,slop] ->
1085                                         tickyAllocPAP goods slop ),
1086   ( fsLit "TICK_ALLOC_UP_THK",     \[goods,slop] ->
1087                                         tickyAllocThunk goods slop ),
1088   ( fsLit "UPD_BH_UPDATABLE",      \[reg] -> emitBlackHoleCode reg )
1089  ]
1090
1091 emitPushUpdateFrame :: CmmExpr -> CmmExpr -> FCode ()
1092 emitPushUpdateFrame sp e = do
1093   dflags <- getDynFlags
1094   emitUpdateFrame dflags sp mkUpdInfoLabel e
1095
1096 pushStackFrame :: [CmmParse CmmExpr] -> CmmParse () -> CmmParse ()
1097 pushStackFrame fields body = do
1098   dflags <- getDynFlags
1099   exprs <- sequence fields
1100   updfr_off <- getUpdFrameOff
1101   let (new_updfr_off, _, g) = copyOutOflow dflags NativeReturn Ret Old
1102                                            [] updfr_off exprs
1103   emit g
1104   withUpdFrameOff new_updfr_off body
1105
1106 reserveStackFrame
1107   :: CmmParse CmmExpr
1108   -> CmmParse CmmReg
1109   -> CmmParse ()
1110   -> CmmParse ()
1111 reserveStackFrame psize preg body = do
1112   dflags <- getDynFlags
1113   old_updfr_off <- getUpdFrameOff
1114   reg <- preg
1115   esize <- psize
1116   let size = case constantFoldExpr dflags esize of
1117                CmmLit (CmmInt n _) -> n
1118                _other -> pprPanic "CmmParse: not a compile-time integer: "
1119                             (ppr esize)
1120   let frame = old_updfr_off + wORD_SIZE dflags * fromIntegral size
1121   emitAssign reg (CmmStackSlot Old frame)
1122   withUpdFrameOff frame body
1123
1124 profilingInfo dflags desc_str ty_str
1125   = if not (gopt Opt_SccProfilingOn dflags)
1126     then NoProfilingInfo
1127     else ProfilingInfo (stringToWord8s desc_str)
1128                        (stringToWord8s ty_str)
1129
1130 staticClosure :: UnitId -> FastString -> FastString -> [CmmLit] -> CmmParse ()
1131 staticClosure pkg cl_label info payload
1132   = do dflags <- getDynFlags
1133        let lits = mkStaticClosure dflags (mkCmmInfoLabel pkg info) dontCareCCS payload [] [] []
1134        code $ emitDataLits (mkCmmDataLabel pkg cl_label) lits
1135
1136 foreignCall
1137         :: String
1138         -> [CmmParse (LocalReg, ForeignHint)]
1139         -> CmmParse CmmExpr
1140         -> [CmmParse (CmmExpr, ForeignHint)]
1141         -> Safety
1142         -> CmmReturnInfo
1143         -> P (CmmParse ())
1144 foreignCall conv_string results_code expr_code args_code safety ret
1145   = do  conv <- case conv_string of
1146           "C" -> return CCallConv
1147           "stdcall" -> return StdCallConv
1148           _ -> fail ("unknown calling convention: " ++ conv_string)
1149         return $ do
1150           dflags <- getDynFlags
1151           results <- sequence results_code
1152           expr <- expr_code
1153           args <- sequence args_code
1154           let
1155                   expr' = adjCallTarget dflags conv expr args
1156                   (arg_exprs, arg_hints) = unzip args
1157                   (res_regs,  res_hints) = unzip results
1158                   fc = ForeignConvention conv arg_hints res_hints ret
1159                   target = ForeignTarget expr' fc
1160           _ <- code $ emitForeignCall safety res_regs target arg_exprs
1161           return ()
1162
1163
1164 doReturn :: [CmmParse CmmExpr] -> CmmParse ()
1165 doReturn exprs_code = do
1166   dflags <- getDynFlags
1167   exprs <- sequence exprs_code
1168   updfr_off <- getUpdFrameOff
1169   emit (mkReturnSimple dflags exprs updfr_off)
1170
1171 mkReturnSimple  :: DynFlags -> [CmmActual] -> UpdFrameOffset -> CmmAGraph
1172 mkReturnSimple dflags actuals updfr_off =
1173   mkReturn dflags e actuals updfr_off
1174   where e = entryCode dflags (CmmLoad (CmmStackSlot Old updfr_off)
1175                              (gcWord dflags))
1176
1177 doRawJump :: CmmParse CmmExpr -> [GlobalReg] -> CmmParse ()
1178 doRawJump expr_code vols = do
1179   dflags <- getDynFlags
1180   expr <- expr_code
1181   updfr_off <- getUpdFrameOff
1182   emit (mkRawJump dflags expr updfr_off vols)
1183
1184 doJumpWithStack :: CmmParse CmmExpr -> [CmmParse CmmExpr]
1185                 -> [CmmParse CmmExpr] -> CmmParse ()
1186 doJumpWithStack expr_code stk_code args_code = do
1187   dflags <- getDynFlags
1188   expr <- expr_code
1189   stk_args <- sequence stk_code
1190   args <- sequence args_code
1191   updfr_off <- getUpdFrameOff
1192   emit (mkJumpExtra dflags NativeNodeCall expr args updfr_off stk_args)
1193
1194 doCall :: CmmParse CmmExpr -> [CmmParse LocalReg] -> [CmmParse CmmExpr]
1195        -> CmmParse ()
1196 doCall expr_code res_code args_code = do
1197   dflags <- getDynFlags
1198   expr <- expr_code
1199   args <- sequence args_code
1200   ress <- sequence res_code
1201   updfr_off <- getUpdFrameOff
1202   c <- code $ mkCall expr (NativeNodeCall,NativeReturn) ress args updfr_off []
1203   emit c
1204
1205 adjCallTarget :: DynFlags -> CCallConv -> CmmExpr -> [(CmmExpr, ForeignHint) ]
1206               -> CmmExpr
1207 -- On Windows, we have to add the '@N' suffix to the label when making
1208 -- a call with the stdcall calling convention.
1209 adjCallTarget dflags StdCallConv (CmmLit (CmmLabel lbl)) args
1210  | platformOS (targetPlatform dflags) == OSMinGW32
1211   = CmmLit (CmmLabel (addLabelSize lbl (sum (map size args))))
1212   where size (e, _) = max (wORD_SIZE dflags) (widthInBytes (typeWidth (cmmExprType dflags e)))
1213                  -- c.f. CgForeignCall.emitForeignCall
1214 adjCallTarget _ _ expr _
1215   = expr
1216
1217 primCall
1218         :: [CmmParse (CmmFormal, ForeignHint)]
1219         -> FastString
1220         -> [CmmParse CmmExpr]
1221         -> P (CmmParse ())
1222 primCall results_code name args_code
1223   = case lookupUFM callishMachOps name of
1224         Nothing -> fail ("unknown primitive " ++ unpackFS name)
1225         Just f  -> return $ do
1226                 results <- sequence results_code
1227                 args <- sequence args_code
1228                 let (p, args') = f args
1229                 code (emitPrimCall (map fst results) p args')
1230
1231 doStore :: CmmType -> CmmParse CmmExpr  -> CmmParse CmmExpr -> CmmParse ()
1232 doStore rep addr_code val_code
1233   = do dflags <- getDynFlags
1234        addr <- addr_code
1235        val <- val_code
1236         -- if the specified store type does not match the type of the expr
1237         -- on the rhs, then we insert a coercion that will cause the type
1238         -- mismatch to be flagged by cmm-lint.  If we don't do this, then
1239         -- the store will happen at the wrong type, and the error will not
1240         -- be noticed.
1241        let val_width = typeWidth (cmmExprType dflags val)
1242            rep_width = typeWidth rep
1243        let coerce_val
1244                 | val_width /= rep_width = CmmMachOp (MO_UU_Conv val_width rep_width) [val]
1245                 | otherwise              = val
1246        emitStore addr coerce_val
1247
1248 -- -----------------------------------------------------------------------------
1249 -- If-then-else and boolean expressions
1250
1251 data BoolExpr
1252   = BoolExpr `BoolAnd` BoolExpr
1253   | BoolExpr `BoolOr`  BoolExpr
1254   | BoolNot BoolExpr
1255   | BoolTest CmmExpr
1256
1257 -- ToDo: smart constructors which simplify the boolean expression.
1258
1259 cmmIfThenElse cond then_part else_part = do
1260      then_id <- newBlockId
1261      join_id <- newBlockId
1262      c <- cond
1263      emitCond c then_id
1264      else_part
1265      emit (mkBranch join_id)
1266      emitLabel then_id
1267      then_part
1268      -- fall through to join
1269      emitLabel join_id
1270
1271 cmmRawIf cond then_id = do
1272     c <- cond
1273     emitCond c then_id
1274
1275 -- 'emitCond cond true_id'  emits code to test whether the cond is true,
1276 -- branching to true_id if so, and falling through otherwise.
1277 emitCond (BoolTest e) then_id = do
1278   else_id <- newBlockId
1279   emit (mkCbranch e then_id else_id Nothing)
1280   emitLabel else_id
1281 emitCond (BoolNot (BoolTest (CmmMachOp op args))) then_id
1282   | Just op' <- maybeInvertComparison op
1283   = emitCond (BoolTest (CmmMachOp op' args)) then_id
1284 emitCond (BoolNot e) then_id = do
1285   else_id <- newBlockId
1286   emitCond e else_id
1287   emit (mkBranch then_id)
1288   emitLabel else_id
1289 emitCond (e1 `BoolOr` e2) then_id = do
1290   emitCond e1 then_id
1291   emitCond e2 then_id
1292 emitCond (e1 `BoolAnd` e2) then_id = do
1293         -- we'd like to invert one of the conditionals here to avoid an
1294         -- extra branch instruction, but we can't use maybeInvertComparison
1295         -- here because we can't look too closely at the expression since
1296         -- we're in a loop.
1297   and_id <- newBlockId
1298   else_id <- newBlockId
1299   emitCond e1 and_id
1300   emit (mkBranch else_id)
1301   emitLabel and_id
1302   emitCond e2 then_id
1303   emitLabel else_id
1304
1305 -- -----------------------------------------------------------------------------
1306 -- Source code notes
1307
1308 -- | Generate a source note spanning from "a" to "b" (inclusive), then
1309 -- proceed with parsing. This allows debugging tools to reason about
1310 -- locations in Cmm code.
1311 withSourceNote :: Located a -> Located b -> CmmParse c -> CmmParse c
1312 withSourceNote a b parse = do
1313   name <- getName
1314   case combineSrcSpans (getLoc a) (getLoc b) of
1315     RealSrcSpan span -> code (emitTick (SourceNote span name)) >> parse
1316     _other           -> parse
1317
1318 -- -----------------------------------------------------------------------------
1319 -- Table jumps
1320
1321 -- We use a simplified form of C-- switch statements for now.  A
1322 -- switch statement always compiles to a table jump.  Each arm can
1323 -- specify a list of values (not ranges), and there can be a single
1324 -- default branch.  The range of the table is given either by the
1325 -- optional range on the switch (eg. switch [0..7] {...}), or by
1326 -- the minimum/maximum values from the branches.
1327
1328 doSwitch :: Maybe (Integer,Integer)
1329          -> CmmParse CmmExpr
1330          -> [([Integer],Either BlockId (CmmParse ()))]
1331          -> Maybe (CmmParse ()) -> CmmParse ()
1332 doSwitch mb_range scrut arms deflt
1333    = do
1334         -- Compile code for the default branch
1335         dflt_entry <- 
1336                 case deflt of
1337                   Nothing -> return Nothing
1338                   Just e  -> do b <- forkLabelledCode e; return (Just b)
1339
1340         -- Compile each case branch
1341         table_entries <- mapM emitArm arms
1342         let table = M.fromList (concat table_entries)
1343
1344         dflags <- getDynFlags
1345         let range = fromMaybe (0, tARGET_MAX_WORD dflags) mb_range
1346
1347         expr <- scrut
1348         -- ToDo: check for out of range and jump to default if necessary
1349         emit $ mkSwitch expr (mkSwitchTargets False range dflt_entry table)
1350    where
1351         emitArm :: ([Integer],Either BlockId (CmmParse ())) -> CmmParse [(Integer,BlockId)]
1352         emitArm (ints,Left blockid) = return [ (i,blockid) | i <- ints ]
1353         emitArm (ints,Right code) = do
1354            blockid <- forkLabelledCode code
1355            return [ (i,blockid) | i <- ints ]
1356
1357 forkLabelledCode :: CmmParse () -> CmmParse BlockId
1358 forkLabelledCode p = do
1359   (_,ag) <- getCodeScoped p
1360   l <- newBlockId
1361   emitOutOfLine l ag
1362   return l
1363
1364 -- -----------------------------------------------------------------------------
1365 -- Putting it all together
1366
1367 -- The initial environment: we define some constants that the compiler
1368 -- knows about here.
1369 initEnv :: DynFlags -> Env
1370 initEnv dflags = listToUFM [
1371   ( fsLit "SIZEOF_StgHeader",
1372     VarN (CmmLit (CmmInt (fromIntegral (fixedHdrSize dflags)) (wordWidth dflags)) )),
1373   ( fsLit "SIZEOF_StgInfoTable",
1374     VarN (CmmLit (CmmInt (fromIntegral (stdInfoTableSizeB dflags)) (wordWidth dflags)) ))
1375   ]
1376
1377 parseCmmFile :: DynFlags -> FilePath -> IO (Messages, Maybe CmmGroup)
1378 parseCmmFile dflags filename = do
1379   showPass dflags "ParseCmm"
1380   buf <- hGetStringBuffer filename
1381   let
1382         init_loc = mkRealSrcLoc (mkFastString filename) 1 1
1383         init_state = (mkPState dflags buf init_loc) { lex_state = [0] }
1384                 -- reset the lex_state: the Lexer monad leaves some stuff
1385                 -- in there we don't want.
1386   case unP cmmParse init_state of
1387     PFailed span err -> do
1388         let msg = mkPlainErrMsg dflags span err
1389         return ((emptyBag, unitBag msg), Nothing)
1390     POk pst code -> do
1391         st <- initC
1392         let fcode = getCmm $ unEC code "global" (initEnv dflags) [] >> return ()
1393             (cmm,_) = runC dflags no_module st fcode
1394         let ms = getMessages pst
1395         if (errorsFound dflags ms)
1396          then return (ms, Nothing)
1397          else do
1398            dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (ppr cmm)
1399            return (ms, Just cmm)
1400   where
1401         no_module = panic "parseCmmFile: no module"
1402 }