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