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