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