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