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