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