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