Snapshot of codegen refactoring to share with simonpj
[ghc.git] / compiler / cmm / CmmParse.y
1 -----------------------------------------------------------------------------
2 --
3 -- (c) The University of Glasgow, 2004-2006
4 --
5 -- Parser for concrete Cmm.
6 -- This doesn't just parse the Cmm file, we also do some code generation
7 -- along the way for switches and foreign calls etc.
8 --
9 -----------------------------------------------------------------------------
10
11 -- TODO: Add support for interruptible/uninterruptible foreign call specification
12
13 {
14 {-# LANGUAGE BangPatterns #-} -- required for versions of Happy before 1.18.6
15 {-# OPTIONS -Wwarn -w #-}
16 -- The above warning supression flag is a temporary kludge.
17 -- While working on this module you are encouraged to remove it and fix
18 -- any warnings in the module. See
19 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
20 -- for details
21
22 module CmmParse ( parseCmmFile ) where
23
24 import CgMonad          hiding (getDynFlags)
25 import CgExtCode
26 import CgHeapery
27 import CgUtils
28 import CgProf
29 import CgTicky
30 import CgInfoTbls
31 import CgForeignCall
32 import CgTailCall
33 import CgStackery
34 import ClosureInfo
35 import CgCallConv
36 import CgClosure
37 import CostCentre
38
39 import BlockId
40 import OldCmm
41 import OldPprCmm()
42 import CmmUtils
43 import CmmLex
44 import CLabel
45 import SMRep
46 import Lexer
47
48 import ForeignCall
49 import Module
50 import Literal
51 import Unique
52 import UniqFM
53 import SrcLoc
54 import DynFlags
55 import StaticFlags
56 import ErrUtils
57 import StringBuffer
58 import FastString
59 import Panic
60 import Constants
61 import Outputable
62 import BasicTypes
63 import Bag              ( emptyBag, unitBag )
64 import Var
65
66 import Control.Monad
67 import Data.Array
68 import Data.Char        ( ord )
69 import System.Exit
70
71 #include "HsVersions.h"
72 }
73
74 %expect 0
75
76 %token
77         ':'     { L _ (CmmT_SpecChar ':') }
78         ';'     { L _ (CmmT_SpecChar ';') }
79         '{'     { L _ (CmmT_SpecChar '{') }
80         '}'     { L _ (CmmT_SpecChar '}') }
81         '['     { L _ (CmmT_SpecChar '[') }
82         ']'     { L _ (CmmT_SpecChar ']') }
83         '('     { L _ (CmmT_SpecChar '(') }
84         ')'     { L _ (CmmT_SpecChar ')') }
85         '='     { L _ (CmmT_SpecChar '=') }
86         '`'     { L _ (CmmT_SpecChar '`') }
87         '~'     { L _ (CmmT_SpecChar '~') }
88         '/'     { L _ (CmmT_SpecChar '/') }
89         '*'     { L _ (CmmT_SpecChar '*') }
90         '%'     { L _ (CmmT_SpecChar '%') }
91         '-'     { L _ (CmmT_SpecChar '-') }
92         '+'     { L _ (CmmT_SpecChar '+') }
93         '&'     { L _ (CmmT_SpecChar '&') }
94         '^'     { L _ (CmmT_SpecChar '^') }
95         '|'     { L _ (CmmT_SpecChar '|') }
96         '>'     { L _ (CmmT_SpecChar '>') }
97         '<'     { L _ (CmmT_SpecChar '<') }
98         ','     { L _ (CmmT_SpecChar ',') }
99         '!'     { L _ (CmmT_SpecChar '!') }
100
101         '..'    { L _ (CmmT_DotDot) }
102         '::'    { L _ (CmmT_DoubleColon) }
103         '>>'    { L _ (CmmT_Shr) }
104         '<<'    { L _ (CmmT_Shl) }
105         '>='    { L _ (CmmT_Ge) }
106         '<='    { L _ (CmmT_Le) }
107         '=='    { L _ (CmmT_Eq) }
108         '!='    { L _ (CmmT_Ne) }
109         '&&'    { L _ (CmmT_BoolAnd) }
110         '||'    { L _ (CmmT_BoolOr) }
111
112         'CLOSURE'       { L _ (CmmT_CLOSURE) }
113         'INFO_TABLE'    { L _ (CmmT_INFO_TABLE) }
114         'INFO_TABLE_RET'{ L _ (CmmT_INFO_TABLE_RET) }
115         'INFO_TABLE_FUN'{ L _ (CmmT_INFO_TABLE_FUN) }
116         'INFO_TABLE_CONSTR'{ L _ (CmmT_INFO_TABLE_CONSTR) }
117         'INFO_TABLE_SELECTOR'{ L _ (CmmT_INFO_TABLE_SELECTOR) }
118         'else'          { L _ (CmmT_else) }
119         'export'        { L _ (CmmT_export) }
120         'section'       { L _ (CmmT_section) }
121         'align'         { L _ (CmmT_align) }
122         'goto'          { L _ (CmmT_goto) }
123         'if'            { L _ (CmmT_if) }
124         'jump'          { L _ (CmmT_jump) }
125         'foreign'       { L _ (CmmT_foreign) }
126         'never'         { L _ (CmmT_never) }
127         'prim'          { L _ (CmmT_prim) }
128         'return'        { L _ (CmmT_return) }
129         'returns'       { L _ (CmmT_returns) }
130         'import'        { L _ (CmmT_import) }
131         'switch'        { L _ (CmmT_switch) }
132         'case'          { L _ (CmmT_case) }
133         'default'       { L _ (CmmT_default) }
134         'bits8'         { L _ (CmmT_bits8) }
135         'bits16'        { L _ (CmmT_bits16) }
136         'bits32'        { L _ (CmmT_bits32) }
137         'bits64'        { L _ (CmmT_bits64) }
138         'float32'       { L _ (CmmT_float32) }
139         'float64'       { L _ (CmmT_float64) }
140         'gcptr'         { L _ (CmmT_gcptr) }
141
142         GLOBALREG       { L _ (CmmT_GlobalReg   $$) }
143         NAME            { L _ (CmmT_Name        $$) }
144         STRING          { L _ (CmmT_String      $$) }
145         INT             { L _ (CmmT_Int         $$) }
146         FLOAT           { L _ (CmmT_Float       $$) }
147
148 %monad { P } { >>= } { return }
149 %lexer { cmmlex } { L _ CmmT_EOF }
150 %name cmmParse cmm
151 %tokentype { Located CmmToken }
152
153 -- C-- operator precedences, taken from the C-- spec
154 %right '||'     -- non-std extension, called %disjoin in C--
155 %right '&&'     -- non-std extension, called %conjoin in C--
156 %right '!'
157 %nonassoc '>=' '>' '<=' '<' '!=' '=='
158 %left '|'
159 %left '^'
160 %left '&'
161 %left '>>' '<<'
162 %left '-' '+'
163 %left '/' '*' '%'
164 %right '~'
165
166 %%
167
168 cmm     :: { ExtCode }
169         : {- empty -}                   { return () }
170         | cmmtop cmm                    { do $1; $2 }
171
172 cmmtop  :: { ExtCode }
173         : cmmproc                       { $1 }
174         | cmmdata                       { $1 }
175         | decl                          { $1 } 
176         | 'CLOSURE' '(' NAME ',' NAME lits ')' ';'  
177                 {% withThisPackage $ \pkg -> 
178                    do lits <- sequence $6;
179                       staticClosure pkg $3 $5 (map getLit lits) }
180
181 -- The only static closures in the RTS are dummy closures like
182 -- stg_END_TSO_QUEUE_closure and stg_dummy_ret.  We don't need
183 -- to provide the full generality of static closures here.
184 -- In particular:
185 --      * CCS can always be CCS_DONT_CARE
186 --      * closure is always extern
187 --      * payload is always empty
188 --      * we can derive closure and info table labels from a single NAME
189
190 cmmdata :: { ExtCode }
191         : 'section' STRING '{' data_label statics '}' 
192                 { do lbl <- $4;
193                      ss <- sequence $5;
194                      code (emitDecl (CmmData (section $2) (Statics lbl $ concat ss))) }
195
196 data_label :: { ExtFCode CLabel }
197     : NAME ':'  
198                 {% withThisPackage $ \pkg -> 
199                    return (mkCmmDataLabel pkg $1) }
200
201 statics :: { [ExtFCode [CmmStatic]] }
202         : {- empty -}                   { [] }
203         | static statics                { $1 : $2 }
204     
205 -- Strings aren't used much in the RTS HC code, so it doesn't seem
206 -- worth allowing inline strings.  C-- doesn't allow them anyway.
207 static  :: { ExtFCode [CmmStatic] }
208         : type expr ';' { do e <- $2;
209                              return [CmmStaticLit (getLit e)] }
210         | type ';'                      { return [CmmUninitialised
211                                                         (widthInBytes (typeWidth $1))] }
212         | 'bits8' '[' ']' STRING ';'    { return [mkString $4] }
213         | 'bits8' '[' INT ']' ';'       { return [CmmUninitialised 
214                                                         (fromIntegral $3)] }
215         | typenot8 '[' INT ']' ';'      { return [CmmUninitialised 
216                                                 (widthInBytes (typeWidth $1) * 
217                                                         fromIntegral $3)] }
218         | 'CLOSURE' '(' NAME lits ')'
219                 { do lits <- sequence $4;
220                      return $ map CmmStaticLit $
221                        mkStaticClosure (mkForeignLabel $3 Nothing ForeignLabelInExternalPackage IsData)
222                          -- mkForeignLabel because these are only used
223                          -- for CHARLIKE and INTLIKE closures in the RTS.
224                          dontCareCCS (map getLit lits) [] [] [] }
225         -- arrays of closures required for the CHARLIKE & INTLIKE arrays
226
227 lits    :: { [ExtFCode CmmExpr] }
228         : {- empty -}           { [] }
229         | ',' expr lits         { $2 : $3 }
230
231 cmmproc :: { ExtCode }
232 -- TODO: add real SRT/info tables to parsed Cmm
233         : info maybe_formals_without_hints maybe_gc_block maybe_frame '{' body '}'
234                 { do ((entry_ret_label, info, live, formals, gc_block, frame), stmts) <-
235                        getCgStmtsEC' $ loopDecls $ do {
236                          (entry_ret_label, info, live) <- $1;
237                          formals <- sequence $2;
238                          gc_block <- $3;
239                          frame <- $4;
240                          $6;
241                          return (entry_ret_label, info, live, formals, gc_block, frame) }
242                      blks <- code (cgStmtsToBlocks stmts)
243                      code (emitInfoTableAndCode entry_ret_label (CmmInfo gc_block frame info) formals blks) }
244
245         | info maybe_formals_without_hints ';'
246                 { do (entry_ret_label, info, live) <- $1;
247                      formals <- sequence $2;
248                      code (emitInfoTableAndCode entry_ret_label (CmmInfo Nothing Nothing info) formals []) }
249
250         | NAME maybe_formals_without_hints maybe_gc_block maybe_frame '{' body '}'
251                 {% withThisPackage $ \pkg ->
252                    do   newFunctionName $1 pkg
253                         ((formals, gc_block, frame), stmts) <-
254                                 getCgStmtsEC' $ loopDecls $ do {
255                                         formals <- sequence $2;
256                                         gc_block <- $3;
257                                         frame <- $4;
258                                         $6;
259                                         return (formals, gc_block, frame) }
260                         blks <- code (cgStmtsToBlocks stmts)
261                         code (emitProc (CmmInfo gc_block frame CmmNonInfoTable) (mkCmmCodeLabel pkg $1) formals blks) }
262
263 info    :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) }
264         : 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
265                 -- ptrs, nptrs, closure type, description, type
266                 {% withThisPackage $ \pkg ->
267                    do let prof = profilingInfo $11 $13
268                           rep = mkHeapRep False (fromIntegral $5) (fromIntegral $7) Thunk
269                         -- ToDo: Type tag $9 redundant
270                       return (mkCmmEntryLabel pkg $3,
271                               CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
272                                            , cit_rep = rep
273                                            , cit_prof = prof, cit_srt = NoC_SRT },
274                               []) }
275         
276         | 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ')'
277                 -- ptrs, nptrs, closure type, description, type, fun type
278                 {% withThisPackage $ \pkg -> 
279                    do let prof = profilingInfo $11 $13
280                           rep = mkHeapRep False (fromIntegral $5) (fromIntegral $7) ty
281                           ty  = Fun 0  -- Arity zero
282                                      (ArgSpec (fromIntegral $15))
283                         -- ToDo: Type tag $9 redundant
284                       return (mkCmmEntryLabel pkg $3,
285                               CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
286                                            , cit_rep = rep
287                                            , cit_prof = prof, cit_srt = NoC_SRT },
288                               []) }
289                 -- we leave most of the fields zero here.  This is only used
290                 -- to generate the BCO info table in the RTS at the moment.
291
292         -- A variant with a non-zero arity (needed to write Main_main in Cmm)
293         | 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ',' INT ')'
294                 -- ptrs, nptrs, closure type, description, type, fun type, arity
295                 {% withThisPackage $ \pkg ->
296                    do let prof = profilingInfo $11 $13
297                           rep = mkHeapRep False (fromIntegral $5) (fromIntegral $7) ty
298                           ty  = Fun (fromIntegral $17)  -- Arity 
299                                      (ArgSpec (fromIntegral $15))
300                         -- ToDo: Type tag $9 redundant
301                       return (mkCmmEntryLabel pkg $3,
302                               CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
303                                            , cit_rep = rep
304                                            , cit_prof = prof, cit_srt = NoC_SRT },
305                               []) }
306                 -- we leave most of the fields zero here.  This is only used
307                 -- to generate the BCO info table in the RTS at the moment.
308         
309         | 'INFO_TABLE_CONSTR' '(' NAME ',' INT ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
310                 -- ptrs, nptrs, tag, closure type, description, type
311                 {% withThisPackage $ \pkg ->
312                    do let prof = profilingInfo $13 $15
313                           rep = mkHeapRep False (fromIntegral $5) (fromIntegral $7) ty
314                           ty  = Constr (fromIntegral $9)  -- Tag
315                                         (stringToWord8s $13)
316                         -- ToDo: Type tag $11 redundant
317                       return (mkCmmEntryLabel pkg $3,
318                               CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
319                                            , cit_rep = rep
320                                            , cit_prof = prof, cit_srt = NoC_SRT },
321                               []) }
322
323                      -- If profiling is on, this string gets duplicated,
324                      -- but that's the way the old code did it we can fix it some other time.
325         
326         | 'INFO_TABLE_SELECTOR' '(' NAME ',' INT ',' INT ',' STRING ',' STRING ')'
327                 -- selector, closure type, description, type
328                 {% withThisPackage $ \pkg ->
329                    do let prof = profilingInfo $9 $11
330                           rep = mkHeapRep False (fromIntegral $5) (fromIntegral $7) ty
331                           ty  = ThunkSelector (fromIntegral $5)
332                         -- ToDo: Type tag $7 redundant
333                       return (mkCmmEntryLabel pkg $3,
334                               CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
335                                            , cit_rep = rep
336                                            , cit_prof = prof, cit_srt = NoC_SRT },
337                               []) }
338
339         | 'INFO_TABLE_RET' '(' NAME ',' INT ')'
340                 -- closure type (no live regs)
341                 {% withThisPackage $ \pkg ->
342                    do let prof = NoProfilingInfo
343                           rep  = mkStackRep []
344                         -- ToDo: Type tag $5 redundant
345                       return (mkCmmRetLabel pkg $3,
346                               CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
347                                            , cit_rep = rep
348                                            , cit_prof = prof, cit_srt = NoC_SRT },
349                               []) }
350
351         | 'INFO_TABLE_RET' '(' NAME ',' INT ',' formals_without_hints0 ')'
352                 -- closure type, live regs
353                 {% withThisPackage $ \pkg ->
354                    do live <- sequence (map (liftM Just) $7)
355                       let prof = NoProfilingInfo
356                           rep  = mkStackRep []
357                         -- ToDo: Type tag $5 redundant
358                       return (mkCmmRetLabel pkg $3,
359                               CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
360                                            , cit_rep = rep
361                                            , cit_prof = prof, cit_srt = NoC_SRT },
362                               []) }
363
364 body    :: { ExtCode }
365         : {- empty -}                   { return () }
366         | decl body                     { do $1; $2 }
367         | stmt body                     { do $1; $2 }
368
369 decl    :: { ExtCode }
370         : type names ';'                { mapM_ (newLocal $1) $2 }
371         | 'import' importNames ';'      { mapM_ newImport $2 }
372         | 'export' names ';'            { return () }  -- ignore exports
373
374
375 -- an imported function name, with optional packageId
376 importNames  
377         :: { [(FastString, CLabel)] }
378         : importName                    { [$1] }
379         | importName ',' importNames    { $1 : $3 }             
380         
381 importName
382         :: { (FastString,  CLabel) }
383
384         -- A label imported without an explicit packageId.
385         --      These are taken to come frome some foreign, unnamed package.
386         : NAME  
387         { ($1, mkForeignLabel $1 Nothing ForeignLabelInExternalPackage IsFunction) }
388
389         -- A label imported with an explicit packageId.
390         | STRING NAME
391         { ($2, mkCmmCodeLabel (fsToPackageId (mkFastString $1)) $2) }
392         
393         
394 names   :: { [FastString] }
395         : NAME                          { [$1] }
396         | NAME ',' names                { $1 : $3 }
397
398 stmt    :: { ExtCode }
399         : ';'                                   { nopEC }
400
401         | NAME ':'
402                 { do l <- newLabel $1; code (labelC l) }
403
404         | lreg '=' expr ';'
405                 { do reg <- $1; e <- $3; stmtEC (CmmAssign reg e) }
406         | type '[' expr ']' '=' expr ';'
407                 { doStore $1 $3 $6 }
408
409         -- Gah! We really want to say "maybe_results" but that causes
410         -- a shift/reduce conflict with assignment.  We either
411         -- we expand out the no-result and single result cases or
412         -- we tweak the syntax to avoid the conflict.  The later
413         -- option is taken here because the other way would require
414         -- multiple levels of expanding and get unwieldy.
415         | maybe_results 'foreign' STRING expr '(' cmm_hint_exprs0 ')' safety vols opt_never_returns ';'
416                 {% foreignCall $3 $1 $4 $6 $9 $8 $10 }
417         | maybe_results 'prim' '%' NAME '(' cmm_hint_exprs0 ')' safety vols ';'
418                 {% primCall $1 $4 $6 $9 $8 }
419         -- stmt-level macros, stealing syntax from ordinary C-- function calls.
420         -- Perhaps we ought to use the %%-form?
421         | NAME '(' exprs0 ')' ';'
422                 {% stmtMacro $1 $3  }
423         | 'switch' maybe_range expr '{' arms default '}'
424                 { do as <- sequence $5; doSwitch $2 $3 as $6 }
425         | 'goto' NAME ';'
426                 { do l <- lookupLabel $2; stmtEC (CmmBranch l) }
427         | 'jump' expr maybe_actuals ';'
428                 { do e1 <- $2; e2 <- sequence $3; stmtEC (CmmJump e1 e2) }
429         | 'return' maybe_actuals ';'
430                 { do e <- sequence $2; stmtEC (CmmReturn e) }
431         | 'if' bool_expr 'goto' NAME
432                 { do l <- lookupLabel $4; cmmRawIf $2 l }
433         | 'if' bool_expr '{' body '}' else      
434                 { cmmIfThenElse $2 $4 $6 }
435
436 opt_never_returns :: { CmmReturnInfo }
437         :                               { CmmMayReturn }
438         | 'never' 'returns'             { CmmNeverReturns }
439
440 bool_expr :: { ExtFCode BoolExpr }
441         : bool_op                       { $1 }
442         | expr                          { do e <- $1; return (BoolTest e) }
443
444 bool_op :: { ExtFCode BoolExpr }
445         : bool_expr '&&' bool_expr      { do e1 <- $1; e2 <- $3; 
446                                           return (BoolAnd e1 e2) }
447         | bool_expr '||' bool_expr      { do e1 <- $1; e2 <- $3; 
448                                           return (BoolOr e1 e2)  }
449         | '!' bool_expr                 { do e <- $2; return (BoolNot e) }
450         | '(' bool_op ')'               { $2 }
451
452 -- This is not C-- syntax.  What to do?
453 safety  :: { CmmSafety }
454         : {- empty -}                   { CmmUnsafe } -- Default may change soon
455         | STRING                        {% parseSafety $1 }
456
457 -- This is not C-- syntax.  What to do?
458 vols    :: { Maybe [GlobalReg] }
459         : {- empty -}                   { Nothing }
460         | '[' ']'                       { Just [] }
461         | '[' globals ']'               { Just $2 }
462
463 globals :: { [GlobalReg] }
464         : GLOBALREG                     { [$1] }
465         | GLOBALREG ',' globals         { $1 : $3 }
466
467 maybe_range :: { Maybe (Int,Int) }
468         : '[' INT '..' INT ']'  { Just (fromIntegral $2, fromIntegral $4) }
469         | {- empty -}           { Nothing }
470
471 arms    :: { [ExtFCode ([Int],Either BlockId ExtCode)] }
472         : {- empty -}                   { [] }
473         | arm arms                      { $1 : $2 }
474
475 arm     :: { ExtFCode ([Int],Either BlockId ExtCode) }
476         : 'case' ints ':' arm_body      { do b <- $4; return ($2, b) }
477
478 arm_body :: { ExtFCode (Either BlockId ExtCode) }
479         : '{' body '}'                  { return (Right $2) }
480         | 'goto' NAME ';'               { do l <- lookupLabel $2; return (Left l) }
481
482 ints    :: { [Int] }
483         : INT                           { [ fromIntegral $1 ] }
484         | INT ',' ints                  { fromIntegral $1 : $3 }
485
486 default :: { Maybe ExtCode }
487         : 'default' ':' '{' body '}'    { Just $4 }
488         -- taking a few liberties with the C-- syntax here; C-- doesn't have
489         -- 'default' branches
490         | {- empty -}                   { Nothing }
491
492 -- Note: OldCmm doesn't support a first class 'else' statement, though
493 -- CmmNode does.
494 else    :: { ExtCode }
495         : {- empty -}                   { nopEC }
496         | 'else' '{' body '}'           { $3 }
497
498 -- we have to write this out longhand so that Happy's precedence rules
499 -- can kick in.
500 expr    :: { ExtFCode CmmExpr } 
501         : expr '/' expr                 { mkMachOp MO_U_Quot [$1,$3] }
502         | expr '*' expr                 { mkMachOp MO_Mul [$1,$3] }
503         | expr '%' expr                 { mkMachOp MO_U_Rem [$1,$3] }
504         | expr '-' expr                 { mkMachOp MO_Sub [$1,$3] }
505         | expr '+' expr                 { mkMachOp MO_Add [$1,$3] }
506         | expr '>>' expr                { mkMachOp MO_U_Shr [$1,$3] }
507         | expr '<<' expr                { mkMachOp MO_Shl [$1,$3] }
508         | expr '&' expr                 { mkMachOp MO_And [$1,$3] }
509         | expr '^' expr                 { mkMachOp MO_Xor [$1,$3] }
510         | expr '|' expr                 { mkMachOp MO_Or [$1,$3] }
511         | expr '>=' expr                { mkMachOp MO_U_Ge [$1,$3] }
512         | expr '>' expr                 { mkMachOp MO_U_Gt [$1,$3] }
513         | expr '<=' expr                { mkMachOp MO_U_Le [$1,$3] }
514         | expr '<' expr                 { mkMachOp MO_U_Lt [$1,$3] }
515         | expr '!=' expr                { mkMachOp MO_Ne [$1,$3] }
516         | expr '==' expr                { mkMachOp MO_Eq [$1,$3] }
517         | '~' expr                      { mkMachOp MO_Not [$2] }
518         | '-' expr                      { mkMachOp MO_S_Neg [$2] }
519         | expr0 '`' NAME '`' expr0      {% do { mo <- nameToMachOp $3 ;
520                                                 return (mkMachOp mo [$1,$5]) } }
521         | expr0                         { $1 }
522
523 expr0   :: { ExtFCode CmmExpr }
524         : INT   maybe_ty         { return (CmmLit (CmmInt $1 (typeWidth $2))) }
525         | FLOAT maybe_ty         { return (CmmLit (CmmFloat $1 (typeWidth $2))) }
526         | STRING                 { do s <- code (newStringCLit $1); 
527                                       return (CmmLit s) }
528         | reg                    { $1 }
529         | type '[' expr ']'      { do e <- $3; return (CmmLoad e $1) }
530         | '%' NAME '(' exprs0 ')' {% exprOp $2 $4 }
531         | '(' expr ')'           { $2 }
532
533
534 -- leaving out the type of a literal gives you the native word size in C--
535 maybe_ty :: { CmmType }
536         : {- empty -}                   { bWord }
537         | '::' type                     { $2 }
538
539 maybe_actuals :: { [ExtFCode HintedCmmActual] }
540         : {- empty -}           { [] }
541         | '(' cmm_hint_exprs0 ')'       { $2 }
542
543 cmm_hint_exprs0 :: { [ExtFCode HintedCmmActual] }
544         : {- empty -}                   { [] }
545         | cmm_hint_exprs                        { $1 }
546
547 cmm_hint_exprs :: { [ExtFCode HintedCmmActual] }
548         : cmm_hint_expr                 { [$1] }
549         | cmm_hint_expr ',' cmm_hint_exprs      { $1 : $3 }
550
551 cmm_hint_expr :: { ExtFCode HintedCmmActual }
552         : expr                          { do e <- $1; return (CmmHinted e (inferCmmHint e)) }
553         | expr STRING                   {% do h <- parseCmmHint $2;
554                                               return $ do
555                                                 e <- $1; return (CmmHinted e h) }
556
557 exprs0  :: { [ExtFCode CmmExpr] }
558         : {- empty -}                   { [] }
559         | exprs                         { $1 }
560
561 exprs   :: { [ExtFCode CmmExpr] }
562         : expr                          { [ $1 ] }
563         | expr ',' exprs                { $1 : $3 }
564
565 reg     :: { ExtFCode CmmExpr }
566         : NAME                  { lookupName $1 }
567         | GLOBALREG             { return (CmmReg (CmmGlobal $1)) }
568
569 maybe_results :: { [ExtFCode HintedCmmFormal] }
570         : {- empty -}           { [] }
571         | '(' cmm_formals ')' '='       { $2 }
572
573 cmm_formals :: { [ExtFCode HintedCmmFormal] }
574         : cmm_formal                    { [$1] }
575         | cmm_formal ','                        { [$1] }
576         | cmm_formal ',' cmm_formals    { $1 : $3 }
577
578 cmm_formal :: { ExtFCode HintedCmmFormal }
579         : local_lreg                    { do e <- $1; return (CmmHinted e (inferCmmHint (CmmReg (CmmLocal e)))) }
580         | STRING local_lreg             {% do h <- parseCmmHint $1;
581                                               return $ do
582                                                 e <- $2; return (CmmHinted e h) }
583
584 local_lreg :: { ExtFCode LocalReg }
585         : NAME                  { do e <- lookupName $1;
586                                      return $
587                                        case e of 
588                                         CmmReg (CmmLocal r) -> r
589                                         other -> pprPanic "CmmParse:" (ftext $1 <> text " not a local register") }
590
591 lreg    :: { ExtFCode CmmReg }
592         : NAME                  { do e <- lookupName $1;
593                                      return $
594                                        case e of 
595                                         CmmReg r -> r
596                                         other -> pprPanic "CmmParse:" (ftext $1 <> text " not a register") }
597         | GLOBALREG             { return (CmmGlobal $1) }
598
599 maybe_formals_without_hints :: { [ExtFCode LocalReg] }
600         : {- empty -}           { [] }
601         | '(' formals_without_hints0 ')'        { $2 }
602
603 formals_without_hints0 :: { [ExtFCode LocalReg] }
604         : {- empty -}           { [] }
605         | formals_without_hints         { $1 }
606
607 formals_without_hints :: { [ExtFCode LocalReg] }
608         : formal_without_hint ','               { [$1] }
609         | formal_without_hint           { [$1] }
610         | formal_without_hint ',' formals_without_hints { $1 : $3 }
611
612 formal_without_hint :: { ExtFCode LocalReg }
613         : type NAME             { newLocal $1 $2 }
614
615 maybe_frame :: { ExtFCode (Maybe UpdateFrame) }
616         : {- empty -}                   { return Nothing }
617         | 'jump' expr '(' exprs0 ')'    { do { target <- $2;
618                                                args <- sequence $4;
619                                                return $ Just (UpdateFrame target args) } }
620
621 maybe_gc_block :: { ExtFCode (Maybe BlockId) }
622         : {- empty -}                   { return Nothing }
623         | 'goto' NAME
624                 { do l <- lookupLabel $2; return (Just l) }
625
626 type    :: { CmmType }
627         : 'bits8'               { b8 }
628         | typenot8              { $1 }
629
630 typenot8 :: { CmmType }
631         : 'bits16'              { b16 }
632         | 'bits32'              { b32 }
633         | 'bits64'              { b64 }
634         | 'float32'             { f32 }
635         | 'float64'             { f64 }
636         | 'gcptr'               { gcWord }
637 {
638 section :: String -> Section
639 section "text"   = Text
640 section "data"   = Data
641 section "rodata" = ReadOnlyData
642 section "relrodata" = RelocatableReadOnlyData
643 section "bss"    = UninitialisedData
644 section s        = OtherSection s
645
646 mkString :: String -> CmmStatic
647 mkString s = CmmString (map (fromIntegral.ord) s)
648
649 -- mkMachOp infers the type of the MachOp from the type of its first
650 -- argument.  We assume that this is correct: for MachOps that don't have
651 -- symmetrical args (e.g. shift ops), the first arg determines the type of
652 -- the op.
653 mkMachOp :: (Width -> MachOp) -> [ExtFCode CmmExpr] -> ExtFCode CmmExpr
654 mkMachOp fn args = do
655   arg_exprs <- sequence args
656   return (CmmMachOp (fn (typeWidth (cmmExprType (head arg_exprs)))) arg_exprs)
657
658 getLit :: CmmExpr -> CmmLit
659 getLit (CmmLit l) = l
660 getLit (CmmMachOp (MO_S_Neg _) [CmmLit (CmmInt i r)])  = CmmInt (negate i) r
661 getLit _ = panic "invalid literal" -- TODO messy failure
662
663 nameToMachOp :: FastString -> P (Width -> MachOp)
664 nameToMachOp name = 
665   case lookupUFM machOps name of
666         Nothing -> fail ("unknown primitive " ++ unpackFS name)
667         Just m  -> return m
668
669 exprOp :: FastString -> [ExtFCode CmmExpr] -> P (ExtFCode CmmExpr)
670 exprOp name args_code =
671   case lookupUFM exprMacros name of
672      Just f  -> return $ do
673         args <- sequence args_code
674         return (f args)
675      Nothing -> do
676         mo <- nameToMachOp name
677         return $ mkMachOp mo args_code
678
679 exprMacros :: UniqFM ([CmmExpr] -> CmmExpr)
680 exprMacros = listToUFM [
681   ( fsLit "ENTRY_CODE",   \ [x] -> entryCode x ),
682   ( fsLit "INFO_PTR",     \ [x] -> closureInfoPtr x ),
683   ( fsLit "STD_INFO",     \ [x] -> infoTable x ),
684   ( fsLit "FUN_INFO",     \ [x] -> funInfoTable x ),
685   ( fsLit "GET_ENTRY",    \ [x] -> entryCode (closureInfoPtr x) ),
686   ( fsLit "GET_STD_INFO", \ [x] -> infoTable (closureInfoPtr x) ),
687   ( fsLit "GET_FUN_INFO", \ [x] -> funInfoTable (closureInfoPtr x) ),
688   ( fsLit "INFO_TYPE",    \ [x] -> infoTableClosureType x ),
689   ( fsLit "INFO_PTRS",    \ [x] -> infoTablePtrs x ),
690   ( fsLit "INFO_NPTRS",   \ [x] -> infoTableNonPtrs x )
691   ]
692
693 -- we understand a subset of C-- primitives:
694 machOps = listToUFM $
695         map (\(x, y) -> (mkFastString x, y)) [
696         ( "add",        MO_Add ),
697         ( "sub",        MO_Sub ),
698         ( "eq",         MO_Eq ),
699         ( "ne",         MO_Ne ),
700         ( "mul",        MO_Mul ),
701         ( "neg",        MO_S_Neg ),
702         ( "quot",       MO_S_Quot ),
703         ( "rem",        MO_S_Rem ),
704         ( "divu",       MO_U_Quot ),
705         ( "modu",       MO_U_Rem ),
706
707         ( "ge",         MO_S_Ge ),
708         ( "le",         MO_S_Le ),
709         ( "gt",         MO_S_Gt ),
710         ( "lt",         MO_S_Lt ),
711
712         ( "geu",        MO_U_Ge ),
713         ( "leu",        MO_U_Le ),
714         ( "gtu",        MO_U_Gt ),
715         ( "ltu",        MO_U_Lt ),
716
717         ( "and",        MO_And ),
718         ( "or",         MO_Or ),
719         ( "xor",        MO_Xor ),
720         ( "com",        MO_Not ),
721         ( "shl",        MO_Shl ),
722         ( "shrl",       MO_U_Shr ),
723         ( "shra",       MO_S_Shr ),
724
725         ( "fadd",       MO_F_Add ),
726         ( "fsub",       MO_F_Sub ),
727         ( "fneg",       MO_F_Neg ),
728         ( "fmul",       MO_F_Mul ),
729         ( "fquot",      MO_F_Quot ),
730
731         ( "feq",        MO_F_Eq ),
732         ( "fne",        MO_F_Ne ),
733         ( "fge",        MO_F_Ge ),
734         ( "fle",        MO_F_Le ),
735         ( "fgt",        MO_F_Gt ),
736         ( "flt",        MO_F_Lt ),
737
738         ( "lobits8",  flip MO_UU_Conv W8  ),
739         ( "lobits16", flip MO_UU_Conv W16 ),
740         ( "lobits32", flip MO_UU_Conv W32 ),
741         ( "lobits64", flip MO_UU_Conv W64 ),
742
743         ( "zx16",     flip MO_UU_Conv W16 ),
744         ( "zx32",     flip MO_UU_Conv W32 ),
745         ( "zx64",     flip MO_UU_Conv W64 ),
746
747         ( "sx16",     flip MO_SS_Conv W16 ),
748         ( "sx32",     flip MO_SS_Conv W32 ),
749         ( "sx64",     flip MO_SS_Conv W64 ),
750
751         ( "f2f32",    flip MO_FF_Conv W32 ),  -- TODO; rounding mode
752         ( "f2f64",    flip MO_FF_Conv W64 ),  -- TODO; rounding mode
753         ( "f2i8",     flip MO_FS_Conv W8 ),
754         ( "f2i16",    flip MO_FS_Conv W16 ),
755         ( "f2i32",    flip MO_FS_Conv W32 ),
756         ( "f2i64",    flip MO_FS_Conv W64 ),
757         ( "i2f32",    flip MO_SF_Conv W32 ),
758         ( "i2f64",    flip MO_SF_Conv W64 )
759         ]
760
761 callishMachOps = listToUFM $
762         map (\(x, y) -> (mkFastString x, y)) [
763         ( "write_barrier", MO_WriteBarrier ),
764         ( "memcpy", MO_Memcpy ),
765         ( "memset", MO_Memset ),
766         ( "memmove", MO_Memmove )
767         -- ToDo: the rest, maybe
768     ]
769
770 parseSafety :: String -> P CmmSafety
771 parseSafety "safe"   = return (CmmSafe NoC_SRT)
772 parseSafety "unsafe" = return CmmUnsafe
773 parseSafety "interruptible" = return CmmInterruptible
774 parseSafety str      = fail ("unrecognised safety: " ++ str)
775
776 parseCmmHint :: String -> P ForeignHint
777 parseCmmHint "ptr"    = return AddrHint
778 parseCmmHint "signed" = return SignedHint
779 parseCmmHint str      = fail ("unrecognised hint: " ++ str)
780
781 -- labels are always pointers, so we might as well infer the hint
782 inferCmmHint :: CmmExpr -> ForeignHint
783 inferCmmHint (CmmLit (CmmLabel _)) = AddrHint
784 inferCmmHint (CmmReg (CmmGlobal g)) | isPtrGlobalReg g = AddrHint
785 inferCmmHint _ = NoHint
786
787 isPtrGlobalReg Sp                    = True
788 isPtrGlobalReg SpLim                 = True
789 isPtrGlobalReg Hp                    = True
790 isPtrGlobalReg HpLim                 = True
791 isPtrGlobalReg CurrentTSO            = True
792 isPtrGlobalReg CurrentNursery        = True
793 isPtrGlobalReg (VanillaReg _ VGcPtr) = True
794 isPtrGlobalReg _                     = False
795
796 happyError :: P a
797 happyError = srcParseFail
798
799 -- -----------------------------------------------------------------------------
800 -- Statement-level macros
801
802 stmtMacro :: FastString -> [ExtFCode CmmExpr] -> P ExtCode
803 stmtMacro fun args_code = do
804   case lookupUFM stmtMacros fun of
805     Nothing -> fail ("unknown macro: " ++ unpackFS fun)
806     Just fcode -> return $ do
807         args <- sequence args_code
808         code (fcode args)
809
810 stmtMacros :: UniqFM ([CmmExpr] -> Code)
811 stmtMacros = listToUFM [
812   ( fsLit "CCS_ALLOC",             \[words,ccs]  -> profAlloc words ccs ),
813   ( fsLit "CLOSE_NURSERY",         \[]  -> emitCloseNursery ),
814   ( fsLit "ENTER_CCS_PAP_CL",     \[e] -> enterCostCentrePAP e ),
815   ( fsLit "ENTER_CCS_THUNK",      \[e] -> enterCostCentreThunk e ),
816   ( fsLit "HP_CHK_GEN",           \[words,liveness,reentry] -> 
817                                       hpChkGen words liveness reentry ),
818   ( fsLit "HP_CHK_NP_ASSIGN_SP0", \[e,f] -> hpChkNodePointsAssignSp0 e f ),
819   ( fsLit "LOAD_THREAD_STATE",    \[] -> emitLoadThreadState ),
820   ( fsLit "LDV_ENTER",            \[e] -> ldvEnter e ),
821   ( fsLit "LDV_RECORD_CREATE",    \[e] -> ldvRecordCreate e ),
822   ( fsLit "OPEN_NURSERY",          \[]  -> emitOpenNursery ),
823   ( fsLit "PUSH_UPD_FRAME",        \[sp,e] -> emitPushUpdateFrame sp e ),
824   ( fsLit "SAVE_THREAD_STATE",    \[] -> emitSaveThreadState ),
825   ( fsLit "SET_HDR",               \[ptr,info,ccs] -> 
826                                         emitSetDynHdr ptr info ccs ),
827   ( fsLit "STK_CHK_GEN",          \[words,liveness,reentry] -> 
828                                       stkChkGen words liveness reentry ),
829   ( fsLit "STK_CHK_NP",    \[e] -> stkChkNodePoints e ),
830   ( fsLit "TICK_ALLOC_PRIM",       \[hdr,goods,slop] -> 
831                                         tickyAllocPrim hdr goods slop ),
832   ( fsLit "TICK_ALLOC_PAP",       \[goods,slop] -> 
833                                         tickyAllocPAP goods slop ),
834   ( fsLit "TICK_ALLOC_UP_THK",    \[goods,slop] -> 
835                                         tickyAllocThunk goods slop ),
836   ( fsLit "UPD_BH_UPDATABLE",       \[] -> emitBlackHoleCode False ),
837   ( fsLit "UPD_BH_SINGLE_ENTRY",    \[] -> emitBlackHoleCode True ),
838
839   ( fsLit "RET_P",      \[a] ->       emitRetUT [(PtrArg,a)]),
840   ( fsLit "RET_N",      \[a] ->       emitRetUT [(NonPtrArg,a)]),
841   ( fsLit "RET_PP",     \[a,b] ->     emitRetUT [(PtrArg,a),(PtrArg,b)]),
842   ( fsLit "RET_NN",     \[a,b] ->     emitRetUT [(NonPtrArg,a),(NonPtrArg,b)]),
843   ( fsLit "RET_NP",     \[a,b] ->     emitRetUT [(NonPtrArg,a),(PtrArg,b)]),
844   ( fsLit "RET_PPP",    \[a,b,c] ->   emitRetUT [(PtrArg,a),(PtrArg,b),(PtrArg,c)]),
845   ( fsLit "RET_NPP",    \[a,b,c] ->   emitRetUT [(NonPtrArg,a),(PtrArg,b),(PtrArg,c)]),
846   ( fsLit "RET_NNP",    \[a,b,c] ->   emitRetUT [(NonPtrArg,a),(NonPtrArg,b),(PtrArg,c)]),
847   ( fsLit "RET_NNN",  \[a,b,c] -> emitRetUT [(NonPtrArg,a),(NonPtrArg,b),(NonPtrArg,c)]),
848   ( fsLit "RET_NNNN",  \[a,b,c,d] -> emitRetUT [(NonPtrArg,a),(NonPtrArg,b),(NonPtrArg,c),(NonPtrArg,d)]),
849   ( fsLit "RET_NNNP",   \[a,b,c,d] -> emitRetUT [(NonPtrArg,a),(NonPtrArg,b),(NonPtrArg,c),(PtrArg,d)]),
850   ( fsLit "RET_NPNP",   \[a,b,c,d] -> emitRetUT [(NonPtrArg,a),(PtrArg,b),(NonPtrArg,c),(PtrArg,d)])
851
852  ]
853
854
855 profilingInfo desc_str ty_str 
856   | not opt_SccProfilingOn = NoProfilingInfo
857   | otherwise              = ProfilingInfo (stringToWord8s desc_str)
858                                            (stringToWord8s ty_str)
859
860 staticClosure :: PackageId -> FastString -> FastString -> [CmmLit] -> ExtCode
861 staticClosure pkg cl_label info payload
862   = code $ emitDataLits (mkCmmDataLabel pkg cl_label) lits
863   where  lits = mkStaticClosure (mkCmmInfoLabel pkg info) dontCareCCS payload [] [] []
864
865 foreignCall
866         :: String
867         -> [ExtFCode HintedCmmFormal]
868         -> ExtFCode CmmExpr
869         -> [ExtFCode HintedCmmActual]
870         -> Maybe [GlobalReg]
871         -> CmmSafety
872         -> CmmReturnInfo
873         -> P ExtCode
874 foreignCall conv_string results_code expr_code args_code vols safety ret
875   = do  convention <- case conv_string of
876           "C" -> return CCallConv
877           "stdcall" -> return StdCallConv
878           "C--" -> return CmmCallConv
879           _ -> fail ("unknown calling convention: " ++ conv_string)
880         return $ do
881           results <- sequence results_code
882           expr <- expr_code
883           args <- sequence args_code
884           --code (stmtC (CmmCall (CmmCallee expr convention) results args safety))
885           case convention of
886             -- Temporary hack so at least some functions are CmmSafe
887             CmmCallConv -> code (stmtC (CmmCall (CmmCallee expr convention) results args safety ret))
888             _ ->
889               let expr' = adjCallTarget convention expr args in
890               case safety of
891               CmmUnsafe ->
892                 code (emitForeignCall' PlayRisky results 
893                    (CmmCallee expr' convention) args vols NoC_SRT ret)
894               CmmSafe srt ->
895                 code (emitForeignCall' PlaySafe results 
896                    (CmmCallee expr' convention) args vols NoC_SRT ret) where
897               CmmInterruptible ->
898                 code (emitForeignCall' PlayInterruptible results 
899                    (CmmCallee expr' convention) args vols NoC_SRT ret)
900
901 adjCallTarget :: CCallConv -> CmmExpr -> [CmmHinted CmmExpr] -> CmmExpr
902 #ifdef mingw32_TARGET_OS
903 -- On Windows, we have to add the '@N' suffix to the label when making
904 -- a call with the stdcall calling convention.
905 adjCallTarget StdCallConv (CmmLit (CmmLabel lbl)) args
906   = CmmLit (CmmLabel (addLabelSize lbl (sum (map size args))))
907   where size (CmmHinted e _) = max wORD_SIZE (widthInBytes (typeWidth (cmmExprType e)))
908                  -- c.f. CgForeignCall.emitForeignCall
909 #endif
910 adjCallTarget _ expr _
911   = expr
912
913 primCall
914         :: [ExtFCode HintedCmmFormal]
915         -> FastString
916         -> [ExtFCode HintedCmmActual]
917         -> Maybe [GlobalReg]
918         -> CmmSafety
919         -> P ExtCode
920 primCall results_code name args_code vols safety
921   = case lookupUFM callishMachOps name of
922         Nothing -> fail ("unknown primitive " ++ unpackFS name)
923         Just p  -> return $ do
924                 results <- sequence results_code
925                 args <- sequence args_code
926                 case safety of
927                   CmmUnsafe ->
928                     code (emitForeignCall' PlayRisky results
929                       (CmmPrim p) args vols NoC_SRT CmmMayReturn)
930                   CmmSafe srt ->
931                     code (emitForeignCall' PlaySafe results 
932                       (CmmPrim p) args vols NoC_SRT CmmMayReturn) where
933                   CmmInterruptible ->
934                     code (emitForeignCall' PlayInterruptible results 
935                       (CmmPrim p) args vols NoC_SRT CmmMayReturn)
936
937 doStore :: CmmType -> ExtFCode CmmExpr  -> ExtFCode CmmExpr -> ExtCode
938 doStore rep addr_code val_code
939   = do addr <- addr_code
940        val <- val_code
941         -- if the specified store type does not match the type of the expr
942         -- on the rhs, then we insert a coercion that will cause the type
943         -- mismatch to be flagged by cmm-lint.  If we don't do this, then
944         -- the store will happen at the wrong type, and the error will not
945         -- be noticed.
946        let val_width = typeWidth (cmmExprType val)
947            rep_width = typeWidth rep
948        let coerce_val 
949                 | val_width /= rep_width = CmmMachOp (MO_UU_Conv val_width rep_width) [val]
950                 | otherwise              = val
951        stmtEC (CmmStore addr coerce_val)
952
953 -- Return an unboxed tuple.
954 emitRetUT :: [(CgRep,CmmExpr)] -> Code
955 emitRetUT args = do
956   tickyUnboxedTupleReturn (length args)  -- TICK
957   (sp, stmts) <- pushUnboxedTuple 0 args
958   emitSimultaneously stmts -- NB. the args might overlap with the stack slots
959                            -- or regs that we assign to, so better use
960                            -- simultaneous assignments here (#3546)
961   when (sp /= 0) $ stmtC (CmmAssign spReg (cmmRegOffW spReg (-sp)))
962   stmtC (CmmJump (entryCode (CmmLoad (cmmRegOffW spReg sp) bWord)) [])
963   -- TODO (when using CPS): emitStmt (CmmReturn (map snd args))
964
965 -- -----------------------------------------------------------------------------
966 -- If-then-else and boolean expressions
967
968 data BoolExpr
969   = BoolExpr `BoolAnd` BoolExpr
970   | BoolExpr `BoolOr`  BoolExpr
971   | BoolNot BoolExpr
972   | BoolTest CmmExpr
973
974 -- ToDo: smart constructors which simplify the boolean expression.
975
976 cmmIfThenElse cond then_part else_part = do
977      then_id <- code newLabelC
978      join_id <- code newLabelC
979      c <- cond
980      emitCond c then_id
981      else_part
982      stmtEC (CmmBranch join_id)
983      code (labelC then_id)
984      then_part
985      -- fall through to join
986      code (labelC join_id)
987
988 cmmRawIf cond then_id = do
989     c <- cond
990     emitCond c then_id
991
992 -- 'emitCond cond true_id'  emits code to test whether the cond is true,
993 -- branching to true_id if so, and falling through otherwise.
994 emitCond (BoolTest e) then_id = do
995   stmtEC (CmmCondBranch e then_id)
996 emitCond (BoolNot (BoolTest (CmmMachOp op args))) then_id
997   | Just op' <- maybeInvertComparison op
998   = emitCond (BoolTest (CmmMachOp op' args)) then_id
999 emitCond (BoolNot e) then_id = do
1000   else_id <- code newLabelC
1001   emitCond e else_id
1002   stmtEC (CmmBranch then_id)
1003   code (labelC else_id)
1004 emitCond (e1 `BoolOr` e2) then_id = do
1005   emitCond e1 then_id
1006   emitCond e2 then_id
1007 emitCond (e1 `BoolAnd` e2) then_id = do
1008         -- we'd like to invert one of the conditionals here to avoid an
1009         -- extra branch instruction, but we can't use maybeInvertComparison
1010         -- here because we can't look too closely at the expression since
1011         -- we're in a loop.
1012   and_id <- code newLabelC
1013   else_id <- code newLabelC
1014   emitCond e1 and_id
1015   stmtEC (CmmBranch else_id)
1016   code (labelC and_id)
1017   emitCond e2 then_id
1018   code (labelC else_id)
1019
1020
1021 -- -----------------------------------------------------------------------------
1022 -- Table jumps
1023
1024 -- We use a simplified form of C-- switch statements for now.  A
1025 -- switch statement always compiles to a table jump.  Each arm can
1026 -- specify a list of values (not ranges), and there can be a single
1027 -- default branch.  The range of the table is given either by the
1028 -- optional range on the switch (eg. switch [0..7] {...}), or by
1029 -- the minimum/maximum values from the branches.
1030
1031 doSwitch :: Maybe (Int,Int) -> ExtFCode CmmExpr -> [([Int],Either BlockId ExtCode)]
1032          -> Maybe ExtCode -> ExtCode
1033 doSwitch mb_range scrut arms deflt
1034    = do 
1035         -- Compile code for the default branch
1036         dflt_entry <- 
1037                 case deflt of
1038                   Nothing -> return Nothing
1039                   Just e  -> do b <- forkLabelledCodeEC e; return (Just b)
1040
1041         -- Compile each case branch
1042         table_entries <- mapM emitArm arms
1043
1044         -- Construct the table
1045         let
1046             all_entries = concat table_entries
1047             ixs = map fst all_entries
1048             (min,max) 
1049                 | Just (l,u) <- mb_range = (l,u)
1050                 | otherwise              = (minimum ixs, maximum ixs)
1051
1052             entries = elems (accumArray (\_ a -> Just a) dflt_entry (min,max)
1053                                 all_entries)
1054         expr <- scrut
1055         -- ToDo: check for out of range and jump to default if necessary
1056         stmtEC (CmmSwitch expr entries)
1057    where
1058         emitArm :: ([Int],Either BlockId ExtCode) -> ExtFCode [(Int,BlockId)]
1059         emitArm (ints,Left blockid) = return [ (i,blockid) | i <- ints ]
1060         emitArm (ints,Right code) = do
1061            blockid <- forkLabelledCodeEC code
1062            return [ (i,blockid) | i <- ints ]
1063
1064 -- -----------------------------------------------------------------------------
1065 -- Putting it all together
1066
1067 -- The initial environment: we define some constants that the compiler
1068 -- knows about here.
1069 initEnv :: Env
1070 initEnv = listToUFM [
1071   ( fsLit "SIZEOF_StgHeader", 
1072     VarN (CmmLit (CmmInt (fromIntegral (fixedHdrSize * wORD_SIZE)) wordWidth) )),
1073   ( fsLit "SIZEOF_StgInfoTable",
1074     VarN (CmmLit (CmmInt (fromIntegral stdInfoTableSizeB) wordWidth) ))
1075   ]
1076
1077 parseCmmFile :: DynFlags -> FilePath -> IO (Messages, Maybe CmmPgm)
1078 parseCmmFile dflags filename = do
1079   showPass dflags "ParseCmm"
1080   buf <- hGetStringBuffer filename
1081   let
1082         init_loc = mkRealSrcLoc (mkFastString filename) 1 1
1083         init_state = (mkPState dflags buf init_loc) { lex_state = [0] }
1084                 -- reset the lex_state: the Lexer monad leaves some stuff
1085                 -- in there we don't want.
1086   case unP cmmParse init_state of
1087     PFailed span err -> do
1088         let msg = mkPlainErrMsg span err
1089         return ((emptyBag, unitBag msg), Nothing)
1090     POk pst code -> do
1091         cmm <- initC dflags no_module (getCmm (unEC code initEnv [] >> return ()))
1092         let ms = getMessages pst
1093         if (errorsFound dflags ms)
1094          then return (ms, Nothing)
1095          else do
1096            dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (pprPlatform (targetPlatform dflags) cmm)
1097            return (ms, Just cmm)
1098   where
1099         no_module = panic "parseCmmFile: no module"
1100 }