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