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