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