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