Merge branch 'master' of http://darcs.haskell.org/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 doRawJump :: CmmParse CmmExpr -> [GlobalReg] -> CmmParse ()
1069 doRawJump expr_code vols = do
1070   dflags <- getDynFlags
1071   expr <- expr_code
1072   updfr_off <- getUpdFrameOff
1073   emit (mkRawJump dflags expr updfr_off vols)
1074
1075 doJumpWithStack :: CmmParse CmmExpr -> [CmmParse CmmExpr]
1076                 -> [CmmParse CmmExpr] -> CmmParse ()
1077 doJumpWithStack expr_code stk_code args_code = do
1078   dflags <- getDynFlags
1079   expr <- expr_code
1080   stk_args <- sequence stk_code
1081   args <- sequence args_code
1082   updfr_off <- getUpdFrameOff
1083   emit (mkJumpExtra dflags expr args updfr_off stk_args)
1084
1085 doCall :: CmmParse CmmExpr -> [CmmParse LocalReg] -> [CmmParse CmmExpr]
1086        -> CmmParse ()
1087 doCall expr_code res_code args_code = do
1088   dflags <- getDynFlags
1089   expr <- expr_code
1090   args <- sequence args_code
1091   ress <- sequence res_code
1092   updfr_off <- getUpdFrameOff
1093   c <- code $ mkCall expr (NativeNodeCall,NativeReturn) ress args updfr_off []
1094   emit c
1095
1096 adjCallTarget :: DynFlags -> CCallConv -> CmmExpr -> [(CmmExpr, ForeignHint) ]
1097               -> CmmExpr
1098 -- On Windows, we have to add the '@N' suffix to the label when making
1099 -- a call with the stdcall calling convention.
1100 adjCallTarget dflags StdCallConv (CmmLit (CmmLabel lbl)) args
1101  | platformOS (targetPlatform dflags) == OSMinGW32
1102   = CmmLit (CmmLabel (addLabelSize lbl (sum (map size args))))
1103   where size (e, _) = max (wORD_SIZE dflags) (widthInBytes (typeWidth (cmmExprType dflags e)))
1104                  -- c.f. CgForeignCall.emitForeignCall
1105 adjCallTarget _ _ expr _
1106   = expr
1107
1108 primCall
1109         :: [CmmParse (CmmFormal, ForeignHint)]
1110         -> FastString
1111         -> [CmmParse CmmExpr]
1112         -> P (CmmParse ())
1113 primCall results_code name args_code
1114   = case lookupUFM callishMachOps name of
1115         Nothing -> fail ("unknown primitive " ++ unpackFS name)
1116         Just p  -> return $ do
1117                 results <- sequence results_code
1118                 args <- sequence args_code
1119                 code (emitPrimCall (map fst results) p args)
1120
1121 doStore :: CmmType -> CmmParse CmmExpr  -> CmmParse CmmExpr -> CmmParse ()
1122 doStore rep addr_code val_code
1123   = do dflags <- getDynFlags
1124        addr <- addr_code
1125        val <- val_code
1126         -- if the specified store type does not match the type of the expr
1127         -- on the rhs, then we insert a coercion that will cause the type
1128         -- mismatch to be flagged by cmm-lint.  If we don't do this, then
1129         -- the store will happen at the wrong type, and the error will not
1130         -- be noticed.
1131        let val_width = typeWidth (cmmExprType dflags val)
1132            rep_width = typeWidth rep
1133        let coerce_val
1134                 | val_width /= rep_width = CmmMachOp (MO_UU_Conv val_width rep_width) [val]
1135                 | otherwise              = val
1136        emitStore addr coerce_val
1137
1138 -- -----------------------------------------------------------------------------
1139 -- If-then-else and boolean expressions
1140
1141 data BoolExpr
1142   = BoolExpr `BoolAnd` BoolExpr
1143   | BoolExpr `BoolOr`  BoolExpr
1144   | BoolNot BoolExpr
1145   | BoolTest CmmExpr
1146
1147 -- ToDo: smart constructors which simplify the boolean expression.
1148
1149 cmmIfThenElse cond then_part else_part = do
1150      then_id <- newBlockId
1151      join_id <- newBlockId
1152      c <- cond
1153      emitCond c then_id
1154      else_part
1155      emit (mkBranch join_id)
1156      emitLabel then_id
1157      then_part
1158      -- fall through to join
1159      emitLabel join_id
1160
1161 cmmRawIf cond then_id = do
1162     c <- cond
1163     emitCond c then_id
1164
1165 -- 'emitCond cond true_id'  emits code to test whether the cond is true,
1166 -- branching to true_id if so, and falling through otherwise.
1167 emitCond (BoolTest e) then_id = do
1168   else_id <- newBlockId
1169   emit (mkCbranch e then_id else_id)
1170   emitLabel else_id
1171 emitCond (BoolNot (BoolTest (CmmMachOp op args))) then_id
1172   | Just op' <- maybeInvertComparison op
1173   = emitCond (BoolTest (CmmMachOp op' args)) then_id
1174 emitCond (BoolNot e) then_id = do
1175   else_id <- newBlockId
1176   emitCond e else_id
1177   emit (mkBranch then_id)
1178   emitLabel else_id
1179 emitCond (e1 `BoolOr` e2) then_id = do
1180   emitCond e1 then_id
1181   emitCond e2 then_id
1182 emitCond (e1 `BoolAnd` e2) then_id = do
1183         -- we'd like to invert one of the conditionals here to avoid an
1184         -- extra branch instruction, but we can't use maybeInvertComparison
1185         -- here because we can't look too closely at the expression since
1186         -- we're in a loop.
1187   and_id <- newBlockId
1188   else_id <- newBlockId
1189   emitCond e1 and_id
1190   emit (mkBranch else_id)
1191   emitLabel and_id
1192   emitCond e2 then_id
1193   emitLabel else_id
1194
1195
1196 -- -----------------------------------------------------------------------------
1197 -- Table jumps
1198
1199 -- We use a simplified form of C-- switch statements for now.  A
1200 -- switch statement always compiles to a table jump.  Each arm can
1201 -- specify a list of values (not ranges), and there can be a single
1202 -- default branch.  The range of the table is given either by the
1203 -- optional range on the switch (eg. switch [0..7] {...}), or by
1204 -- the minimum/maximum values from the branches.
1205
1206 doSwitch :: Maybe (Int,Int) -> CmmParse CmmExpr -> [([Int],Either BlockId (CmmParse ()))]
1207          -> Maybe (CmmParse ()) -> CmmParse ()
1208 doSwitch mb_range scrut arms deflt
1209    = do
1210         -- Compile code for the default branch
1211         dflt_entry <- 
1212                 case deflt of
1213                   Nothing -> return Nothing
1214                   Just e  -> do b <- forkLabelledCode e; return (Just b)
1215
1216         -- Compile each case branch
1217         table_entries <- mapM emitArm arms
1218
1219         -- Construct the table
1220         let
1221             all_entries = concat table_entries
1222             ixs = map fst all_entries
1223             (min,max) 
1224                 | Just (l,u) <- mb_range = (l,u)
1225                 | otherwise              = (minimum ixs, maximum ixs)
1226
1227             entries = elems (accumArray (\_ a -> Just a) dflt_entry (min,max)
1228                                 all_entries)
1229         expr <- scrut
1230         -- ToDo: check for out of range and jump to default if necessary
1231         emit (mkSwitch expr entries)
1232    where
1233         emitArm :: ([Int],Either BlockId (CmmParse ())) -> CmmParse [(Int,BlockId)]
1234         emitArm (ints,Left blockid) = return [ (i,blockid) | i <- ints ]
1235         emitArm (ints,Right code) = do
1236            blockid <- forkLabelledCode code
1237            return [ (i,blockid) | i <- ints ]
1238
1239 forkLabelledCode :: CmmParse () -> CmmParse BlockId
1240 forkLabelledCode p = do
1241   ag <- getCode p
1242   l <- newBlockId
1243   emitOutOfLine l ag
1244   return l
1245
1246 -- -----------------------------------------------------------------------------
1247 -- Putting it all together
1248
1249 -- The initial environment: we define some constants that the compiler
1250 -- knows about here.
1251 initEnv :: DynFlags -> Env
1252 initEnv dflags = listToUFM [
1253   ( fsLit "SIZEOF_StgHeader",
1254     VarN (CmmLit (CmmInt (fromIntegral (fixedHdrSize dflags * wORD_SIZE dflags)) (wordWidth dflags)) )),
1255   ( fsLit "SIZEOF_StgInfoTable",
1256     VarN (CmmLit (CmmInt (fromIntegral (stdInfoTableSizeB dflags)) (wordWidth dflags)) ))
1257   ]
1258
1259 parseCmmFile :: DynFlags -> FilePath -> IO (Messages, Maybe CmmGroup)
1260 parseCmmFile dflags filename = do
1261   showPass dflags "ParseCmm"
1262   buf <- hGetStringBuffer filename
1263   let
1264         init_loc = mkRealSrcLoc (mkFastString filename) 1 1
1265         init_state = (mkPState dflags buf init_loc) { lex_state = [0] }
1266                 -- reset the lex_state: the Lexer monad leaves some stuff
1267                 -- in there we don't want.
1268   case unP cmmParse init_state of
1269     PFailed span err -> do
1270         let msg = mkPlainErrMsg dflags span err
1271         return ((emptyBag, unitBag msg), Nothing)
1272     POk pst code -> do
1273         st <- initC
1274         let (cmm,_) = runC dflags no_module st (getCmm (unEC code (initEnv dflags) [] >> return ()))
1275         let ms = getMessages pst
1276         if (errorsFound dflags ms)
1277          then return (ms, Nothing)
1278          else do
1279            dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (ppr cmm)
1280            return (ms, Just cmm)
1281   where
1282         no_module = panic "parseCmmFile: no module"
1283 }