9d9136e18bcd2e6939af3c8ee4871a697aa1abf0
[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 (emitData (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 prof <- profilingInfo $11 $13
268                       return (mkCmmEntryLabel pkg $3,
269                         CmmInfoTable (mkCmmInfoLabel pkg $3) False prof (fromIntegral $9)
270                                      (ThunkInfo (fromIntegral $5, fromIntegral $7) NoC_SRT),
271                         []) }
272         
273         | 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ')'
274                 -- ptrs, nptrs, closure type, description, type, fun type
275                 {% withThisPackage $ \pkg -> 
276                    do prof <- profilingInfo $11 $13
277                       return (mkCmmEntryLabel pkg $3,
278                         CmmInfoTable (mkCmmInfoLabel pkg $3) False prof (fromIntegral $9)
279                                      (FunInfo (fromIntegral $5, fromIntegral $7) NoC_SRT
280                                       0  -- Arity zero
281                                       (ArgSpec (fromIntegral $15))
282                                       zeroCLit),
283                         []) }
284                 -- we leave most of the fields zero here.  This is only used
285                 -- to generate the BCO info table in the RTS at the moment.
286
287         -- A variant with a non-zero arity (needed to write Main_main in Cmm)
288         | 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ',' INT ')'
289                 -- ptrs, nptrs, closure type, description, type, fun type, arity
290                 {% withThisPackage $ \pkg ->
291                    do prof <- profilingInfo $11 $13
292                       return (mkCmmEntryLabel pkg $3,
293                         CmmInfoTable (mkCmmInfoLabel pkg $3) False prof (fromIntegral $9)
294                                      (FunInfo (fromIntegral $5, fromIntegral $7) NoC_SRT (fromIntegral $17)
295                                       (ArgSpec (fromIntegral $15))
296                                       zeroCLit),
297                         []) }
298                 -- we leave most of the fields zero here.  This is only used
299                 -- to generate the BCO info table in the RTS at the moment.
300         
301         | 'INFO_TABLE_CONSTR' '(' NAME ',' INT ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
302                 -- ptrs, nptrs, tag, closure type, description, type
303                 {% withThisPackage $ \pkg ->
304                    do prof <- profilingInfo $13 $15
305                      -- If profiling is on, this string gets duplicated,
306                      -- but that's the way the old code did it we can fix it some other time.
307                       desc_lit <- code $ mkStringCLit $13
308                       return (mkCmmEntryLabel pkg $3,
309                         CmmInfoTable (mkCmmInfoLabel pkg $3) False prof (fromIntegral $11)
310                                      (ConstrInfo (fromIntegral $5, fromIntegral $7) (fromIntegral $9) desc_lit),
311                         []) }
312         
313         | 'INFO_TABLE_SELECTOR' '(' NAME ',' INT ',' INT ',' STRING ',' STRING ')'
314                 -- selector, closure type, description, type
315                 {% withThisPackage $ \pkg ->
316                    do prof <- profilingInfo $9 $11
317                       return (mkCmmEntryLabel pkg $3,
318                         CmmInfoTable (mkCmmInfoLabel pkg $3) False prof (fromIntegral $7)
319                                      (ThunkSelectorInfo (fromIntegral $5) NoC_SRT),
320                         []) }
321
322         | 'INFO_TABLE_RET' '(' NAME ',' INT ')'
323                 -- closure type (no live regs)
324                 {% withThisPackage $ \pkg ->
325                    do let infoLabel = mkCmmInfoLabel pkg $3
326                       return (mkCmmRetLabel pkg $3,
327                         CmmInfoTable (mkCmmInfoLabel pkg $3) False (ProfilingInfo zeroCLit zeroCLit) (fromIntegral $5)
328                                      (ContInfo [] NoC_SRT),
329                         []) }
330
331         | 'INFO_TABLE_RET' '(' NAME ',' INT ',' formals_without_hints0 ')'
332                 -- closure type, live regs
333                 {% withThisPackage $ \pkg ->
334                    do live <- sequence (map (liftM Just) $7)
335                       return (mkCmmRetLabel pkg $3,
336                         CmmInfoTable (mkCmmInfoLabel pkg $3) False (ProfilingInfo zeroCLit zeroCLit) (fromIntegral $5)
337                                      (ContInfo live NoC_SRT),
338                         live) }
339
340 body    :: { ExtCode }
341         : {- empty -}                   { return () }
342         | decl body                     { do $1; $2 }
343         | stmt body                     { do $1; $2 }
344
345 decl    :: { ExtCode }
346         : type names ';'                { mapM_ (newLocal $1) $2 }
347         | 'import' importNames ';'      { mapM_ newImport $2 }
348         | 'export' names ';'            { return () }  -- ignore exports
349
350
351 -- an imported function name, with optional packageId
352 importNames  
353         :: { [(FastString, CLabel)] }
354         : importName                    { [$1] }
355         | importName ',' importNames    { $1 : $3 }             
356         
357 importName
358         :: { (FastString,  CLabel) }
359
360         -- A label imported without an explicit packageId.
361         --      These are taken to come frome some foreign, unnamed package.
362         : NAME  
363         { ($1, mkForeignLabel $1 Nothing ForeignLabelInExternalPackage IsFunction) }
364
365         -- A label imported with an explicit packageId.
366         | STRING NAME
367         { ($2, mkCmmCodeLabel (fsToPackageId (mkFastString $1)) $2) }
368         
369         
370 names   :: { [FastString] }
371         : NAME                          { [$1] }
372         | NAME ',' names                { $1 : $3 }
373
374 stmt    :: { ExtCode }
375         : ';'                                   { nopEC }
376
377         | NAME ':'
378                 { do l <- newLabel $1; code (labelC l) }
379
380         | lreg '=' expr ';'
381                 { do reg <- $1; e <- $3; stmtEC (CmmAssign reg e) }
382         | type '[' expr ']' '=' expr ';'
383                 { doStore $1 $3 $6 }
384
385         -- Gah! We really want to say "maybe_results" but that causes
386         -- a shift/reduce conflict with assignment.  We either
387         -- we expand out the no-result and single result cases or
388         -- we tweak the syntax to avoid the conflict.  The later
389         -- option is taken here because the other way would require
390         -- multiple levels of expanding and get unwieldy.
391         | maybe_results 'foreign' STRING expr '(' cmm_hint_exprs0 ')' safety vols opt_never_returns ';'
392                 {% foreignCall $3 $1 $4 $6 $9 $8 $10 }
393         | maybe_results 'prim' '%' NAME '(' cmm_hint_exprs0 ')' safety vols ';'
394                 {% primCall $1 $4 $6 $9 $8 }
395         -- stmt-level macros, stealing syntax from ordinary C-- function calls.
396         -- Perhaps we ought to use the %%-form?
397         | NAME '(' exprs0 ')' ';'
398                 {% stmtMacro $1 $3  }
399         | 'switch' maybe_range expr '{' arms default '}'
400                 { do as <- sequence $5; doSwitch $2 $3 as $6 }
401         | 'goto' NAME ';'
402                 { do l <- lookupLabel $2; stmtEC (CmmBranch l) }
403         | 'jump' expr maybe_actuals ';'
404                 { do e1 <- $2; e2 <- sequence $3; stmtEC (CmmJump e1 e2) }
405         | 'return' maybe_actuals ';'
406                 { do e <- sequence $2; stmtEC (CmmReturn e) }
407         | 'if' bool_expr 'goto' NAME
408                 { do l <- lookupLabel $4; cmmRawIf $2 l }
409         | 'if' bool_expr '{' body '}' else      
410                 { cmmIfThenElse $2 $4 $6 }
411
412 opt_never_returns :: { CmmReturnInfo }
413         :                               { CmmMayReturn }
414         | 'never' 'returns'             { CmmNeverReturns }
415
416 bool_expr :: { ExtFCode BoolExpr }
417         : bool_op                       { $1 }
418         | expr                          { do e <- $1; return (BoolTest e) }
419
420 bool_op :: { ExtFCode BoolExpr }
421         : bool_expr '&&' bool_expr      { do e1 <- $1; e2 <- $3; 
422                                           return (BoolAnd e1 e2) }
423         | bool_expr '||' bool_expr      { do e1 <- $1; e2 <- $3; 
424                                           return (BoolOr e1 e2)  }
425         | '!' bool_expr                 { do e <- $2; return (BoolNot e) }
426         | '(' bool_op ')'               { $2 }
427
428 -- This is not C-- syntax.  What to do?
429 safety  :: { CmmSafety }
430         : {- empty -}                   { CmmUnsafe } -- Default may change soon
431         | STRING                        {% parseSafety $1 }
432
433 -- This is not C-- syntax.  What to do?
434 vols    :: { Maybe [GlobalReg] }
435         : {- empty -}                   { Nothing }
436         | '[' ']'                       { Just [] }
437         | '[' globals ']'               { Just $2 }
438
439 globals :: { [GlobalReg] }
440         : GLOBALREG                     { [$1] }
441         | GLOBALREG ',' globals         { $1 : $3 }
442
443 maybe_range :: { Maybe (Int,Int) }
444         : '[' INT '..' INT ']'  { Just (fromIntegral $2, fromIntegral $4) }
445         | {- empty -}           { Nothing }
446
447 arms    :: { [ExtFCode ([Int],Either BlockId ExtCode)] }
448         : {- empty -}                   { [] }
449         | arm arms                      { $1 : $2 }
450
451 arm     :: { ExtFCode ([Int],Either BlockId ExtCode) }
452         : 'case' ints ':' arm_body      { do b <- $4; return ($2, b) }
453
454 arm_body :: { ExtFCode (Either BlockId ExtCode) }
455         : '{' body '}'                  { return (Right $2) }
456         | 'goto' NAME ';'               { do l <- lookupLabel $2; return (Left l) }
457
458 ints    :: { [Int] }
459         : INT                           { [ fromIntegral $1 ] }
460         | INT ',' ints                  { fromIntegral $1 : $3 }
461
462 default :: { Maybe ExtCode }
463         : 'default' ':' '{' body '}'    { Just $4 }
464         -- taking a few liberties with the C-- syntax here; C-- doesn't have
465         -- 'default' branches
466         | {- empty -}                   { Nothing }
467
468 -- Note: OldCmm doesn't support a first class 'else' statement, though
469 -- CmmNode does.
470 else    :: { ExtCode }
471         : {- empty -}                   { nopEC }
472         | 'else' '{' body '}'           { $3 }
473
474 -- we have to write this out longhand so that Happy's precedence rules
475 -- can kick in.
476 expr    :: { ExtFCode CmmExpr } 
477         : expr '/' expr                 { mkMachOp MO_U_Quot [$1,$3] }
478         | expr '*' expr                 { mkMachOp MO_Mul [$1,$3] }
479         | expr '%' expr                 { mkMachOp MO_U_Rem [$1,$3] }
480         | expr '-' expr                 { mkMachOp MO_Sub [$1,$3] }
481         | expr '+' expr                 { mkMachOp MO_Add [$1,$3] }
482         | expr '>>' expr                { mkMachOp MO_U_Shr [$1,$3] }
483         | expr '<<' expr                { mkMachOp MO_Shl [$1,$3] }
484         | expr '&' expr                 { mkMachOp MO_And [$1,$3] }
485         | expr '^' expr                 { mkMachOp MO_Xor [$1,$3] }
486         | expr '|' expr                 { mkMachOp MO_Or [$1,$3] }
487         | expr '>=' expr                { mkMachOp MO_U_Ge [$1,$3] }
488         | expr '>' expr                 { mkMachOp MO_U_Gt [$1,$3] }
489         | expr '<=' expr                { mkMachOp MO_U_Le [$1,$3] }
490         | expr '<' expr                 { mkMachOp MO_U_Lt [$1,$3] }
491         | expr '!=' expr                { mkMachOp MO_Ne [$1,$3] }
492         | expr '==' expr                { mkMachOp MO_Eq [$1,$3] }
493         | '~' expr                      { mkMachOp MO_Not [$2] }
494         | '-' expr                      { mkMachOp MO_S_Neg [$2] }
495         | expr0 '`' NAME '`' expr0      {% do { mo <- nameToMachOp $3 ;
496                                                 return (mkMachOp mo [$1,$5]) } }
497         | expr0                         { $1 }
498
499 expr0   :: { ExtFCode CmmExpr }
500         : INT   maybe_ty         { return (CmmLit (CmmInt $1 (typeWidth $2))) }
501         | FLOAT maybe_ty         { return (CmmLit (CmmFloat $1 (typeWidth $2))) }
502         | STRING                 { do s <- code (mkStringCLit $1); 
503                                       return (CmmLit s) }
504         | reg                    { $1 }
505         | type '[' expr ']'      { do e <- $3; return (CmmLoad e $1) }
506         | '%' NAME '(' exprs0 ')' {% exprOp $2 $4 }
507         | '(' expr ')'           { $2 }
508
509
510 -- leaving out the type of a literal gives you the native word size in C--
511 maybe_ty :: { CmmType }
512         : {- empty -}                   { bWord }
513         | '::' type                     { $2 }
514
515 maybe_actuals :: { [ExtFCode HintedCmmActual] }
516         : {- empty -}           { [] }
517         | '(' cmm_hint_exprs0 ')'       { $2 }
518
519 cmm_hint_exprs0 :: { [ExtFCode HintedCmmActual] }
520         : {- empty -}                   { [] }
521         | cmm_hint_exprs                        { $1 }
522
523 cmm_hint_exprs :: { [ExtFCode HintedCmmActual] }
524         : cmm_hint_expr                 { [$1] }
525         | cmm_hint_expr ',' cmm_hint_exprs      { $1 : $3 }
526
527 cmm_hint_expr :: { ExtFCode HintedCmmActual }
528         : expr                          { do e <- $1; return (CmmHinted e (inferCmmHint e)) }
529         | expr STRING                   {% do h <- parseCmmHint $2;
530                                               return $ do
531                                                 e <- $1; return (CmmHinted e h) }
532
533 exprs0  :: { [ExtFCode CmmExpr] }
534         : {- empty -}                   { [] }
535         | exprs                         { $1 }
536
537 exprs   :: { [ExtFCode CmmExpr] }
538         : expr                          { [ $1 ] }
539         | expr ',' exprs                { $1 : $3 }
540
541 reg     :: { ExtFCode CmmExpr }
542         : NAME                  { lookupName $1 }
543         | GLOBALREG             { return (CmmReg (CmmGlobal $1)) }
544
545 maybe_results :: { [ExtFCode HintedCmmFormal] }
546         : {- empty -}           { [] }
547         | '(' cmm_formals ')' '='       { $2 }
548
549 cmm_formals :: { [ExtFCode HintedCmmFormal] }
550         : cmm_formal                    { [$1] }
551         | cmm_formal ','                        { [$1] }
552         | cmm_formal ',' cmm_formals    { $1 : $3 }
553
554 cmm_formal :: { ExtFCode HintedCmmFormal }
555         : local_lreg                    { do e <- $1; return (CmmHinted e (inferCmmHint (CmmReg (CmmLocal e)))) }
556         | STRING local_lreg             {% do h <- parseCmmHint $1;
557                                               return $ do
558                                                 e <- $2; return (CmmHinted e h) }
559
560 local_lreg :: { ExtFCode LocalReg }
561         : NAME                  { do e <- lookupName $1;
562                                      return $
563                                        case e of 
564                                         CmmReg (CmmLocal r) -> r
565                                         other -> pprPanic "CmmParse:" (ftext $1 <> text " not a local register") }
566
567 lreg    :: { ExtFCode CmmReg }
568         : NAME                  { do e <- lookupName $1;
569                                      return $
570                                        case e of 
571                                         CmmReg r -> r
572                                         other -> pprPanic "CmmParse:" (ftext $1 <> text " not a register") }
573         | GLOBALREG             { return (CmmGlobal $1) }
574
575 maybe_formals_without_hints :: { [ExtFCode LocalReg] }
576         : {- empty -}           { [] }
577         | '(' formals_without_hints0 ')'        { $2 }
578
579 formals_without_hints0 :: { [ExtFCode LocalReg] }
580         : {- empty -}           { [] }
581         | formals_without_hints         { $1 }
582
583 formals_without_hints :: { [ExtFCode LocalReg] }
584         : formal_without_hint ','               { [$1] }
585         | formal_without_hint           { [$1] }
586         | formal_without_hint ',' formals_without_hints { $1 : $3 }
587
588 formal_without_hint :: { ExtFCode LocalReg }
589         : type NAME             { newLocal $1 $2 }
590
591 maybe_frame :: { ExtFCode (Maybe UpdateFrame) }
592         : {- empty -}                   { return Nothing }
593         | 'jump' expr '(' exprs0 ')'    { do { target <- $2;
594                                                args <- sequence $4;
595                                                return $ Just (UpdateFrame target args) } }
596
597 maybe_gc_block :: { ExtFCode (Maybe BlockId) }
598         : {- empty -}                   { return Nothing }
599         | 'goto' NAME
600                 { do l <- lookupLabel $2; return (Just l) }
601
602 type    :: { CmmType }
603         : 'bits8'               { b8 }
604         | typenot8              { $1 }
605
606 typenot8 :: { CmmType }
607         : 'bits16'              { b16 }
608         | 'bits32'              { b32 }
609         | 'bits64'              { b64 }
610         | 'float32'             { f32 }
611         | 'float64'             { f64 }
612         | 'gcptr'               { gcWord }
613 {
614 section :: String -> Section
615 section "text"   = Text
616 section "data"   = Data
617 section "rodata" = ReadOnlyData
618 section "relrodata" = RelocatableReadOnlyData
619 section "bss"    = UninitialisedData
620 section s        = OtherSection s
621
622 mkString :: String -> CmmStatic
623 mkString s = CmmString (map (fromIntegral.ord) s)
624
625 -- mkMachOp infers the type of the MachOp from the type of its first
626 -- argument.  We assume that this is correct: for MachOps that don't have
627 -- symmetrical args (e.g. shift ops), the first arg determines the type of
628 -- the op.
629 mkMachOp :: (Width -> MachOp) -> [ExtFCode CmmExpr] -> ExtFCode CmmExpr
630 mkMachOp fn args = do
631   arg_exprs <- sequence args
632   return (CmmMachOp (fn (typeWidth (cmmExprType (head arg_exprs)))) arg_exprs)
633
634 getLit :: CmmExpr -> CmmLit
635 getLit (CmmLit l) = l
636 getLit (CmmMachOp (MO_S_Neg _) [CmmLit (CmmInt i r)])  = CmmInt (negate i) r
637 getLit _ = panic "invalid literal" -- TODO messy failure
638
639 nameToMachOp :: FastString -> P (Width -> MachOp)
640 nameToMachOp name = 
641   case lookupUFM machOps name of
642         Nothing -> fail ("unknown primitive " ++ unpackFS name)
643         Just m  -> return m
644
645 exprOp :: FastString -> [ExtFCode CmmExpr] -> P (ExtFCode CmmExpr)
646 exprOp name args_code =
647   case lookupUFM exprMacros name of
648      Just f  -> return $ do
649         args <- sequence args_code
650         return (f args)
651      Nothing -> do
652         mo <- nameToMachOp name
653         return $ mkMachOp mo args_code
654
655 exprMacros :: UniqFM ([CmmExpr] -> CmmExpr)
656 exprMacros = listToUFM [
657   ( fsLit "ENTRY_CODE",   \ [x] -> entryCode x ),
658   ( fsLit "INFO_PTR",     \ [x] -> closureInfoPtr x ),
659   ( fsLit "STD_INFO",     \ [x] -> infoTable x ),
660   ( fsLit "FUN_INFO",     \ [x] -> funInfoTable x ),
661   ( fsLit "GET_ENTRY",    \ [x] -> entryCode (closureInfoPtr x) ),
662   ( fsLit "GET_STD_INFO", \ [x] -> infoTable (closureInfoPtr x) ),
663   ( fsLit "GET_FUN_INFO", \ [x] -> funInfoTable (closureInfoPtr x) ),
664   ( fsLit "INFO_TYPE",    \ [x] -> infoTableClosureType x ),
665   ( fsLit "INFO_PTRS",    \ [x] -> infoTablePtrs x ),
666   ( fsLit "INFO_NPTRS",   \ [x] -> infoTableNonPtrs x )
667   ]
668
669 -- we understand a subset of C-- primitives:
670 machOps = listToUFM $
671         map (\(x, y) -> (mkFastString x, y)) [
672         ( "add",        MO_Add ),
673         ( "sub",        MO_Sub ),
674         ( "eq",         MO_Eq ),
675         ( "ne",         MO_Ne ),
676         ( "mul",        MO_Mul ),
677         ( "neg",        MO_S_Neg ),
678         ( "quot",       MO_S_Quot ),
679         ( "rem",        MO_S_Rem ),
680         ( "divu",       MO_U_Quot ),
681         ( "modu",       MO_U_Rem ),
682
683         ( "ge",         MO_S_Ge ),
684         ( "le",         MO_S_Le ),
685         ( "gt",         MO_S_Gt ),
686         ( "lt",         MO_S_Lt ),
687
688         ( "geu",        MO_U_Ge ),
689         ( "leu",        MO_U_Le ),
690         ( "gtu",        MO_U_Gt ),
691         ( "ltu",        MO_U_Lt ),
692
693         ( "and",        MO_And ),
694         ( "or",         MO_Or ),
695         ( "xor",        MO_Xor ),
696         ( "com",        MO_Not ),
697         ( "shl",        MO_Shl ),
698         ( "shrl",       MO_U_Shr ),
699         ( "shra",       MO_S_Shr ),
700
701         ( "fadd",       MO_F_Add ),
702         ( "fsub",       MO_F_Sub ),
703         ( "fneg",       MO_F_Neg ),
704         ( "fmul",       MO_F_Mul ),
705         ( "fquot",      MO_F_Quot ),
706
707         ( "feq",        MO_F_Eq ),
708         ( "fne",        MO_F_Ne ),
709         ( "fge",        MO_F_Ge ),
710         ( "fle",        MO_F_Le ),
711         ( "fgt",        MO_F_Gt ),
712         ( "flt",        MO_F_Lt ),
713
714         ( "lobits8",  flip MO_UU_Conv W8  ),
715         ( "lobits16", flip MO_UU_Conv W16 ),
716         ( "lobits32", flip MO_UU_Conv W32 ),
717         ( "lobits64", flip MO_UU_Conv W64 ),
718
719         ( "zx16",     flip MO_UU_Conv W16 ),
720         ( "zx32",     flip MO_UU_Conv W32 ),
721         ( "zx64",     flip MO_UU_Conv W64 ),
722
723         ( "sx16",     flip MO_SS_Conv W16 ),
724         ( "sx32",     flip MO_SS_Conv W32 ),
725         ( "sx64",     flip MO_SS_Conv W64 ),
726
727         ( "f2f32",    flip MO_FF_Conv W32 ),  -- TODO; rounding mode
728         ( "f2f64",    flip MO_FF_Conv W64 ),  -- TODO; rounding mode
729         ( "f2i8",     flip MO_FS_Conv W8 ),
730         ( "f2i16",    flip MO_FS_Conv W16 ),
731         ( "f2i32",    flip MO_FS_Conv W32 ),
732         ( "f2i64",    flip MO_FS_Conv W64 ),
733         ( "i2f32",    flip MO_SF_Conv W32 ),
734         ( "i2f64",    flip MO_SF_Conv W64 )
735         ]
736
737 callishMachOps = listToUFM $
738         map (\(x, y) -> (mkFastString x, y)) [
739         ( "write_barrier", MO_WriteBarrier ),
740         ( "memcpy", MO_Memcpy ),
741         ( "memset", MO_Memset ),
742         ( "memmove", MO_Memmove )
743         -- ToDo: the rest, maybe
744     ]
745
746 parseSafety :: String -> P CmmSafety
747 parseSafety "safe"   = return (CmmSafe NoC_SRT)
748 parseSafety "unsafe" = return CmmUnsafe
749 parseSafety "interruptible" = return CmmInterruptible
750 parseSafety str      = fail ("unrecognised safety: " ++ str)
751
752 parseCmmHint :: String -> P ForeignHint
753 parseCmmHint "ptr"    = return AddrHint
754 parseCmmHint "signed" = return SignedHint
755 parseCmmHint str      = fail ("unrecognised hint: " ++ str)
756
757 -- labels are always pointers, so we might as well infer the hint
758 inferCmmHint :: CmmExpr -> ForeignHint
759 inferCmmHint (CmmLit (CmmLabel _)) = AddrHint
760 inferCmmHint (CmmReg (CmmGlobal g)) | isPtrGlobalReg g = AddrHint
761 inferCmmHint _ = NoHint
762
763 isPtrGlobalReg Sp                    = True
764 isPtrGlobalReg SpLim                 = True
765 isPtrGlobalReg Hp                    = True
766 isPtrGlobalReg HpLim                 = True
767 isPtrGlobalReg CurrentTSO            = True
768 isPtrGlobalReg CurrentNursery        = True
769 isPtrGlobalReg (VanillaReg _ VGcPtr) = True
770 isPtrGlobalReg _                     = False
771
772 happyError :: P a
773 happyError = srcParseFail
774
775 -- -----------------------------------------------------------------------------
776 -- Statement-level macros
777
778 stmtMacro :: FastString -> [ExtFCode CmmExpr] -> P ExtCode
779 stmtMacro fun args_code = do
780   case lookupUFM stmtMacros fun of
781     Nothing -> fail ("unknown macro: " ++ unpackFS fun)
782     Just fcode -> return $ do
783         args <- sequence args_code
784         code (fcode args)
785
786 stmtMacros :: UniqFM ([CmmExpr] -> Code)
787 stmtMacros = listToUFM [
788   ( fsLit "CCS_ALLOC",             \[words,ccs]  -> profAlloc words ccs ),
789   ( fsLit "CLOSE_NURSERY",         \[]  -> emitCloseNursery ),
790   ( fsLit "ENTER_CCS_PAP_CL",     \[e] -> enterCostCentrePAP e ),
791   ( fsLit "ENTER_CCS_THUNK",      \[e] -> enterCostCentreThunk e ),
792   ( fsLit "HP_CHK_GEN",           \[words,liveness,reentry] -> 
793                                       hpChkGen words liveness reentry ),
794   ( fsLit "HP_CHK_NP_ASSIGN_SP0", \[e,f] -> hpChkNodePointsAssignSp0 e f ),
795   ( fsLit "LOAD_THREAD_STATE",    \[] -> emitLoadThreadState ),
796   ( fsLit "LDV_ENTER",            \[e] -> ldvEnter e ),
797   ( fsLit "LDV_RECORD_CREATE",    \[e] -> ldvRecordCreate e ),
798   ( fsLit "OPEN_NURSERY",          \[]  -> emitOpenNursery ),
799   ( fsLit "PUSH_UPD_FRAME",        \[sp,e] -> emitPushUpdateFrame sp e ),
800   ( fsLit "SAVE_THREAD_STATE",    \[] -> emitSaveThreadState ),
801   ( fsLit "SET_HDR",               \[ptr,info,ccs] -> 
802                                         emitSetDynHdr ptr info ccs ),
803   ( fsLit "STK_CHK_GEN",          \[words,liveness,reentry] -> 
804                                       stkChkGen words liveness reentry ),
805   ( fsLit "STK_CHK_NP",    \[e] -> stkChkNodePoints e ),
806   ( fsLit "TICK_ALLOC_PRIM",       \[hdr,goods,slop] -> 
807                                         tickyAllocPrim hdr goods slop ),
808   ( fsLit "TICK_ALLOC_PAP",       \[goods,slop] -> 
809                                         tickyAllocPAP goods slop ),
810   ( fsLit "TICK_ALLOC_UP_THK",    \[goods,slop] -> 
811                                         tickyAllocThunk goods slop ),
812   ( fsLit "UPD_BH_UPDATABLE",       \[] -> emitBlackHoleCode False ),
813   ( fsLit "UPD_BH_SINGLE_ENTRY",    \[] -> emitBlackHoleCode True ),
814
815   ( fsLit "RET_P",      \[a] ->       emitRetUT [(PtrArg,a)]),
816   ( fsLit "RET_N",      \[a] ->       emitRetUT [(NonPtrArg,a)]),
817   ( fsLit "RET_PP",     \[a,b] ->     emitRetUT [(PtrArg,a),(PtrArg,b)]),
818   ( fsLit "RET_NN",     \[a,b] ->     emitRetUT [(NonPtrArg,a),(NonPtrArg,b)]),
819   ( fsLit "RET_NP",     \[a,b] ->     emitRetUT [(NonPtrArg,a),(PtrArg,b)]),
820   ( fsLit "RET_PPP",    \[a,b,c] ->   emitRetUT [(PtrArg,a),(PtrArg,b),(PtrArg,c)]),
821   ( fsLit "RET_NPP",    \[a,b,c] ->   emitRetUT [(NonPtrArg,a),(PtrArg,b),(PtrArg,c)]),
822   ( fsLit "RET_NNP",    \[a,b,c] ->   emitRetUT [(NonPtrArg,a),(NonPtrArg,b),(PtrArg,c)]),
823   ( fsLit "RET_NNN",  \[a,b,c] -> emitRetUT [(NonPtrArg,a),(NonPtrArg,b),(NonPtrArg,c)]),
824   ( fsLit "RET_NNNN",  \[a,b,c,d] -> emitRetUT [(NonPtrArg,a),(NonPtrArg,b),(NonPtrArg,c),(NonPtrArg,d)]),
825   ( fsLit "RET_NNNP",   \[a,b,c,d] -> emitRetUT [(NonPtrArg,a),(NonPtrArg,b),(NonPtrArg,c),(PtrArg,d)]),
826   ( fsLit "RET_NPNP",   \[a,b,c,d] -> emitRetUT [(NonPtrArg,a),(PtrArg,b),(NonPtrArg,c),(PtrArg,d)])
827
828  ]
829
830
831
832 profilingInfo desc_str ty_str = do
833   lit1 <- if opt_SccProfilingOn 
834                    then code $ mkStringCLit desc_str
835                    else return (mkIntCLit 0)
836   lit2 <- if opt_SccProfilingOn 
837                    then code $ mkStringCLit ty_str
838                    else return (mkIntCLit 0)
839   return (ProfilingInfo lit1 lit2)
840
841
842 staticClosure :: PackageId -> FastString -> FastString -> [CmmLit] -> ExtCode
843 staticClosure pkg cl_label info payload
844   = code $ emitDataLits (mkCmmDataLabel pkg cl_label) lits
845   where  lits = mkStaticClosure (mkCmmInfoLabel pkg info) dontCareCCS payload [] [] []
846
847 foreignCall
848         :: String
849         -> [ExtFCode HintedCmmFormal]
850         -> ExtFCode CmmExpr
851         -> [ExtFCode HintedCmmActual]
852         -> Maybe [GlobalReg]
853         -> CmmSafety
854         -> CmmReturnInfo
855         -> P ExtCode
856 foreignCall conv_string results_code expr_code args_code vols safety ret
857   = do  convention <- case conv_string of
858           "C" -> return CCallConv
859           "stdcall" -> return StdCallConv
860           "C--" -> return CmmCallConv
861           _ -> fail ("unknown calling convention: " ++ conv_string)
862         return $ do
863           results <- sequence results_code
864           expr <- expr_code
865           args <- sequence args_code
866           --code (stmtC (CmmCall (CmmCallee expr convention) results args safety))
867           case convention of
868             -- Temporary hack so at least some functions are CmmSafe
869             CmmCallConv -> code (stmtC (CmmCall (CmmCallee expr convention) results args safety ret))
870             _ ->
871               let expr' = adjCallTarget convention expr args in
872               case safety of
873               CmmUnsafe ->
874                 code (emitForeignCall' PlayRisky results 
875                    (CmmCallee expr' convention) args vols NoC_SRT ret)
876               CmmSafe srt ->
877                 code (emitForeignCall' PlaySafe results 
878                    (CmmCallee expr' convention) args vols NoC_SRT ret) where
879               CmmInterruptible ->
880                 code (emitForeignCall' PlayInterruptible results 
881                    (CmmCallee expr' convention) args vols NoC_SRT ret)
882
883 adjCallTarget :: CCallConv -> CmmExpr -> [CmmHinted CmmExpr] -> CmmExpr
884 #ifdef mingw32_TARGET_OS
885 -- On Windows, we have to add the '@N' suffix to the label when making
886 -- a call with the stdcall calling convention.
887 adjCallTarget StdCallConv (CmmLit (CmmLabel lbl)) args
888   = CmmLit (CmmLabel (addLabelSize lbl (sum (map size args))))
889   where size (CmmHinted e _) = max wORD_SIZE (widthInBytes (typeWidth (cmmExprType e)))
890                  -- c.f. CgForeignCall.emitForeignCall
891 #endif
892 adjCallTarget _ expr _
893   = expr
894
895 primCall
896         :: [ExtFCode HintedCmmFormal]
897         -> FastString
898         -> [ExtFCode HintedCmmActual]
899         -> Maybe [GlobalReg]
900         -> CmmSafety
901         -> P ExtCode
902 primCall results_code name args_code vols safety
903   = case lookupUFM callishMachOps name of
904         Nothing -> fail ("unknown primitive " ++ unpackFS name)
905         Just p  -> return $ do
906                 results <- sequence results_code
907                 args <- sequence args_code
908                 case safety of
909                   CmmUnsafe ->
910                     code (emitForeignCall' PlayRisky results
911                       (CmmPrim p) args vols NoC_SRT CmmMayReturn)
912                   CmmSafe srt ->
913                     code (emitForeignCall' PlaySafe results 
914                       (CmmPrim p) args vols NoC_SRT CmmMayReturn) where
915                   CmmInterruptible ->
916                     code (emitForeignCall' PlayInterruptible results 
917                       (CmmPrim p) args vols NoC_SRT CmmMayReturn)
918
919 doStore :: CmmType -> ExtFCode CmmExpr  -> ExtFCode CmmExpr -> ExtCode
920 doStore rep addr_code val_code
921   = do addr <- addr_code
922        val <- val_code
923         -- if the specified store type does not match the type of the expr
924         -- on the rhs, then we insert a coercion that will cause the type
925         -- mismatch to be flagged by cmm-lint.  If we don't do this, then
926         -- the store will happen at the wrong type, and the error will not
927         -- be noticed.
928        let val_width = typeWidth (cmmExprType val)
929            rep_width = typeWidth rep
930        let coerce_val 
931                 | val_width /= rep_width = CmmMachOp (MO_UU_Conv val_width rep_width) [val]
932                 | otherwise              = val
933        stmtEC (CmmStore addr coerce_val)
934
935 -- Return an unboxed tuple.
936 emitRetUT :: [(CgRep,CmmExpr)] -> Code
937 emitRetUT args = do
938   tickyUnboxedTupleReturn (length args)  -- TICK
939   (sp, stmts) <- pushUnboxedTuple 0 args
940   emitSimultaneously stmts -- NB. the args might overlap with the stack slots
941                            -- or regs that we assign to, so better use
942                            -- simultaneous assignments here (#3546)
943   when (sp /= 0) $ stmtC (CmmAssign spReg (cmmRegOffW spReg (-sp)))
944   stmtC (CmmJump (entryCode (CmmLoad (cmmRegOffW spReg sp) bWord)) [])
945   -- TODO (when using CPS): emitStmt (CmmReturn (map snd args))
946
947 -- -----------------------------------------------------------------------------
948 -- If-then-else and boolean expressions
949
950 data BoolExpr
951   = BoolExpr `BoolAnd` BoolExpr
952   | BoolExpr `BoolOr`  BoolExpr
953   | BoolNot BoolExpr
954   | BoolTest CmmExpr
955
956 -- ToDo: smart constructors which simplify the boolean expression.
957
958 cmmIfThenElse cond then_part else_part = do
959      then_id <- code newLabelC
960      join_id <- code newLabelC
961      c <- cond
962      emitCond c then_id
963      else_part
964      stmtEC (CmmBranch join_id)
965      code (labelC then_id)
966      then_part
967      -- fall through to join
968      code (labelC join_id)
969
970 cmmRawIf cond then_id = do
971     c <- cond
972     emitCond c then_id
973
974 -- 'emitCond cond true_id'  emits code to test whether the cond is true,
975 -- branching to true_id if so, and falling through otherwise.
976 emitCond (BoolTest e) then_id = do
977   stmtEC (CmmCondBranch e then_id)
978 emitCond (BoolNot (BoolTest (CmmMachOp op args))) then_id
979   | Just op' <- maybeInvertComparison op
980   = emitCond (BoolTest (CmmMachOp op' args)) then_id
981 emitCond (BoolNot e) then_id = do
982   else_id <- code newLabelC
983   emitCond e else_id
984   stmtEC (CmmBranch then_id)
985   code (labelC else_id)
986 emitCond (e1 `BoolOr` e2) then_id = do
987   emitCond e1 then_id
988   emitCond e2 then_id
989 emitCond (e1 `BoolAnd` e2) then_id = do
990         -- we'd like to invert one of the conditionals here to avoid an
991         -- extra branch instruction, but we can't use maybeInvertComparison
992         -- here because we can't look too closely at the expression since
993         -- we're in a loop.
994   and_id <- code newLabelC
995   else_id <- code newLabelC
996   emitCond e1 and_id
997   stmtEC (CmmBranch else_id)
998   code (labelC and_id)
999   emitCond e2 then_id
1000   code (labelC else_id)
1001
1002
1003 -- -----------------------------------------------------------------------------
1004 -- Table jumps
1005
1006 -- We use a simplified form of C-- switch statements for now.  A
1007 -- switch statement always compiles to a table jump.  Each arm can
1008 -- specify a list of values (not ranges), and there can be a single
1009 -- default branch.  The range of the table is given either by the
1010 -- optional range on the switch (eg. switch [0..7] {...}), or by
1011 -- the minimum/maximum values from the branches.
1012
1013 doSwitch :: Maybe (Int,Int) -> ExtFCode CmmExpr -> [([Int],Either BlockId ExtCode)]
1014          -> Maybe ExtCode -> ExtCode
1015 doSwitch mb_range scrut arms deflt
1016    = do 
1017         -- Compile code for the default branch
1018         dflt_entry <- 
1019                 case deflt of
1020                   Nothing -> return Nothing
1021                   Just e  -> do b <- forkLabelledCodeEC e; return (Just b)
1022
1023         -- Compile each case branch
1024         table_entries <- mapM emitArm arms
1025
1026         -- Construct the table
1027         let
1028             all_entries = concat table_entries
1029             ixs = map fst all_entries
1030             (min,max) 
1031                 | Just (l,u) <- mb_range = (l,u)
1032                 | otherwise              = (minimum ixs, maximum ixs)
1033
1034             entries = elems (accumArray (\_ a -> Just a) dflt_entry (min,max)
1035                                 all_entries)
1036         expr <- scrut
1037         -- ToDo: check for out of range and jump to default if necessary
1038         stmtEC (CmmSwitch expr entries)
1039    where
1040         emitArm :: ([Int],Either BlockId ExtCode) -> ExtFCode [(Int,BlockId)]
1041         emitArm (ints,Left blockid) = return [ (i,blockid) | i <- ints ]
1042         emitArm (ints,Right code) = do
1043            blockid <- forkLabelledCodeEC code
1044            return [ (i,blockid) | i <- ints ]
1045
1046 -- -----------------------------------------------------------------------------
1047 -- Putting it all together
1048
1049 -- The initial environment: we define some constants that the compiler
1050 -- knows about here.
1051 initEnv :: Env
1052 initEnv = listToUFM [
1053   ( fsLit "SIZEOF_StgHeader", 
1054     Var (CmmLit (CmmInt (fromIntegral (fixedHdrSize * wORD_SIZE)) wordWidth) )),
1055   ( fsLit "SIZEOF_StgInfoTable",
1056     Var (CmmLit (CmmInt (fromIntegral stdInfoTableSizeB) wordWidth) ))
1057   ]
1058
1059 parseCmmFile :: DynFlags -> FilePath -> IO (Messages, Maybe Cmm)
1060 parseCmmFile dflags filename = do
1061   showPass dflags "ParseCmm"
1062   buf <- hGetStringBuffer filename
1063   let
1064         init_loc = mkRealSrcLoc (mkFastString filename) 1 1
1065         init_state = (mkPState dflags buf init_loc) { lex_state = [0] }
1066                 -- reset the lex_state: the Lexer monad leaves some stuff
1067                 -- in there we don't want.
1068   case unP cmmParse init_state of
1069     PFailed span err -> do
1070         let msg = mkPlainErrMsg span err
1071         return ((emptyBag, unitBag msg), Nothing)
1072     POk pst code -> do
1073         cmm <- initC dflags no_module (getCmm (unEC code initEnv [] >> return ()))
1074         let ms = getMessages pst
1075         if (errorsFound dflags ms)
1076          then return (ms, Nothing)
1077          else do
1078            dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (pprPlatform (targetPlatform dflags) cmm)
1079            return (ms, Just cmm)
1080   where
1081         no_module = panic "parseCmmFile: no module"
1082 }