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