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