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