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