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