Merge remote-tracking branch 'origin/HEAD' into tc-untouchables
[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 -}                   { bWord }
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'               { gcWord }
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   arg_exprs <- sequence args
634   return (CmmMachOp (fn (typeWidth (cmmExprType (head arg_exprs)))) arg_exprs)
635
636 getLit :: CmmExpr -> CmmLit
637 getLit (CmmLit l) = l
638 getLit (CmmMachOp (MO_S_Neg _) [CmmLit (CmmInt i r)])  = CmmInt (negate i) r
639 getLit _ = panic "invalid literal" -- TODO messy failure
640
641 nameToMachOp :: FastString -> P (Width -> MachOp)
642 nameToMachOp name =
643   case lookupUFM machOps name of
644         Nothing -> fail ("unknown primitive " ++ unpackFS name)
645         Just m  -> return m
646
647 exprOp :: FastString -> [ExtFCode CmmExpr] -> P (ExtFCode CmmExpr)
648 exprOp name args_code = do
649   dflags <- getDynFlags
650   case lookupUFM (exprMacros dflags) name of
651      Just f  -> return $ do
652         args <- sequence args_code
653         return (f args)
654      Nothing -> do
655         mo <- nameToMachOp name
656         return $ mkMachOp mo args_code
657
658 exprMacros :: DynFlags -> UniqFM ([CmmExpr] -> CmmExpr)
659 exprMacros dflags = listToUFM [
660   ( fsLit "ENTRY_CODE",   \ [x] -> entryCode dflags x ),
661   ( fsLit "INFO_PTR",     \ [x] -> closureInfoPtr x ),
662   ( fsLit "STD_INFO",     \ [x] -> infoTable dflags x ),
663   ( fsLit "FUN_INFO",     \ [x] -> funInfoTable dflags x ),
664   ( fsLit "GET_ENTRY",    \ [x] -> entryCode dflags (closureInfoPtr x) ),
665   ( fsLit "GET_STD_INFO", \ [x] -> infoTable dflags (closureInfoPtr x) ),
666   ( fsLit "GET_FUN_INFO", \ [x] -> funInfoTable dflags (closureInfoPtr x) ),
667   ( fsLit "INFO_TYPE",    \ [x] -> infoTableClosureType dflags x ),
668   ( fsLit "INFO_PTRS",    \ [x] -> infoTablePtrs dflags x ),
669   ( fsLit "INFO_NPTRS",   \ [x] -> infoTableNonPtrs dflags x )
670   ]
671
672 -- we understand a subset of C-- primitives:
673 machOps = listToUFM $
674         map (\(x, y) -> (mkFastString x, y)) [
675         ( "add",        MO_Add ),
676         ( "sub",        MO_Sub ),
677         ( "eq",         MO_Eq ),
678         ( "ne",         MO_Ne ),
679         ( "mul",        MO_Mul ),
680         ( "neg",        MO_S_Neg ),
681         ( "quot",       MO_S_Quot ),
682         ( "rem",        MO_S_Rem ),
683         ( "divu",       MO_U_Quot ),
684         ( "modu",       MO_U_Rem ),
685
686         ( "ge",         MO_S_Ge ),
687         ( "le",         MO_S_Le ),
688         ( "gt",         MO_S_Gt ),
689         ( "lt",         MO_S_Lt ),
690
691         ( "geu",        MO_U_Ge ),
692         ( "leu",        MO_U_Le ),
693         ( "gtu",        MO_U_Gt ),
694         ( "ltu",        MO_U_Lt ),
695
696         ( "and",        MO_And ),
697         ( "or",         MO_Or ),
698         ( "xor",        MO_Xor ),
699         ( "com",        MO_Not ),
700         ( "shl",        MO_Shl ),
701         ( "shrl",       MO_U_Shr ),
702         ( "shra",       MO_S_Shr ),
703
704         ( "fadd",       MO_F_Add ),
705         ( "fsub",       MO_F_Sub ),
706         ( "fneg",       MO_F_Neg ),
707         ( "fmul",       MO_F_Mul ),
708         ( "fquot",      MO_F_Quot ),
709
710         ( "feq",        MO_F_Eq ),
711         ( "fne",        MO_F_Ne ),
712         ( "fge",        MO_F_Ge ),
713         ( "fle",        MO_F_Le ),
714         ( "fgt",        MO_F_Gt ),
715         ( "flt",        MO_F_Lt ),
716
717         ( "lobits8",  flip MO_UU_Conv W8  ),
718         ( "lobits16", flip MO_UU_Conv W16 ),
719         ( "lobits32", flip MO_UU_Conv W32 ),
720         ( "lobits64", flip MO_UU_Conv W64 ),
721
722         ( "zx16",     flip MO_UU_Conv W16 ),
723         ( "zx32",     flip MO_UU_Conv W32 ),
724         ( "zx64",     flip MO_UU_Conv W64 ),
725
726         ( "sx16",     flip MO_SS_Conv W16 ),
727         ( "sx32",     flip MO_SS_Conv W32 ),
728         ( "sx64",     flip MO_SS_Conv W64 ),
729
730         ( "f2f32",    flip MO_FF_Conv W32 ),  -- TODO; rounding mode
731         ( "f2f64",    flip MO_FF_Conv W64 ),  -- TODO; rounding mode
732         ( "f2i8",     flip MO_FS_Conv W8 ),
733         ( "f2i16",    flip MO_FS_Conv W16 ),
734         ( "f2i32",    flip MO_FS_Conv W32 ),
735         ( "f2i64",    flip MO_FS_Conv W64 ),
736         ( "i2f32",    flip MO_SF_Conv W32 ),
737         ( "i2f64",    flip MO_SF_Conv W64 )
738         ]
739
740 callishMachOps = listToUFM $
741         map (\(x, y) -> (mkFastString x, y)) [
742         ( "write_barrier", MO_WriteBarrier ),
743         ( "memcpy", MO_Memcpy ),
744         ( "memset", MO_Memset ),
745         ( "memmove", MO_Memmove )
746         -- ToDo: the rest, maybe
747     ]
748
749 parseSafety :: String -> P CmmSafety
750 parseSafety "safe"   = return (CmmSafe NoC_SRT)
751 parseSafety "unsafe" = return CmmUnsafe
752 parseSafety "interruptible" = return CmmInterruptible
753 parseSafety str      = fail ("unrecognised safety: " ++ str)
754
755 parseCmmHint :: String -> P ForeignHint
756 parseCmmHint "ptr"    = return AddrHint
757 parseCmmHint "signed" = return SignedHint
758 parseCmmHint str      = fail ("unrecognised hint: " ++ str)
759
760 -- labels are always pointers, so we might as well infer the hint
761 inferCmmHint :: CmmExpr -> ForeignHint
762 inferCmmHint (CmmLit (CmmLabel _)) = AddrHint
763 inferCmmHint (CmmReg (CmmGlobal g)) | isPtrGlobalReg g = AddrHint
764 inferCmmHint _ = NoHint
765
766 isPtrGlobalReg Sp                    = True
767 isPtrGlobalReg SpLim                 = True
768 isPtrGlobalReg Hp                    = True
769 isPtrGlobalReg HpLim                 = True
770 isPtrGlobalReg CCCS                  = True
771 isPtrGlobalReg CurrentTSO            = True
772 isPtrGlobalReg CurrentNursery        = True
773 isPtrGlobalReg (VanillaReg _ VGcPtr) = True
774 isPtrGlobalReg _                     = False
775
776 happyError :: P a
777 happyError = srcParseFail
778
779 -- -----------------------------------------------------------------------------
780 -- Statement-level macros
781
782 stmtMacro :: FastString -> [ExtFCode CmmExpr] -> P ExtCode
783 stmtMacro fun args_code = do
784   case lookupUFM stmtMacros fun of
785     Nothing -> fail ("unknown macro: " ++ unpackFS fun)
786     Just fcode -> return $ do
787         args <- sequence args_code
788         code (fcode args)
789
790 stmtMacros :: UniqFM ([CmmExpr] -> Code)
791 stmtMacros = listToUFM [
792   ( fsLit "CCS_ALLOC",             \[words,ccs]  -> profAlloc words ccs ),
793   ( fsLit "CLOSE_NURSERY",         \[]  -> emitCloseNursery ),
794   ( fsLit "ENTER_CCS_THUNK",      \[e] -> enterCostCentreThunk e ),
795   ( fsLit "HP_CHK_GEN",           \[words,liveness,reentry] ->
796                                       hpChkGen words liveness reentry ),
797   ( fsLit "HP_CHK_NP_ASSIGN_SP0", \[e,f] -> hpChkNodePointsAssignSp0 e f ),
798   ( fsLit "LOAD_THREAD_STATE",    \[] -> emitLoadThreadState ),
799   ( fsLit "LDV_ENTER",            \[e] -> ldvEnter e ),
800   ( fsLit "LDV_RECORD_CREATE",    \[e] -> ldvRecordCreate e ),
801   ( fsLit "OPEN_NURSERY",          \[]  -> emitOpenNursery ),
802   ( fsLit "PUSH_UPD_FRAME",        \[sp,e] -> emitPushUpdateFrame sp e ),
803   ( fsLit "SAVE_THREAD_STATE",    \[] -> emitSaveThreadState ),
804   ( fsLit "SET_HDR",               \[ptr,info,ccs] ->
805                                         emitSetDynHdr ptr info ccs ),
806   ( fsLit "STK_CHK_GEN",          \[words,liveness,reentry] ->
807                                       stkChkGen words liveness reentry ),
808   ( fsLit "STK_CHK_NP",    \[e] -> stkChkNodePoints e ),
809   ( fsLit "TICK_ALLOC_PRIM",       \[hdr,goods,slop] ->
810                                         tickyAllocPrim hdr goods slop ),
811   ( fsLit "TICK_ALLOC_PAP",       \[goods,slop] ->
812                                         tickyAllocPAP goods slop ),
813   ( fsLit "TICK_ALLOC_UP_THK",    \[goods,slop] ->
814                                         tickyAllocThunk goods slop ),
815   ( fsLit "UPD_BH_UPDATABLE",       \[] -> emitBlackHoleCode False ),
816   ( fsLit "UPD_BH_SINGLE_ENTRY",    \[] -> emitBlackHoleCode True ),
817
818   ( fsLit "RET_P",      \[a] ->       emitRetUT [(PtrArg,a)]),
819   ( fsLit "RET_N",      \[a] ->       emitRetUT [(NonPtrArg,a)]),
820   ( fsLit "RET_PP",     \[a,b] ->     emitRetUT [(PtrArg,a),(PtrArg,b)]),
821   ( fsLit "RET_NN",     \[a,b] ->     emitRetUT [(NonPtrArg,a),(NonPtrArg,b)]),
822   ( fsLit "RET_NP",     \[a,b] ->     emitRetUT [(NonPtrArg,a),(PtrArg,b)]),
823   ( fsLit "RET_PPP",    \[a,b,c] ->   emitRetUT [(PtrArg,a),(PtrArg,b),(PtrArg,c)]),
824   ( fsLit "RET_NPP",    \[a,b,c] ->   emitRetUT [(NonPtrArg,a),(PtrArg,b),(PtrArg,c)]),
825   ( fsLit "RET_NNP",    \[a,b,c] ->   emitRetUT [(NonPtrArg,a),(NonPtrArg,b),(PtrArg,c)]),
826   ( fsLit "RET_NNN",  \[a,b,c] -> emitRetUT [(NonPtrArg,a),(NonPtrArg,b),(NonPtrArg,c)]),
827   ( fsLit "RET_NNNN",  \[a,b,c,d] -> emitRetUT [(NonPtrArg,a),(NonPtrArg,b),(NonPtrArg,c),(NonPtrArg,d)]),
828   ( fsLit "RET_NNNP",   \[a,b,c,d] -> emitRetUT [(NonPtrArg,a),(NonPtrArg,b),(NonPtrArg,c),(PtrArg,d)]),
829   ( fsLit "RET_NPNP",   \[a,b,c,d] -> emitRetUT [(NonPtrArg,a),(PtrArg,b),(NonPtrArg,c),(PtrArg,d)])
830
831  ]
832
833
834 profilingInfo dflags desc_str ty_str
835   = if not (dopt Opt_SccProfilingOn dflags)
836     then NoProfilingInfo
837     else ProfilingInfo (stringToWord8s desc_str)
838                        (stringToWord8s ty_str)
839
840 staticClosure :: PackageId -> FastString -> FastString -> [CmmLit] -> ExtCode
841 staticClosure pkg cl_label info payload
842   = do dflags <- getDynFlags
843        let lits = mkStaticClosure dflags (mkCmmInfoLabel pkg info) dontCareCCS payload [] [] []
844        code $ emitDataLits (mkCmmDataLabel pkg cl_label) lits
845
846 foreignCall
847         :: String
848         -> [ExtFCode HintedCmmFormal]
849         -> ExtFCode CmmExpr
850         -> [ExtFCode HintedCmmActual]
851         -> Maybe [GlobalReg]
852         -> CmmSafety
853         -> CmmReturnInfo
854         -> P ExtCode
855 foreignCall conv_string results_code expr_code args_code vols safety ret
856   = do  convention <- case conv_string of
857           "C" -> return CCallConv
858           "stdcall" -> return StdCallConv
859           "C--" -> return CmmCallConv
860           _ -> fail ("unknown calling convention: " ++ conv_string)
861         return $ do
862           dflags <- getDynFlags
863           let platform = targetPlatform dflags
864           results <- sequence results_code
865           expr <- expr_code
866           args <- sequence args_code
867           case convention of
868             -- Temporary hack so at least some functions are CmmSafe
869             CmmCallConv -> code (stmtC (CmmCall (CmmCallee expr convention) results args ret))
870             _ ->
871               let expr' = adjCallTarget platform convention expr args in
872               case safety of
873               CmmUnsafe ->
874                 code (emitForeignCall' PlayRisky results
875                    (CmmCallee expr' convention) args vols NoC_SRT ret)
876               CmmSafe srt ->
877                 code (emitForeignCall' PlaySafe results
878                    (CmmCallee expr' convention) args vols NoC_SRT ret) where
879               CmmInterruptible ->
880                 code (emitForeignCall' PlayInterruptible results
881                    (CmmCallee expr' convention) args vols NoC_SRT ret)
882
883 adjCallTarget :: Platform -> CCallConv -> CmmExpr -> [CmmHinted CmmExpr]
884               -> CmmExpr
885 -- On Windows, we have to add the '@N' suffix to the label when making
886 -- a call with the stdcall calling convention.
887 adjCallTarget (Platform { platformOS = OSMinGW32 }) StdCallConv (CmmLit (CmmLabel lbl)) args
888   = CmmLit (CmmLabel (addLabelSize lbl (sum (map size args))))
889   where size (CmmHinted e _) = max wORD_SIZE (widthInBytes (typeWidth (cmmExprType e)))
890                  -- c.f. CgForeignCall.emitForeignCall
891 adjCallTarget _ _ expr _
892   = expr
893
894 primCall
895         :: [ExtFCode HintedCmmFormal]
896         -> FastString
897         -> [ExtFCode HintedCmmActual]
898         -> Maybe [GlobalReg]
899         -> CmmSafety
900         -> P ExtCode
901 primCall results_code name args_code vols safety
902   = case lookupUFM callishMachOps name of
903         Nothing -> fail ("unknown primitive " ++ unpackFS name)
904         Just p  -> return $ do
905                 results <- sequence results_code
906                 args <- sequence args_code
907                 case safety of
908                   CmmUnsafe ->
909                     code (emitForeignCall' PlayRisky results
910                       (CmmPrim p Nothing) args vols NoC_SRT CmmMayReturn)
911                   CmmSafe srt ->
912                     code (emitForeignCall' PlaySafe results
913                       (CmmPrim p Nothing) args vols NoC_SRT CmmMayReturn) where
914                   CmmInterruptible ->
915                     code (emitForeignCall' PlayInterruptible results
916                       (CmmPrim p Nothing) args vols NoC_SRT CmmMayReturn)
917
918 doStore :: CmmType -> ExtFCode CmmExpr  -> ExtFCode CmmExpr -> ExtCode
919 doStore rep addr_code val_code
920   = do addr <- addr_code
921        val <- val_code
922         -- if the specified store type does not match the type of the expr
923         -- on the rhs, then we insert a coercion that will cause the type
924         -- mismatch to be flagged by cmm-lint.  If we don't do this, then
925         -- the store will happen at the wrong type, and the error will not
926         -- be noticed.
927        let val_width = typeWidth (cmmExprType val)
928            rep_width = typeWidth rep
929        let coerce_val
930                 | val_width /= rep_width = CmmMachOp (MO_UU_Conv val_width rep_width) [val]
931                 | otherwise              = val
932        stmtEC (CmmStore addr coerce_val)
933
934 -- Return an unboxed tuple.
935 emitRetUT :: [(CgRep,CmmExpr)] -> Code
936 emitRetUT args = do
937   dflags <- getDynFlags
938   tickyUnboxedTupleReturn (length args)  -- TICK
939   (sp, stmts, live) <- pushUnboxedTuple 0 args
940   emitSimultaneously stmts -- NB. the args might overlap with the stack slots
941                            -- or regs that we assign to, so better use
942                            -- simultaneous assignments here (#3546)
943   when (sp /= 0) $ stmtC (CmmAssign spReg (cmmRegOffW spReg (-sp)))
944   stmtC $ CmmJump (entryCode dflags (CmmLoad (cmmRegOffW spReg sp) bWord)) (Just live)
945
946 -- -----------------------------------------------------------------------------
947 -- If-then-else and boolean expressions
948
949 data BoolExpr
950   = BoolExpr `BoolAnd` BoolExpr
951   | BoolExpr `BoolOr`  BoolExpr
952   | BoolNot BoolExpr
953   | BoolTest CmmExpr
954
955 -- ToDo: smart constructors which simplify the boolean expression.
956
957 cmmIfThenElse cond then_part else_part = do
958      then_id <- code newLabelC
959      join_id <- code newLabelC
960      c <- cond
961      emitCond c then_id
962      else_part
963      stmtEC (CmmBranch join_id)
964      code (labelC then_id)
965      then_part
966      -- fall through to join
967      code (labelC join_id)
968
969 cmmRawIf cond then_id = do
970     c <- cond
971     emitCond c then_id
972
973 -- 'emitCond cond true_id'  emits code to test whether the cond is true,
974 -- branching to true_id if so, and falling through otherwise.
975 emitCond (BoolTest e) then_id = do
976   stmtEC (CmmCondBranch e then_id)
977 emitCond (BoolNot (BoolTest (CmmMachOp op args))) then_id
978   | Just op' <- maybeInvertComparison op
979   = emitCond (BoolTest (CmmMachOp op' args)) then_id
980 emitCond (BoolNot e) then_id = do
981   else_id <- code newLabelC
982   emitCond e else_id
983   stmtEC (CmmBranch then_id)
984   code (labelC else_id)
985 emitCond (e1 `BoolOr` e2) then_id = do
986   emitCond e1 then_id
987   emitCond e2 then_id
988 emitCond (e1 `BoolAnd` e2) then_id = do
989         -- we'd like to invert one of the conditionals here to avoid an
990         -- extra branch instruction, but we can't use maybeInvertComparison
991         -- here because we can't look too closely at the expression since
992         -- we're in a loop.
993   and_id <- code newLabelC
994   else_id <- code newLabelC
995   emitCond e1 and_id
996   stmtEC (CmmBranch else_id)
997   code (labelC and_id)
998   emitCond e2 then_id
999   code (labelC else_id)
1000
1001
1002 -- -----------------------------------------------------------------------------
1003 -- Table jumps
1004
1005 -- We use a simplified form of C-- switch statements for now.  A
1006 -- switch statement always compiles to a table jump.  Each arm can
1007 -- specify a list of values (not ranges), and there can be a single
1008 -- default branch.  The range of the table is given either by the
1009 -- optional range on the switch (eg. switch [0..7] {...}), or by
1010 -- the minimum/maximum values from the branches.
1011
1012 doSwitch :: Maybe (Int,Int) -> ExtFCode CmmExpr -> [([Int],Either BlockId ExtCode)]
1013          -> Maybe ExtCode -> ExtCode
1014 doSwitch mb_range scrut arms deflt
1015    = do
1016         -- Compile code for the default branch
1017         dflt_entry <-
1018                 case deflt of
1019                   Nothing -> return Nothing
1020                   Just e  -> do b <- forkLabelledCodeEC e; return (Just b)
1021
1022         -- Compile each case branch
1023         table_entries <- mapM emitArm arms
1024
1025         -- Construct the table
1026         let
1027             all_entries = concat table_entries
1028             ixs = map fst all_entries
1029             (min,max)
1030                 | Just (l,u) <- mb_range = (l,u)
1031                 | otherwise              = (minimum ixs, maximum ixs)
1032
1033             entries = elems (accumArray (\_ a -> Just a) dflt_entry (min,max)
1034                                 all_entries)
1035         expr <- scrut
1036         -- ToDo: check for out of range and jump to default if necessary
1037         stmtEC (CmmSwitch expr entries)
1038    where
1039         emitArm :: ([Int],Either BlockId ExtCode) -> ExtFCode [(Int,BlockId)]
1040         emitArm (ints,Left blockid) = return [ (i,blockid) | i <- ints ]
1041         emitArm (ints,Right code) = do
1042            blockid <- forkLabelledCodeEC code
1043            return [ (i,blockid) | i <- ints ]
1044
1045 -- -----------------------------------------------------------------------------
1046 -- Putting it all together
1047
1048 -- The initial environment: we define some constants that the compiler
1049 -- knows about here.
1050 initEnv :: DynFlags -> Env
1051 initEnv dflags = listToUFM [
1052   ( fsLit "SIZEOF_StgHeader",
1053     VarN (CmmLit (CmmInt (fromIntegral (fixedHdrSize dflags * wORD_SIZE)) wordWidth) )),
1054   ( fsLit "SIZEOF_StgInfoTable",
1055     VarN (CmmLit (CmmInt (fromIntegral (stdInfoTableSizeB dflags)) wordWidth) ))
1056   ]
1057
1058 parseCmmFile :: DynFlags -> FilePath -> IO (Messages, Maybe CmmGroup)
1059 parseCmmFile dflags filename = do
1060   showPass dflags "ParseCmm"
1061   buf <- hGetStringBuffer filename
1062   let
1063         init_loc = mkRealSrcLoc (mkFastString filename) 1 1
1064         init_state = (mkPState dflags buf init_loc) { lex_state = [0] }
1065                 -- reset the lex_state: the Lexer monad leaves some stuff
1066                 -- in there we don't want.
1067   case unP cmmParse init_state of
1068     PFailed span err -> do
1069         let msg = mkPlainErrMsg dflags span err
1070         return ((emptyBag, unitBag msg), Nothing)
1071     POk pst code -> do
1072         st <- initC
1073         let (cmm,_) = runC dflags no_module st (getCmm (unEC code (initEnv dflags) [] >> return ()))
1074         let ms = getMessages pst
1075         if (errorsFound dflags ms)
1076          then return (ms, Nothing)
1077          else do
1078            dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (ppr cmm)
1079            return (ms, Just cmm)
1080   where
1081         no_module = panic "parseCmmFile: no module"
1082 }