Add formal parameters to the Cmm parser
[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         : info maybe_formals '{' body '}'
203                 { do (info_lbl, info1, info2) <- $1;
204                      formals <- sequence $2;
205                      stmts <- getCgStmtsEC (loopDecls $4)
206                      blks <- code (cgStmtsToBlocks stmts)
207                      code (emitInfoTableAndCode info_lbl info1 info2 formals blks) }
208
209         | info maybe_formals ';'
210                 { do (info_lbl, info1, info2) <- $1;
211                      formals <- sequence $2;
212                      code (emitInfoTableAndCode info_lbl info1 info2 formals []) }
213
214         | NAME maybe_formals '{' body '}'
215                 { do formals <- sequence $2;
216                      stmts <- getCgStmtsEC (loopDecls $4);
217                      blks <- code (cgStmtsToBlocks stmts);
218                      code (emitProc [] (mkRtsCodeLabelFS $1) formals blks) }
219
220 info    :: { ExtFCode (CLabel, [CmmLit],[CmmLit]) }
221         : 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
222                 -- ptrs, nptrs, closure type, description, type
223                 { stdInfo $3 $5 $7 0 $9 $11 $13 }
224         
225         | 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ')'
226                 -- ptrs, nptrs, closure type, description, type, fun type
227                 { funInfo $3 $5 $7 $9 $11 $13 $15 }
228         
229         | 'INFO_TABLE_CONSTR' '(' NAME ',' INT ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
230                 -- ptrs, nptrs, tag, closure type, description, type
231                 { conInfo $3 $5 $7 $9 $11 $13 $15 }
232         
233         | 'INFO_TABLE_SELECTOR' '(' NAME ',' INT ',' INT ',' STRING ',' STRING ')'
234                 -- selector, closure type, description, type
235                 { basicInfo $3 (mkIntCLit (fromIntegral $5)) 0 $7 $9 $11 }
236
237         | 'INFO_TABLE_RET' '(' NAME ',' INT ',' INT ',' INT ')'
238                 -- size, live bits, closure type
239                 { retInfo $3 $5 $7 $9 }
240
241 body    :: { ExtCode }
242         : {- empty -}                   { return () }
243         | decl body                     { do $1; $2 }
244         | stmt body                     { do $1; $2 }
245
246 decl    :: { ExtCode }
247         : type names ';'                { mapM_ (newLocal $1) $2 }
248         | 'import' names ';'            { return () }  -- ignore imports
249         | 'export' names ';'            { return () }  -- ignore exports
250
251 names   :: { [FastString] }
252         : NAME                  { [$1] }
253         | NAME ',' names        { $1 : $3 }
254
255 stmt    :: { ExtCode }
256         : ';'                                   { nopEC }
257
258         | NAME ':'
259                 { do l <- newLabel $1; code (labelC l) }
260
261 -- HACK: this should just be lregs but that causes a shift/reduce conflict
262 -- with foreign calls
263 --      | hint_lregs '=' expr ';'
264 --              { do reg <- head $1; e <- $3; stmtEC (CmmAssign (fst reg) e) }
265         | type '[' expr ']' '=' expr ';'
266                 { doStore $1 $3 $6 }
267         | maybe_results 'foreign' STRING expr '(' hint_exprs0 ')' vols ';'
268                 {% foreignCall $3 $1 $4 $6 $8 }
269         | maybe_results 'prim' '%' NAME '(' hint_exprs0 ')' vols ';'
270                 {% primCall $1 $4 $6 $8 }
271         -- stmt-level macros, stealing syntax from ordinary C-- function calls.
272         -- Perhaps we ought to use the %%-form?
273         | NAME '(' exprs0 ')' ';'
274                 {% stmtMacro $1 $3  }
275         | 'switch' maybe_range expr '{' arms default '}'
276                 { doSwitch $2 $3 $5 $6 }
277         | 'goto' NAME ';'
278                 { do l <- lookupLabel $2; stmtEC (CmmBranch l) }
279         | 'jump' expr maybe_actuals ';'
280                 { do e1 <- $2; e2 <- sequence $3; stmtEC (CmmJump e1 e2) }
281         | 'return' maybe_actuals ';'
282                 { do e <- sequence $2; stmtEC (CmmReturn e) }
283         | 'if' bool_expr '{' body '}' else      
284                 { ifThenElse $2 $4 $6 }
285
286 bool_expr :: { ExtFCode BoolExpr }
287         : bool_op                       { $1 }
288         | expr                          { do e <- $1; return (BoolTest e) }
289
290 bool_op :: { ExtFCode BoolExpr }
291         : bool_expr '&&' bool_expr      { do e1 <- $1; e2 <- $3; 
292                                           return (BoolAnd e1 e2) }
293         | bool_expr '||' bool_expr      { do e1 <- $1; e2 <- $3; 
294                                           return (BoolOr e1 e2)  }
295         | '!' bool_expr                 { do e <- $2; return (BoolNot e) }
296         | '(' bool_op ')'               { $2 }
297
298 -- This is not C-- syntax.  What to do?
299 vols    :: { Maybe [GlobalReg] }
300         : {- empty -}                   { Nothing }
301         | '[' ']'                       { Just [] }
302         | '[' globals ']'               { Just $2 }
303
304 globals :: { [GlobalReg] }
305         : GLOBALREG                     { [$1] }
306         | GLOBALREG ',' globals         { $1 : $3 }
307
308 maybe_range :: { Maybe (Int,Int) }
309         : '[' INT '..' INT ']'  { Just (fromIntegral $2, fromIntegral $4) }
310         | {- empty -}           { Nothing }
311
312 arms    :: { [([Int],ExtCode)] }
313         : {- empty -}                   { [] }
314         | arm arms                      { $1 : $2 }
315
316 arm     :: { ([Int],ExtCode) }
317         : 'case' ints ':' '{' body '}'  { ($2, $5) }
318
319 ints    :: { [Int] }
320         : INT                           { [ fromIntegral $1 ] }
321         | INT ',' ints                  { fromIntegral $1 : $3 }
322
323 default :: { Maybe ExtCode }
324         : 'default' ':' '{' body '}'    { Just $4 }
325         -- taking a few liberties with the C-- syntax here; C-- doesn't have
326         -- 'default' branches
327         | {- empty -}                   { Nothing }
328
329 else    :: { ExtCode }
330         : {- empty -}                   { nopEC }
331         | 'else' '{' body '}'           { $3 }
332
333 -- we have to write this out longhand so that Happy's precedence rules
334 -- can kick in.
335 expr    :: { ExtFCode CmmExpr } 
336         : expr '/' expr                 { mkMachOp MO_U_Quot [$1,$3] }
337         | expr '*' expr                 { mkMachOp MO_Mul [$1,$3] }
338         | expr '%' expr                 { mkMachOp MO_U_Rem [$1,$3] }
339         | expr '-' expr                 { mkMachOp MO_Sub [$1,$3] }
340         | expr '+' expr                 { mkMachOp MO_Add [$1,$3] }
341         | expr '>>' expr                { mkMachOp MO_U_Shr [$1,$3] }
342         | expr '<<' expr                { mkMachOp MO_Shl [$1,$3] }
343         | expr '&' expr                 { mkMachOp MO_And [$1,$3] }
344         | expr '^' expr                 { mkMachOp MO_Xor [$1,$3] }
345         | expr '|' expr                 { mkMachOp MO_Or [$1,$3] }
346         | expr '>=' expr                { mkMachOp MO_U_Ge [$1,$3] }
347         | expr '>' expr                 { mkMachOp MO_U_Gt [$1,$3] }
348         | expr '<=' expr                { mkMachOp MO_U_Le [$1,$3] }
349         | expr '<' expr                 { mkMachOp MO_U_Lt [$1,$3] }
350         | expr '!=' expr                { mkMachOp MO_Ne [$1,$3] }
351         | expr '==' expr                { mkMachOp MO_Eq [$1,$3] }
352         | '~' expr                      { mkMachOp MO_Not [$2] }
353         | '-' expr                      { mkMachOp MO_S_Neg [$2] }
354         | expr0 '`' NAME '`' expr0      {% do { mo <- nameToMachOp $3 ;
355                                                 return (mkMachOp mo [$1,$5]) } }
356         | expr0                         { $1 }
357
358 expr0   :: { ExtFCode CmmExpr }
359         : INT   maybe_ty         { return (CmmLit (CmmInt $1 $2)) }
360         | FLOAT maybe_ty         { return (CmmLit (CmmFloat $1 $2)) }
361         | STRING                 { do s <- code (mkStringCLit $1); 
362                                       return (CmmLit s) }
363         | reg                    { $1 }
364         | type '[' expr ']'      { do e <- $3; return (CmmLoad e $1) }
365         | '%' NAME '(' exprs0 ')' {% exprOp $2 $4 }
366         | '(' expr ')'           { $2 }
367
368
369 -- leaving out the type of a literal gives you the native word size in C--
370 maybe_ty :: { MachRep }
371         : {- empty -}                   { wordRep }
372         | '::' type                     { $2 }
373
374 maybe_actuals :: { [ExtFCode (CmmExpr, MachHint)] }
375         : {- empty -}           { [] }
376         | '(' hint_exprs0 ')'   { $2 }
377
378 hint_exprs0 :: { [ExtFCode (CmmExpr, MachHint)] }
379         : {- empty -}                   { [] }
380         | hint_exprs                    { $1 }
381
382 hint_exprs :: { [ExtFCode (CmmExpr, MachHint)] }
383         : hint_expr                     { [$1] }
384         | hint_expr ',' hint_exprs      { $1 : $3 }
385
386 hint_expr :: { ExtFCode (CmmExpr, MachHint) }
387         : expr                          { do e <- $1; return (e, inferHint e) }
388         | expr STRING                   {% do h <- parseHint $2;
389                                               return $ do
390                                                 e <- $1; return (e,h) }
391
392 exprs0  :: { [ExtFCode CmmExpr] }
393         : {- empty -}                   { [] }
394         | exprs                         { $1 }
395
396 exprs   :: { [ExtFCode CmmExpr] }
397         : expr                          { [ $1 ] }
398         | expr ',' exprs                { $1 : $3 }
399
400 reg     :: { ExtFCode CmmExpr }
401         : NAME                  { lookupName $1 }
402         | GLOBALREG             { return (CmmReg (CmmGlobal $1)) }
403
404 maybe_results :: { [ExtFCode (CmmReg, MachHint)] }
405         : {- empty -}           { [] }
406         | hint_lregs '='        { $1 }
407
408 hint_lregs :: { [ExtFCode (CmmReg, MachHint)] }
409         : hint_lreg ','                 { [$1] }
410         | hint_lreg                     { [$1] }
411         | hint_lreg ',' hint_lregs      { $1 : $3 }
412
413 hint_lreg :: { ExtFCode (CmmReg, MachHint) }
414         : lreg                          { do e <- $1; return (e, inferHint (CmmReg e)) }
415         | STRING lreg                   {% do h <- parseHint $1;
416                                               return $ do
417                                                 e <- $2; return (e,h) }
418
419 lreg    :: { ExtFCode CmmReg }
420         : NAME                  { do e <- lookupName $1;
421                                      return $
422                                        case e of 
423                                         CmmReg r -> r
424                                         other -> pprPanic "CmmParse:" (ftext $1 <> text " not a register") }
425         | GLOBALREG             { return (CmmGlobal $1) }
426
427 maybe_formals :: { [ExtFCode LocalReg] }
428         : {- empty -}           { [] }
429         | '(' formals0 ')'      { $2 }
430
431 formals0 :: { [ExtFCode LocalReg] }
432         : {- empty -}           { [] }
433         | formals               { $1 }
434
435 formals :: { [ExtFCode LocalReg] }
436         : formal ','            { [$1] }
437         | formal                { [$1] }
438         | formal ',' formals    { $1 : $3 }
439
440 formal :: { ExtFCode LocalReg }
441         : type NAME             { newLocal defaultKind $1 $2 }
442         | STRING type NAME      {% do k <- parseKind $1;
443                                      return $ newLocal k $2 $3 }
444
445 type    :: { MachRep }
446         : 'bits8'               { I8 }
447         | typenot8              { $1 }
448
449 typenot8 :: { MachRep }
450         : 'bits16'              { I16 }
451         | 'bits32'              { I32 }
452         | 'bits64'              { I64 }
453         | 'float32'             { F32 }
454         | 'float64'             { F64 }
455 {
456 section :: String -> Section
457 section "text"   = Text
458 section "data"   = Data
459 section "rodata" = ReadOnlyData
460 section "relrodata" = RelocatableReadOnlyData
461 section "bss"    = UninitialisedData
462 section s        = OtherSection s
463
464 mkString :: String -> CmmStatic
465 mkString s = CmmString (map (fromIntegral.ord) s)
466
467 -- mkMachOp infers the type of the MachOp from the type of its first
468 -- argument.  We assume that this is correct: for MachOps that don't have
469 -- symmetrical args (e.g. shift ops), the first arg determines the type of
470 -- the op.
471 mkMachOp :: (MachRep -> MachOp) -> [ExtFCode CmmExpr] -> ExtFCode CmmExpr
472 mkMachOp fn args = do
473   arg_exprs <- sequence args
474   return (CmmMachOp (fn (cmmExprRep (head arg_exprs))) arg_exprs)
475
476 getLit :: CmmExpr -> CmmLit
477 getLit (CmmLit l) = l
478 getLit (CmmMachOp (MO_S_Neg _) [CmmLit (CmmInt i r)])  = CmmInt (negate i) r
479 getLit _ = panic "invalid literal" -- TODO messy failure
480
481 nameToMachOp :: FastString -> P (MachRep -> MachOp)
482 nameToMachOp name = 
483   case lookupUFM machOps name of
484         Nothing -> fail ("unknown primitive " ++ unpackFS name)
485         Just m  -> return m
486
487 exprOp :: FastString -> [ExtFCode CmmExpr] -> P (ExtFCode CmmExpr)
488 exprOp name args_code =
489   case lookupUFM exprMacros name of
490      Just f  -> return $ do
491         args <- sequence args_code
492         return (f args)
493      Nothing -> do
494         mo <- nameToMachOp name
495         return $ mkMachOp mo args_code
496
497 exprMacros :: UniqFM ([CmmExpr] -> CmmExpr)
498 exprMacros = listToUFM [
499   ( FSLIT("ENTRY_CODE"),   \ [x] -> entryCode x ),
500   ( FSLIT("INFO_PTR"),     \ [x] -> closureInfoPtr x ),
501   ( FSLIT("STD_INFO"),     \ [x] -> infoTable x ),
502   ( FSLIT("FUN_INFO"),     \ [x] -> funInfoTable x ),
503   ( FSLIT("GET_ENTRY"),    \ [x] -> entryCode (closureInfoPtr x) ),
504   ( FSLIT("GET_STD_INFO"), \ [x] -> infoTable (closureInfoPtr x) ),
505   ( FSLIT("GET_FUN_INFO"), \ [x] -> funInfoTable (closureInfoPtr x) ),
506   ( FSLIT("INFO_TYPE"),    \ [x] -> infoTableClosureType x ),
507   ( FSLIT("INFO_PTRS"),    \ [x] -> infoTablePtrs x ),
508   ( FSLIT("INFO_NPTRS"),   \ [x] -> infoTableNonPtrs x )
509   ]
510
511 -- we understand a subset of C-- primitives:
512 machOps = listToUFM $
513         map (\(x, y) -> (mkFastString x, y)) [
514         ( "add",        MO_Add ),
515         ( "sub",        MO_Sub ),
516         ( "eq",         MO_Eq ),
517         ( "ne",         MO_Ne ),
518         ( "mul",        MO_Mul ),
519         ( "neg",        MO_S_Neg ),
520         ( "quot",       MO_S_Quot ),
521         ( "rem",        MO_S_Rem ),
522         ( "divu",       MO_U_Quot ),
523         ( "modu",       MO_U_Rem ),
524
525         ( "ge",         MO_S_Ge ),
526         ( "le",         MO_S_Le ),
527         ( "gt",         MO_S_Gt ),
528         ( "lt",         MO_S_Lt ),
529
530         ( "geu",        MO_U_Ge ),
531         ( "leu",        MO_U_Le ),
532         ( "gtu",        MO_U_Gt ),
533         ( "ltu",        MO_U_Lt ),
534
535         ( "flt",        MO_S_Lt ),
536         ( "fle",        MO_S_Le ),
537         ( "feq",        MO_Eq ),
538         ( "fne",        MO_Ne ),
539         ( "fgt",        MO_S_Gt ),
540         ( "fge",        MO_S_Ge ),
541         ( "fneg",       MO_S_Neg ),
542
543         ( "and",        MO_And ),
544         ( "or",         MO_Or ),
545         ( "xor",        MO_Xor ),
546         ( "com",        MO_Not ),
547         ( "shl",        MO_Shl ),
548         ( "shrl",       MO_U_Shr ),
549         ( "shra",       MO_S_Shr ),
550
551         ( "lobits8",  flip MO_U_Conv I8  ),
552         ( "lobits16", flip MO_U_Conv I16 ),
553         ( "lobits32", flip MO_U_Conv I32 ),
554         ( "lobits64", flip MO_U_Conv I64 ),
555         ( "sx16",     flip MO_S_Conv I16 ),
556         ( "sx32",     flip MO_S_Conv I32 ),
557         ( "sx64",     flip MO_S_Conv I64 ),
558         ( "zx16",     flip MO_U_Conv I16 ),
559         ( "zx32",     flip MO_U_Conv I32 ),
560         ( "zx64",     flip MO_U_Conv I64 ),
561         ( "f2f32",    flip MO_S_Conv F32 ),  -- TODO; rounding mode
562         ( "f2f64",    flip MO_S_Conv F64 ),  -- TODO; rounding mode
563         ( "f2i8",     flip MO_S_Conv I8 ),
564         ( "f2i16",    flip MO_S_Conv I16 ),
565         ( "f2i32",    flip MO_S_Conv I32 ),
566         ( "f2i64",    flip MO_S_Conv I64 ),
567         ( "i2f32",    flip MO_S_Conv F32 ),
568         ( "i2f64",    flip MO_S_Conv F64 )
569         ]
570
571 callishMachOps = listToUFM $
572         map (\(x, y) -> (mkFastString x, y)) [
573         ( "write_barrier", MO_WriteBarrier )
574         -- ToDo: the rest, maybe
575     ]
576
577 parseHint :: String -> P MachHint
578 parseHint "ptr"    = return PtrHint
579 parseHint "signed" = return SignedHint
580 parseHint "float"  = return FloatHint
581 parseHint str      = fail ("unrecognised hint: " ++ str)
582
583 -- labels are always pointers, so we might as well infer the hint
584 inferHint :: CmmExpr -> MachHint
585 inferHint (CmmLit (CmmLabel _)) = PtrHint
586 inferHint (CmmReg (CmmGlobal g)) | isPtrGlobalReg g = PtrHint
587 inferHint _ = NoHint
588
589 isPtrGlobalReg Sp               = True
590 isPtrGlobalReg SpLim            = True
591 isPtrGlobalReg Hp               = True
592 isPtrGlobalReg HpLim            = True
593 isPtrGlobalReg CurrentTSO       = True
594 isPtrGlobalReg CurrentNursery   = True
595 isPtrGlobalReg _                = False
596
597 happyError :: P a
598 happyError = srcParseFail
599
600 -- -----------------------------------------------------------------------------
601 -- Statement-level macros
602
603 stmtMacro :: FastString -> [ExtFCode CmmExpr] -> P ExtCode
604 stmtMacro fun args_code = do
605   case lookupUFM stmtMacros fun of
606     Nothing -> fail ("unknown macro: " ++ unpackFS fun)
607     Just fcode -> return $ do
608         args <- sequence args_code
609         code (fcode args)
610
611 stmtMacros :: UniqFM ([CmmExpr] -> Code)
612 stmtMacros = listToUFM [
613   ( FSLIT("CCS_ALLOC"),            \[words,ccs]  -> profAlloc words ccs ),
614   ( FSLIT("CLOSE_NURSERY"),        \[]  -> emitCloseNursery ),
615   ( FSLIT("ENTER_CCS_PAP_CL"),     \[e] -> enterCostCentrePAP e ),
616   ( FSLIT("ENTER_CCS_THUNK"),      \[e] -> enterCostCentreThunk e ),
617   ( FSLIT("HP_CHK_GEN"),           \[words,liveness,reentry] -> 
618                                       hpChkGen words liveness reentry ),
619   ( FSLIT("HP_CHK_NP_ASSIGN_SP0"), \[e,f] -> hpChkNodePointsAssignSp0 e f ),
620   ( FSLIT("LOAD_THREAD_STATE"),    \[] -> emitLoadThreadState ),
621   ( FSLIT("LDV_ENTER"),            \[e] -> ldvEnter e ),
622   ( FSLIT("LDV_RECORD_CREATE"),    \[e] -> ldvRecordCreate e ),
623   ( FSLIT("OPEN_NURSERY"),         \[]  -> emitOpenNursery ),
624   ( FSLIT("PUSH_UPD_FRAME"),       \[sp,e] -> emitPushUpdateFrame sp e ),
625   ( FSLIT("SAVE_THREAD_STATE"),    \[] -> emitSaveThreadState ),
626   ( FSLIT("SET_HDR"),              \[ptr,info,ccs] -> 
627                                         emitSetDynHdr ptr info ccs ),
628   ( FSLIT("STK_CHK_GEN"),          \[words,liveness,reentry] -> 
629                                       stkChkGen words liveness reentry ),
630   ( FSLIT("STK_CHK_NP"),           \[e] -> stkChkNodePoints e ),
631   ( FSLIT("TICK_ALLOC_PRIM"),      \[hdr,goods,slop] -> 
632                                         tickyAllocPrim hdr goods slop ),
633   ( FSLIT("TICK_ALLOC_PAP"),       \[goods,slop] -> 
634                                         tickyAllocPAP goods slop ),
635   ( FSLIT("TICK_ALLOC_UP_THK"),    \[goods,slop] -> 
636                                         tickyAllocThunk goods slop ),
637   ( FSLIT("UPD_BH_UPDATABLE"),       \[] -> emitBlackHoleCode False ),
638   ( FSLIT("UPD_BH_SINGLE_ENTRY"),    \[] -> emitBlackHoleCode True ),
639
640   ( FSLIT("RET_P"),     \[a] ->       emitRetUT [(PtrArg,a)]),
641   ( FSLIT("RET_N"),     \[a] ->       emitRetUT [(NonPtrArg,a)]),
642   ( FSLIT("RET_PP"),    \[a,b] ->     emitRetUT [(PtrArg,a),(PtrArg,b)]),
643   ( FSLIT("RET_NN"),    \[a,b] ->     emitRetUT [(NonPtrArg,a),(NonPtrArg,b)]),
644   ( FSLIT("RET_NP"),    \[a,b] ->     emitRetUT [(NonPtrArg,a),(PtrArg,b)]),
645   ( FSLIT("RET_PPP"),   \[a,b,c] ->   emitRetUT [(PtrArg,a),(PtrArg,b),(PtrArg,c)]),
646   ( FSLIT("RET_NPP"),   \[a,b,c] ->   emitRetUT [(NonPtrArg,a),(PtrArg,b),(PtrArg,c)]),
647   ( FSLIT("RET_NNP"),   \[a,b,c] ->   emitRetUT [(NonPtrArg,a),(NonPtrArg,b),(PtrArg,c)]),
648   ( FSLIT("RET_NNNP"),  \[a,b,c,d] -> emitRetUT [(NonPtrArg,a),(NonPtrArg,b),(NonPtrArg,c),(PtrArg,d)]),
649   ( FSLIT("RET_NPNP"),  \[a,b,c,d] -> emitRetUT [(NonPtrArg,a),(PtrArg,b),(NonPtrArg,c),(PtrArg,d)])
650
651  ]
652
653 -- -----------------------------------------------------------------------------
654 -- Our extended FCode monad.
655
656 -- We add a mapping from names to CmmExpr, to support local variable names in
657 -- the concrete C-- code.  The unique supply of the underlying FCode monad
658 -- is used to grab a new unique for each local variable.
659
660 -- In C--, a local variable can be declared anywhere within a proc,
661 -- and it scopes from the beginning of the proc to the end.  Hence, we have
662 -- to collect declarations as we parse the proc, and feed the environment
663 -- back in circularly (to avoid a two-pass algorithm).
664
665 data Named = Var CmmExpr | Label BlockId
666 type Decls = [(FastString,Named)]
667 type Env   = UniqFM Named
668
669 newtype ExtFCode a = EC { unEC :: Env -> Decls -> FCode (Decls, a) }
670
671 type ExtCode = ExtFCode ()
672
673 returnExtFC a = EC $ \e s -> return (s, a)
674 thenExtFC (EC m) k = EC $ \e s -> do (s',r) <- m e s; unEC (k r) e s'
675
676 instance Monad ExtFCode where
677   (>>=) = thenExtFC
678   return = returnExtFC
679
680 -- This function takes the variable decarations and imports and makes 
681 -- an environment, which is looped back into the computation.  In this
682 -- way, we can have embedded declarations that scope over the whole
683 -- procedure, and imports that scope over the entire module.
684 loopDecls :: ExtFCode a -> ExtFCode a
685 loopDecls (EC fcode) = 
686    EC $ \e s -> fixC (\ ~(decls,a) -> fcode (addListToUFM e decls) [])
687
688 getEnv :: ExtFCode Env
689 getEnv = EC $ \e s -> return (s, e)
690
691 addVarDecl :: FastString -> CmmExpr -> ExtCode
692 addVarDecl var expr = EC $ \e s -> return ((var, Var expr):s, ())
693
694 addLabel :: FastString -> BlockId -> ExtCode
695 addLabel name block_id = EC $ \e s -> return ((name, Label block_id):s, ())
696
697 newLocal :: MachRep -> FastString -> ExtCode
698 newLocal ty name  = do
699    u <- code newUnique
700    addVarDecl name (CmmReg (CmmLocal (LocalReg u ty)))
701
702 newLabel :: FastString -> ExtFCode BlockId
703 newLabel name = do
704    u <- code newUnique
705    addLabel name (BlockId u)
706    return (BlockId u)
707
708 lookupLabel :: FastString -> ExtFCode BlockId
709 lookupLabel name = do
710   env <- getEnv
711   return $ 
712      case lookupUFM env name of
713         Just (Label l) -> l
714         _other -> BlockId (newTagUnique (getUnique name) 'L')
715
716 -- Unknown names are treated as if they had been 'import'ed.
717 -- This saves us a lot of bother in the RTS sources, at the expense of
718 -- deferring some errors to link time.
719 lookupName :: FastString -> ExtFCode CmmExpr
720 lookupName name = do
721   env <- getEnv
722   return $ 
723      case lookupUFM env name of
724         Just (Var e) -> e
725         _other -> CmmLit (CmmLabel (mkRtsCodeLabelFS name))
726
727 -- Lifting FCode computations into the ExtFCode monad:
728 code :: FCode a -> ExtFCode a
729 code fc = EC $ \e s -> do r <- fc; return (s, r)
730
731 code2 :: (FCode (Decls,b) -> FCode ((Decls,b),c))
732          -> ExtFCode b -> ExtFCode c
733 code2 f (EC ec) = EC $ \e s -> do ((s',b),c) <- f (ec e s); return (s',c)
734
735 nopEC = code nopC
736 stmtEC stmt = code (stmtC stmt)
737 stmtsEC stmts = code (stmtsC stmts)
738 getCgStmtsEC = code2 getCgStmts'
739
740 forkLabelledCodeEC ec = do
741   stmts <- getCgStmtsEC ec
742   code (forkCgStmts stmts)
743
744 retInfo name size live_bits cl_type = do
745   let liveness = smallLiveness (fromIntegral size) (fromIntegral live_bits)
746       info_lbl = mkRtsRetInfoLabelFS name
747       (info1,info2) = mkRetInfoTable info_lbl liveness NoC_SRT 
748                                 (fromIntegral cl_type)
749   return (info_lbl, info1, info2)
750
751 stdInfo name ptrs nptrs srt_bitmap cl_type desc_str ty_str =
752   basicInfo name (packHalfWordsCLit ptrs nptrs) 
753         srt_bitmap cl_type desc_str ty_str
754
755 conInfo name ptrs nptrs srt_bitmap cl_type desc_str ty_str = do
756   (lbl, info1, _) <- basicInfo name (packHalfWordsCLit ptrs nptrs) 
757                         srt_bitmap cl_type desc_str ty_str
758   desc_lit <- code $ mkStringCLit desc_str
759   let desc_field = makeRelativeRefTo lbl desc_lit
760   return (lbl, info1, [desc_field])
761
762 basicInfo name layout srt_bitmap cl_type desc_str ty_str = do
763   let info_lbl = mkRtsInfoLabelFS name
764   lit1 <- if opt_SccProfilingOn 
765                    then code $ do lit <- mkStringCLit desc_str
766                                   return (makeRelativeRefTo info_lbl lit)
767                    else return (mkIntCLit 0)
768   lit2 <- if opt_SccProfilingOn 
769                    then code $ do lit <- mkStringCLit ty_str
770                                   return (makeRelativeRefTo info_lbl lit)
771                    else return (mkIntCLit 0)
772   let info1 = mkStdInfoTable lit1 lit2 (fromIntegral cl_type) 
773                         (fromIntegral srt_bitmap)
774                         layout
775   return (info_lbl, info1, [])
776
777 funInfo name ptrs nptrs cl_type desc_str ty_str fun_type = do
778   (label,info1,_) <- stdInfo name ptrs nptrs 0{-srt_bitmap-}
779                          cl_type desc_str ty_str 
780   let info2 = mkFunGenInfoExtraBits (fromIntegral fun_type) 0 zero zero zero
781                 -- we leave most of the fields zero here.  This is only used
782                 -- to generate the BCO info table in the RTS at the moment.
783   return (label,info1,info2)
784  where
785    zero = mkIntCLit 0
786
787
788 staticClosure :: FastString -> FastString -> [CmmLit] -> ExtCode
789 staticClosure cl_label info payload
790   = code $ emitDataLits (mkRtsDataLabelFS cl_label) lits
791   where  lits = mkStaticClosure (mkRtsInfoLabelFS info) dontCareCCS payload [] [] []
792
793 foreignCall
794         :: String
795         -> [ExtFCode (CmmReg,MachHint)]
796         -> ExtFCode CmmExpr
797         -> [ExtFCode (CmmExpr,MachHint)]
798         -> Maybe [GlobalReg] -> P ExtCode
799 foreignCall conv_string results_code expr_code args_code vols
800   = do  convention <- case conv_string of
801           "C" -> return CCallConv
802           "C--" -> return CmmCallConv
803           _ -> fail ("unknown calling convention: " ++ conv_string)
804         return $ do
805           results <- sequence results_code
806           expr <- expr_code
807           args <- sequence args_code
808           code (emitForeignCall' PlayRisky results 
809                  (CmmForeignCall expr convention) args vols) where
810
811 primCall
812         :: [ExtFCode (CmmReg,MachHint)]
813         -> FastString
814         -> [ExtFCode (CmmExpr,MachHint)]
815         -> Maybe [GlobalReg] -> P ExtCode
816 primCall results_code name args_code vols
817   = case lookupUFM callishMachOps name of
818         Nothing -> fail ("unknown primitive " ++ unpackFS name)
819         Just p  -> return $ do
820                 results <- sequence results_code
821                 args <- sequence args_code
822                 code (emitForeignCall' PlayRisky results (CmmPrim p) args vols)
823
824 doStore :: MachRep -> ExtFCode CmmExpr  -> ExtFCode CmmExpr -> ExtCode
825 doStore rep addr_code val_code
826   = do addr <- addr_code
827        val <- val_code
828         -- if the specified store type does not match the type of the expr
829         -- on the rhs, then we insert a coercion that will cause the type
830         -- mismatch to be flagged by cmm-lint.  If we don't do this, then
831         -- the store will happen at the wrong type, and the error will not
832         -- be noticed.
833        let coerce_val 
834                 | cmmExprRep val /= rep = CmmMachOp (MO_U_Conv rep rep) [val]
835                 | otherwise             = val
836        stmtEC (CmmStore addr coerce_val)
837
838 -- Return an unboxed tuple.
839 emitRetUT :: [(CgRep,CmmExpr)] -> Code
840 emitRetUT args = do
841   tickyUnboxedTupleReturn (length args)  -- TICK
842   (sp, stmts) <- pushUnboxedTuple 0 args
843   emitStmts stmts
844   when (sp /= 0) $ stmtC (CmmAssign spReg (cmmRegOffW spReg (-sp)))
845   stmtC (CmmJump (entryCode (CmmLoad (cmmRegOffW spReg sp) wordRep)) [])
846
847 -- -----------------------------------------------------------------------------
848 -- If-then-else and boolean expressions
849
850 data BoolExpr
851   = BoolExpr `BoolAnd` BoolExpr
852   | BoolExpr `BoolOr`  BoolExpr
853   | BoolNot BoolExpr
854   | BoolTest CmmExpr
855
856 -- ToDo: smart constructors which simplify the boolean expression.
857
858 ifThenElse cond then_part else_part = do
859      then_id <- code newLabelC
860      join_id <- code newLabelC
861      c <- cond
862      emitCond c then_id
863      else_part
864      stmtEC (CmmBranch join_id)
865      code (labelC then_id)
866      then_part
867      -- fall through to join
868      code (labelC join_id)
869
870 -- 'emitCond cond true_id'  emits code to test whether the cond is true,
871 -- branching to true_id if so, and falling through otherwise.
872 emitCond (BoolTest e) then_id = do
873   stmtEC (CmmCondBranch e then_id)
874 emitCond (BoolNot (BoolTest (CmmMachOp op args))) then_id
875   | Just op' <- maybeInvertComparison op
876   = emitCond (BoolTest (CmmMachOp op' args)) then_id
877 emitCond (BoolNot e) then_id = do
878   else_id <- code newLabelC
879   emitCond e else_id
880   stmtEC (CmmBranch then_id)
881   code (labelC else_id)
882 emitCond (e1 `BoolOr` e2) then_id = do
883   emitCond e1 then_id
884   emitCond e2 then_id
885 emitCond (e1 `BoolAnd` e2) then_id = do
886         -- we'd like to invert one of the conditionals here to avoid an
887         -- extra branch instruction, but we can't use maybeInvertComparison
888         -- here because we can't look too closely at the expression since
889         -- we're in a loop.
890   and_id <- code newLabelC
891   else_id <- code newLabelC
892   emitCond e1 and_id
893   stmtEC (CmmBranch else_id)
894   code (labelC and_id)
895   emitCond e2 then_id
896   code (labelC else_id)
897
898
899 -- -----------------------------------------------------------------------------
900 -- Table jumps
901
902 -- We use a simplified form of C-- switch statements for now.  A
903 -- switch statement always compiles to a table jump.  Each arm can
904 -- specify a list of values (not ranges), and there can be a single
905 -- default branch.  The range of the table is given either by the
906 -- optional range on the switch (eg. switch [0..7] {...}), or by
907 -- the minimum/maximum values from the branches.
908
909 doSwitch :: Maybe (Int,Int) -> ExtFCode CmmExpr -> [([Int],ExtCode)]
910          -> Maybe ExtCode -> ExtCode
911 doSwitch mb_range scrut arms deflt
912    = do 
913         -- Compile code for the default branch
914         dflt_entry <- 
915                 case deflt of
916                   Nothing -> return Nothing
917                   Just e  -> do b <- forkLabelledCodeEC e; return (Just b)
918
919         -- Compile each case branch
920         table_entries <- mapM emitArm arms
921
922         -- Construct the table
923         let
924             all_entries = concat table_entries
925             ixs = map fst all_entries
926             (min,max) 
927                 | Just (l,u) <- mb_range = (l,u)
928                 | otherwise              = (minimum ixs, maximum ixs)
929
930             entries = elems (accumArray (\_ a -> Just a) dflt_entry (min,max)
931                                 all_entries)
932         expr <- scrut
933         -- ToDo: check for out of range and jump to default if necessary
934         stmtEC (CmmSwitch expr entries)
935    where
936         emitArm :: ([Int],ExtCode) -> ExtFCode [(Int,BlockId)]
937         emitArm (ints,code) = do
938            blockid <- forkLabelledCodeEC code
939            return [ (i,blockid) | i <- ints ]
940
941
942 -- -----------------------------------------------------------------------------
943 -- Putting it all together
944
945 -- The initial environment: we define some constants that the compiler
946 -- knows about here.
947 initEnv :: Env
948 initEnv = listToUFM [
949   ( FSLIT("SIZEOF_StgHeader"), 
950     Var (CmmLit (CmmInt (fromIntegral (fixedHdrSize * wORD_SIZE)) wordRep) )),
951   ( FSLIT("SIZEOF_StgInfoTable"),
952     Var (CmmLit (CmmInt (fromIntegral stdInfoTableSizeB) wordRep) ))
953   ]
954
955 parseCmmFile :: DynFlags -> FilePath -> IO (Maybe Cmm)
956 parseCmmFile dflags filename = do
957   showPass dflags "ParseCmm"
958   buf <- hGetStringBuffer filename
959   let
960         init_loc = mkSrcLoc (mkFastString filename) 1 0
961         init_state = (mkPState buf init_loc dflags) { lex_state = [0] }
962                 -- reset the lex_state: the Lexer monad leaves some stuff
963                 -- in there we don't want.
964   case unP cmmParse init_state of
965     PFailed span err -> do printError span err; return Nothing
966     POk pst code -> do
967         cmm <- initC dflags no_module (getCmm (unEC code initEnv [] >> return ()))
968         let ms = getMessages pst
969         printErrorsAndWarnings dflags ms
970         when (errorsFound dflags ms) $ exitWith (ExitFailure 1)
971         dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (pprCmms [cmm])
972         return (Just cmm)
973   where
974         no_module = panic "parseCmmFile: no module"
975 }