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