In CMM, only allow foreign calls to labels, not arbitrary expressions
[ghc.git] / compiler / cmm / CmmParse.y
1 -----------------------------------------------------------------------------
2 --
3 -- (c) The University of Glasgow, 2004-2012
4 --
5 -- Parser for concrete Cmm.
6 --
7 -----------------------------------------------------------------------------
8
9 {- -----------------------------------------------------------------------------
10 Note [Syntax of .cmm files]
11
12 NOTE: You are very much on your own in .cmm.  There is very little
13 error checking at all:
14
15   * Type errors are detected by the (optional) -dcmm-lint pass, if you
16     don't turn this on then a type error will likely result in a panic
17     from the native code generator.
18
19   * Passing the wrong number of arguments or arguments of the wrong
20     type is not detected.
21
22 There are two ways to write .cmm code:
23
24  (1) High-level Cmm code delegates the stack handling to GHC, and
25      never explicitly mentions Sp or registers.
26
27  (2) Low-level Cmm manages the stack itself, and must know about
28      calling conventions.
29
30 Whether you want high-level or low-level Cmm is indicated by the
31 presence of an argument list on a procedure.  For example:
32
33 foo ( gcptr a, bits32 b )
34 {
35   // this is high-level cmm code
36
37   if (b > 0) {
38      // we can make tail calls passing arguments:
39      jump stg_ap_0_fast(a);
40   }
41
42   push (stg_upd_frame_info, a) {
43     // stack frames can be explicitly pushed
44
45     (x,y) = call wibble(a,b,3,4);
46       // calls pass arguments and return results using the native
47       // Haskell calling convention.  The code generator will automatically
48       // construct a stack frame and an info table for the continuation.
49
50     return (x,y);
51       // we can return multiple values from the current proc
52   }
53 }
54
55 bar
56 {
57   // this is low-level cmm code, indicated by the fact that we did not
58   // put an argument list on bar.
59
60   x = R1;  // the calling convention is explicit: better be careful
61            // that this works on all platforms!
62
63   jump %ENTRY_CODE(Sp(0))
64 }
65
66 Here is a list of rules for high-level and low-level code.  If you
67 break the rules, you get a panic (for using a high-level construct in
68 a low-level proc), or wrong code (when using low-level code in a
69 high-level proc).  This stuff isn't checked! (TODO!)
70
71 High-level only:
72
73   - tail-calls with arguments, e.g.
74     jump stg_fun (arg1, arg2);
75
76   - function calls:
77     (ret1,ret2) = call stg_fun (arg1, arg2);
78
79     This makes a call with the NativeNodeCall convention, and the
80     values are returned to the following code using the NativeReturn
81     convention.
82
83   - returning:
84     return (ret1, ret2)
85
86     These use the NativeReturn convention to return zero or more
87     results to the caller.
88
89   - pushing stack frames:
90     push (info_ptr, field1, ..., fieldN) { ... statements ... }
91
92 Low-level only:
93
94   - References to Sp, R1-R8, F1-F4 etc.
95
96     NB. foreign calls may clobber the argument registers R1-R8, F1-F4
97     etc., so ensure they are saved into variables around foreign
98     calls.
99
100   - SAVE_THREAD_STATE() and LOAD_THREAD_STATE(), which modify Sp
101     directly.
102
103 Both high-level and low-level code can use a raw tail-call:
104
105     jump stg_fun [R1,R2]
106
107 This always transfers control to a low-level Cmm function, but the
108 call can be made from high-level code.  Arguments must be passed
109 explicitly in R/F/D/L registers.
110
111 NB. you *must* specify the list of GlobalRegs that are passed via a
112 jump, otherwise the register allocator will assume that all the
113 GlobalRegs are dead at the jump.
114
115
116 A stack frame is written like this:
117
118 INFO_TABLE_RET ( label, FRAME_TYPE, info_ptr, field1, ..., fieldN )
119                return ( arg1, ..., argM )
120 {
121   ... code ...
122 }
123
124 where field1 ... fieldN are the fields of the stack frame (with types)
125 arg1...argN are the values returned to the stack frame (with types).
126 The return values are assumed to be passed according to the
127 NativeReturn convention.
128
129 On entry to the code, the stack frame looks like:
130
131    |----------|
132    | fieldN   |
133    |   ...    |
134    | field1   |
135    |----------|
136    | info_ptr |
137    |----------|
138    |  argN    |
139    |   ...    | <- Sp
140
141 and some of the args may be in registers.
142
143 We prepend the code by a copyIn of the args, and assign all the stack
144 frame fields to their formals.  The initial "arg offset" for stack
145 layout purposes consists of the whole stack frame plus any args that
146 might be on the stack.
147
148 A tail-call may pass a stack frame to the callee using the following
149 syntax:
150
151 jump f (info_ptr, field1,..,fieldN) (arg1,..,argN)
152
153 where info_ptr and field1..fieldN describe the stack frame, and
154 arg1..argN are the arguments passed to f using the NativeNodeCall
155 convention.
156
157 ----------------------------------------------------------------------------- -}
158
159 {
160 {-# LANGUAGE BangPatterns #-} -- required for versions of Happy before 1.18.6
161 {-# OPTIONS -Wwarn -w #-}
162 -- The above warning supression flag is a temporary kludge.
163 -- While working on this module you are encouraged to remove it and fix
164 -- any warnings in the module. See
165 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
166 -- for details
167
168 module CmmParse ( parseCmmFile ) where
169
170 import StgCmmExtCode
171 import CmmCallConv
172 import StgCmmProf
173 import StgCmmHeap
174 import StgCmmMonad hiding ( getCode, getCodeR, emitLabel, emit, emitStore
175                           , emitAssign, emitOutOfLine, withUpdFrameOff
176                           , getUpdFrameOff )
177 import qualified StgCmmMonad as F
178 import StgCmmUtils
179 import StgCmmForeign
180 import StgCmmExpr
181 import StgCmmClosure
182 import StgCmmLayout     hiding (ArgRep(..))
183 import StgCmmTicky
184 import StgCmmBind       ( emitBlackHoleCode, emitUpdateFrame )
185
186 import MkGraph
187 import Cmm
188 import CmmUtils
189 import CmmInfo
190 import BlockId
191 import CmmLex
192 import CLabel
193 import SMRep
194 import Lexer
195
196 import CostCentre
197 import ForeignCall
198 import Module
199 import Platform
200 import Literal
201 import Unique
202 import UniqFM
203 import SrcLoc
204 import DynFlags
205 import StaticFlags
206 import ErrUtils
207 import StringBuffer
208 import FastString
209 import Panic
210 import Constants
211 import Outputable
212 import BasicTypes
213 import Bag              ( emptyBag, unitBag )
214 import Var
215
216 import Control.Monad
217 import Data.Array
218 import Data.Char        ( ord )
219 import System.Exit
220 import Data.Maybe
221
222 #include "HsVersions.h"
223 }
224
225 %expect 0
226
227 %token
228         ':'     { L _ (CmmT_SpecChar ':') }
229         ';'     { L _ (CmmT_SpecChar ';') }
230         '{'     { L _ (CmmT_SpecChar '{') }
231         '}'     { L _ (CmmT_SpecChar '}') }
232         '['     { L _ (CmmT_SpecChar '[') }
233         ']'     { L _ (CmmT_SpecChar ']') }
234         '('     { L _ (CmmT_SpecChar '(') }
235         ')'     { L _ (CmmT_SpecChar ')') }
236         '='     { L _ (CmmT_SpecChar '=') }
237         '`'     { L _ (CmmT_SpecChar '`') }
238         '~'     { L _ (CmmT_SpecChar '~') }
239         '/'     { L _ (CmmT_SpecChar '/') }
240         '*'     { L _ (CmmT_SpecChar '*') }
241         '%'     { L _ (CmmT_SpecChar '%') }
242         '-'     { L _ (CmmT_SpecChar '-') }
243         '+'     { L _ (CmmT_SpecChar '+') }
244         '&'     { L _ (CmmT_SpecChar '&') }
245         '^'     { L _ (CmmT_SpecChar '^') }
246         '|'     { L _ (CmmT_SpecChar '|') }
247         '>'     { L _ (CmmT_SpecChar '>') }
248         '<'     { L _ (CmmT_SpecChar '<') }
249         ','     { L _ (CmmT_SpecChar ',') }
250         '!'     { L _ (CmmT_SpecChar '!') }
251
252         '..'    { L _ (CmmT_DotDot) }
253         '::'    { L _ (CmmT_DoubleColon) }
254         '>>'    { L _ (CmmT_Shr) }
255         '<<'    { L _ (CmmT_Shl) }
256         '>='    { L _ (CmmT_Ge) }
257         '<='    { L _ (CmmT_Le) }
258         '=='    { L _ (CmmT_Eq) }
259         '!='    { L _ (CmmT_Ne) }
260         '&&'    { L _ (CmmT_BoolAnd) }
261         '||'    { L _ (CmmT_BoolOr) }
262
263         'CLOSURE'       { L _ (CmmT_CLOSURE) }
264         'INFO_TABLE'    { L _ (CmmT_INFO_TABLE) }
265         'INFO_TABLE_RET'{ L _ (CmmT_INFO_TABLE_RET) }
266         'INFO_TABLE_FUN'{ L _ (CmmT_INFO_TABLE_FUN) }
267         'INFO_TABLE_CONSTR'{ L _ (CmmT_INFO_TABLE_CONSTR) }
268         'INFO_TABLE_SELECTOR'{ L _ (CmmT_INFO_TABLE_SELECTOR) }
269         'else'          { L _ (CmmT_else) }
270         'export'        { L _ (CmmT_export) }
271         'section'       { L _ (CmmT_section) }
272         'align'         { L _ (CmmT_align) }
273         'goto'          { L _ (CmmT_goto) }
274         'if'            { L _ (CmmT_if) }
275         'call'          { L _ (CmmT_call) }
276         'jump'          { L _ (CmmT_jump) }
277         'foreign'       { L _ (CmmT_foreign) }
278         'never'         { L _ (CmmT_never) }
279         'prim'          { L _ (CmmT_prim) }
280         'return'        { L _ (CmmT_return) }
281         'returns'       { L _ (CmmT_returns) }
282         'import'        { L _ (CmmT_import) }
283         'switch'        { L _ (CmmT_switch) }
284         'case'          { L _ (CmmT_case) }
285         'default'       { L _ (CmmT_default) }
286         'push'          { L _ (CmmT_push) }
287         'bits8'         { L _ (CmmT_bits8) }
288         'bits16'        { L _ (CmmT_bits16) }
289         'bits32'        { L _ (CmmT_bits32) }
290         'bits64'        { L _ (CmmT_bits64) }
291         'bits128'       { L _ (CmmT_bits128) }
292         'float32'       { L _ (CmmT_float32) }
293         'float64'       { L _ (CmmT_float64) }
294         'gcptr'         { L _ (CmmT_gcptr) }
295
296         GLOBALREG       { L _ (CmmT_GlobalReg   $$) }
297         NAME            { L _ (CmmT_Name        $$) }
298         STRING          { L _ (CmmT_String      $$) }
299         INT             { L _ (CmmT_Int         $$) }
300         FLOAT           { L _ (CmmT_Float       $$) }
301
302 %monad { P } { >>= } { return }
303 %lexer { cmmlex } { L _ CmmT_EOF }
304 %name cmmParse cmm
305 %tokentype { Located CmmToken }
306
307 -- C-- operator precedences, taken from the C-- spec
308 %right '||'     -- non-std extension, called %disjoin in C--
309 %right '&&'     -- non-std extension, called %conjoin in C--
310 %right '!'
311 %nonassoc '>=' '>' '<=' '<' '!=' '=='
312 %left '|'
313 %left '^'
314 %left '&'
315 %left '>>' '<<'
316 %left '-' '+'
317 %left '/' '*' '%'
318 %right '~'
319
320 %%
321
322 cmm     :: { CmmParse () }
323         : {- empty -}                   { return () }
324         | cmmtop cmm                    { do $1; $2 }
325
326 cmmtop  :: { CmmParse () }
327         : cmmproc                       { $1 }
328         | cmmdata                       { $1 }
329         | decl                          { $1 } 
330         | 'CLOSURE' '(' NAME ',' NAME lits ')' ';'  
331                 {% withThisPackage $ \pkg -> 
332                    do lits <- sequence $6;
333                       staticClosure pkg $3 $5 (map getLit lits) }
334
335 -- The only static closures in the RTS are dummy closures like
336 -- stg_END_TSO_QUEUE_closure and stg_dummy_ret.  We don't need
337 -- to provide the full generality of static closures here.
338 -- In particular:
339 --      * CCS can always be CCS_DONT_CARE
340 --      * closure is always extern
341 --      * payload is always empty
342 --      * we can derive closure and info table labels from a single NAME
343
344 cmmdata :: { CmmParse () }
345         : 'section' STRING '{' data_label statics '}' 
346                 { do lbl <- $4;
347                      ss <- sequence $5;
348                      code (emitDecl (CmmData (section $2) (Statics lbl $ concat ss))) }
349
350 data_label :: { CmmParse CLabel }
351     : NAME ':'  
352                 {% withThisPackage $ \pkg -> 
353                    return (mkCmmDataLabel pkg $1) }
354
355 statics :: { [CmmParse [CmmStatic]] }
356         : {- empty -}                   { [] }
357         | static statics                { $1 : $2 }
358     
359 -- Strings aren't used much in the RTS HC code, so it doesn't seem
360 -- worth allowing inline strings.  C-- doesn't allow them anyway.
361 static  :: { CmmParse [CmmStatic] }
362         : type expr ';' { do e <- $2;
363                              return [CmmStaticLit (getLit e)] }
364         | type ';'                      { return [CmmUninitialised
365                                                         (widthInBytes (typeWidth $1))] }
366         | 'bits8' '[' ']' STRING ';'    { return [mkString $4] }
367         | 'bits8' '[' INT ']' ';'       { return [CmmUninitialised 
368                                                         (fromIntegral $3)] }
369         | typenot8 '[' INT ']' ';'      { return [CmmUninitialised 
370                                                 (widthInBytes (typeWidth $1) * 
371                                                         fromIntegral $3)] }
372         | 'CLOSURE' '(' NAME lits ')'
373                 { do { lits <- sequence $4
374                 ; dflags <- getDynFlags
375                      ; return $ map CmmStaticLit $
376                         mkStaticClosure dflags (mkForeignLabel $3 Nothing ForeignLabelInExternalPackage IsData)
377                          -- mkForeignLabel because these are only used
378                          -- for CHARLIKE and INTLIKE closures in the RTS.
379                         dontCareCCS (map getLit lits) [] [] [] } }
380         -- arrays of closures required for the CHARLIKE & INTLIKE arrays
381
382 lits    :: { [CmmParse CmmExpr] }
383         : {- empty -}           { [] }
384         | ',' expr lits         { $2 : $3 }
385
386 cmmproc :: { CmmParse () }
387         : info maybe_conv maybe_formals maybe_body
388                 { do ((entry_ret_label, info, stk_formals, formals), agraph) <-
389                        getCodeR $ loopDecls $ do {
390                          (entry_ret_label, info, stk_formals) <- $1;
391                          formals <- sequence (fromMaybe [] $3);
392                          $4;
393                          return (entry_ret_label, info, stk_formals, formals) }
394                      let do_layout = isJust $3
395                      code (emitProcWithStackFrame $2 info
396                                 entry_ret_label stk_formals formals agraph
397                                 do_layout ) }
398
399 maybe_conv :: { Convention }
400            : {- empty -}        { NativeNodeCall }
401            | 'return'           { NativeReturn }
402
403 maybe_body :: { CmmParse () }
404            : ';'                { return () }
405            | '{' body '}'       { $2 }
406
407 info    :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }
408         : NAME
409                 {% withThisPackage $ \pkg ->
410                    do   newFunctionName $1 pkg
411                         return (mkCmmCodeLabel pkg $1, Nothing, []) }
412
413
414         | 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
415                 -- ptrs, nptrs, closure type, description, type
416                 {% withThisPackage $ \pkg ->
417                    do dflags <- getDynFlags
418                       let prof = profilingInfo dflags $11 $13
419                           rep  = mkRTSRep (fromIntegral $9) $
420                                    mkHeapRep dflags False (fromIntegral $5)
421                                                    (fromIntegral $7) Thunk
422                               -- not really Thunk, but that makes the info table
423                               -- we want.
424                       return (mkCmmEntryLabel pkg $3,
425                               Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
426                                            , cit_rep = rep
427                                            , cit_prof = prof, cit_srt = NoC_SRT },
428                               []) }
429         
430         | 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ')'
431                 -- ptrs, nptrs, closure type, description, type, fun type
432                 {% withThisPackage $ \pkg -> 
433                    do dflags <- getDynFlags
434                       let prof = profilingInfo dflags $11 $13
435                           ty   = Fun 0 (ArgSpec (fromIntegral $15))
436                                 -- Arity zero, arg_type $15
437                           rep = mkRTSRep (fromIntegral $9) $
438                                     mkHeapRep dflags False (fromIntegral $5)
439                                                     (fromIntegral $7) ty
440                       return (mkCmmEntryLabel pkg $3,
441                               Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
442                                            , cit_rep = rep
443                                            , cit_prof = prof, cit_srt = NoC_SRT },
444                               []) }
445                 -- we leave most of the fields zero here.  This is only used
446                 -- to generate the BCO info table in the RTS at the moment.
447
448         | 'INFO_TABLE_CONSTR' '(' NAME ',' INT ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
449                 -- ptrs, nptrs, tag, closure type, description, type
450                 {% withThisPackage $ \pkg ->
451                    do dflags <- getDynFlags
452                       let prof = profilingInfo dflags $13 $15
453                           ty  = Constr (fromIntegral $9)  -- Tag
454                                        (stringToWord8s $13)
455                           rep = mkRTSRep (fromIntegral $11) $
456                                   mkHeapRep dflags False (fromIntegral $5)
457                                                   (fromIntegral $7) ty
458                       return (mkCmmEntryLabel pkg $3,
459                               Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
460                                            , cit_rep = rep
461                                            , cit_prof = prof, cit_srt = NoC_SRT },
462                               []) }
463
464                      -- If profiling is on, this string gets duplicated,
465                      -- but that's the way the old code did it we can fix it some other time.
466         
467         | 'INFO_TABLE_SELECTOR' '(' NAME ',' INT ',' INT ',' STRING ',' STRING ')'
468                 -- selector, closure type, description, type
469                 {% withThisPackage $ \pkg ->
470                    do dflags <- getDynFlags
471                       let prof = profilingInfo dflags $9 $11
472                           ty  = ThunkSelector (fromIntegral $5)
473                           rep = mkRTSRep (fromIntegral $7) $
474                                    mkHeapRep dflags False 0 0 ty
475                       return (mkCmmEntryLabel pkg $3,
476                               Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
477                                            , cit_rep = rep
478                                            , cit_prof = prof, cit_srt = NoC_SRT },
479                               []) }
480
481         | 'INFO_TABLE_RET' '(' NAME ',' INT ')'
482                 -- closure type (no live regs)
483                 {% withThisPackage $ \pkg ->
484                    do let prof = NoProfilingInfo
485                           rep  = mkRTSRep (fromIntegral $5) $ mkStackRep []
486                       return (mkCmmRetLabel pkg $3,
487                               Just $ CmmInfoTable { cit_lbl = mkCmmRetInfoLabel pkg $3
488                                            , cit_rep = rep
489                                            , cit_prof = prof, cit_srt = NoC_SRT },
490                               []) }
491
492         | 'INFO_TABLE_RET' '(' NAME ',' INT ',' formals0 ')'
493                 -- closure type, live regs
494                 {% withThisPackage $ \pkg ->
495                    do dflags <- getDynFlags
496                       live <- sequence $7
497                       let prof = NoProfilingInfo
498                           -- drop one for the info pointer
499                           bitmap = mkLiveness dflags (map Just (drop 1 live))
500                           rep  = mkRTSRep (fromIntegral $5) $ mkStackRep bitmap
501                       return (mkCmmRetLabel pkg $3,
502                               Just $ CmmInfoTable { cit_lbl = mkCmmRetInfoLabel pkg $3
503                                            , cit_rep = rep
504                                            , cit_prof = prof, cit_srt = NoC_SRT },
505                               live) }
506
507 body    :: { CmmParse () }
508         : {- empty -}                   { return () }
509         | decl body                     { do $1; $2 }
510         | stmt body                     { do $1; $2 }
511
512 decl    :: { CmmParse () }
513         : type names ';'                { mapM_ (newLocal $1) $2 }
514         | 'import' importNames ';'      { mapM_ newImport $2 }
515         | 'export' names ';'            { return () }  -- ignore exports
516
517
518 -- an imported function name, with optional packageId
519 importNames
520         :: { [(FastString, CLabel)] }
521         : importName                    { [$1] }
522         | importName ',' importNames    { $1 : $3 }
523
524 importName
525         :: { (FastString,  CLabel) }
526
527         -- A label imported without an explicit packageId.
528         --      These are taken to come frome some foreign, unnamed package.
529         : NAME  
530         { ($1, mkForeignLabel $1 Nothing ForeignLabelInExternalPackage IsFunction) }
531
532         -- A label imported with an explicit packageId.
533         | STRING NAME
534         { ($2, mkCmmCodeLabel (fsToPackageId (mkFastString $1)) $2) }
535         
536         
537 names   :: { [FastString] }
538         : NAME                          { [$1] }
539         | NAME ',' names                { $1 : $3 }
540
541 stmt    :: { CmmParse () }
542         : ';'                                   { return () }
543
544         | NAME ':'
545                 { do l <- newLabel $1; emitLabel l }
546
547
548
549         | lreg '=' expr ';'
550                 { do reg <- $1; e <- $3; emitAssign reg e }
551         | type '[' expr ']' '=' expr ';'
552                 { doStore $1 $3 $6 }
553
554         -- Gah! We really want to say "foreign_results" but that causes
555         -- a shift/reduce conflict with assignment.  We either
556         -- we expand out the no-result and single result cases or
557         -- we tweak the syntax to avoid the conflict.  The later
558         -- option is taken here because the other way would require
559         -- multiple levels of expanding and get unwieldy.
560         | foreign_results 'foreign' STRING foreignLabel '(' cmm_hint_exprs0 ')' safety opt_never_returns ';'
561                 {% foreignCall $3 $1 $4 $6 $8 $9 }
562         | foreign_results 'prim' '%' NAME '(' exprs0 ')' ';'
563                 {% primCall $1 $4 $6 }
564         -- stmt-level macros, stealing syntax from ordinary C-- function calls.
565         -- Perhaps we ought to use the %%-form?
566         | NAME '(' exprs0 ')' ';'
567                 {% stmtMacro $1 $3  }
568         | 'switch' maybe_range expr '{' arms default '}'
569                 { do as <- sequence $5; doSwitch $2 $3 as $6 }
570         | 'goto' NAME ';'
571                 { do l <- lookupLabel $2; emit (mkBranch l) }
572         | 'return' '(' exprs0 ')' ';'
573                 { doReturn $3 }
574         | 'jump' expr vols ';'
575                 { doRawJump $2 $3 }
576         | 'jump' expr '(' exprs0 ')' ';'
577                 { doJumpWithStack $2 [] $4 }
578         | 'jump' expr '(' exprs0 ')' '(' exprs0 ')' ';'
579                 { doJumpWithStack $2 $4 $7 }
580         | 'call' expr '(' exprs0 ')' ';'
581                 { doCall $2 [] $4 }
582         | '(' formals ')' '=' 'call' expr '(' exprs0 ')' ';'
583                 { doCall $6 $2 $8 }
584         | 'if' bool_expr 'goto' NAME
585                 { do l <- lookupLabel $4; cmmRawIf $2 l }
586         | 'if' bool_expr '{' body '}' else      
587                 { cmmIfThenElse $2 $4 $6 }
588         | 'push' '(' exprs0 ')' maybe_body
589                 { pushStackFrame $3 $5 }
590
591 foreignLabel     :: { CmmParse CmmExpr }
592         : NAME                          { return (CmmLit (CmmLabel (mkForeignLabel $1 Nothing ForeignLabelInExternalPackage IsFunction))) }
593
594 opt_never_returns :: { CmmReturnInfo }
595         :                               { CmmMayReturn }
596         | 'never' 'returns'             { CmmNeverReturns }
597
598 bool_expr :: { CmmParse BoolExpr }
599         : bool_op                       { $1 }
600         | expr                          { do e <- $1; return (BoolTest e) }
601
602 bool_op :: { CmmParse BoolExpr }
603         : bool_expr '&&' bool_expr      { do e1 <- $1; e2 <- $3; 
604                                           return (BoolAnd e1 e2) }
605         | bool_expr '||' bool_expr      { do e1 <- $1; e2 <- $3; 
606                                           return (BoolOr e1 e2)  }
607         | '!' bool_expr                 { do e <- $2; return (BoolNot e) }
608         | '(' bool_op ')'               { $2 }
609
610 safety  :: { Safety }
611         : {- empty -}                   { PlayRisky }
612         | STRING                        {% parseSafety $1 }
613
614 vols    :: { [GlobalReg] }
615         : '[' ']'                       { [] }
616         | '[' '*' ']'                   {% do df <- getDynFlags
617                                          ; return (realArgRegsCover df) }
618                                            -- All of them. See comment attached
619                                            -- to realArgRegsCover
620         | '[' globals ']'               { $2 }
621
622 globals :: { [GlobalReg] }
623         : GLOBALREG                     { [$1] }
624         | GLOBALREG ',' globals         { $1 : $3 }
625
626 maybe_range :: { Maybe (Int,Int) }
627         : '[' INT '..' INT ']'  { Just (fromIntegral $2, fromIntegral $4) }
628         | {- empty -}           { Nothing }
629
630 arms    :: { [CmmParse ([Int],Either BlockId (CmmParse ()))] }
631         : {- empty -}                   { [] }
632         | arm arms                      { $1 : $2 }
633
634 arm     :: { CmmParse ([Int],Either BlockId (CmmParse ())) }
635         : 'case' ints ':' arm_body      { do b <- $4; return ($2, b) }
636
637 arm_body :: { CmmParse (Either BlockId (CmmParse ())) }
638         : '{' body '}'                  { return (Right $2) }
639         | 'goto' NAME ';'               { do l <- lookupLabel $2; return (Left l) }
640
641 ints    :: { [Int] }
642         : INT                           { [ fromIntegral $1 ] }
643         | INT ',' ints                  { fromIntegral $1 : $3 }
644
645 default :: { Maybe (CmmParse ()) }
646         : 'default' ':' '{' body '}'    { Just $4 }
647         -- taking a few liberties with the C-- syntax here; C-- doesn't have
648         -- 'default' branches
649         | {- empty -}                   { Nothing }
650
651 -- Note: OldCmm doesn't support a first class 'else' statement, though
652 -- CmmNode does.
653 else    :: { CmmParse () }
654         : {- empty -}                   { return () }
655         | 'else' '{' body '}'           { $3 }
656
657 -- we have to write this out longhand so that Happy's precedence rules
658 -- can kick in.
659 expr    :: { CmmParse CmmExpr }
660         : expr '/' expr                 { mkMachOp MO_U_Quot [$1,$3] }
661         | expr '*' expr                 { mkMachOp MO_Mul [$1,$3] }
662         | expr '%' expr                 { mkMachOp MO_U_Rem [$1,$3] }
663         | expr '-' expr                 { mkMachOp MO_Sub [$1,$3] }
664         | expr '+' expr                 { mkMachOp MO_Add [$1,$3] }
665         | expr '>>' expr                { mkMachOp MO_U_Shr [$1,$3] }
666         | expr '<<' expr                { mkMachOp MO_Shl [$1,$3] }
667         | expr '&' expr                 { mkMachOp MO_And [$1,$3] }
668         | expr '^' expr                 { mkMachOp MO_Xor [$1,$3] }
669         | expr '|' expr                 { mkMachOp MO_Or [$1,$3] }
670         | expr '>=' expr                { mkMachOp MO_U_Ge [$1,$3] }
671         | expr '>' expr                 { mkMachOp MO_U_Gt [$1,$3] }
672         | expr '<=' expr                { mkMachOp MO_U_Le [$1,$3] }
673         | expr '<' expr                 { mkMachOp MO_U_Lt [$1,$3] }
674         | expr '!=' expr                { mkMachOp MO_Ne [$1,$3] }
675         | expr '==' expr                { mkMachOp MO_Eq [$1,$3] }
676         | '~' expr                      { mkMachOp MO_Not [$2] }
677         | '-' expr                      { mkMachOp MO_S_Neg [$2] }
678         | expr0 '`' NAME '`' expr0      {% do { mo <- nameToMachOp $3 ;
679                                                 return (mkMachOp mo [$1,$5]) } }
680         | expr0                         { $1 }
681
682 expr0   :: { CmmParse CmmExpr }
683         : INT   maybe_ty         { return (CmmLit (CmmInt $1 (typeWidth $2))) }
684         | FLOAT maybe_ty         { return (CmmLit (CmmFloat $1 (typeWidth $2))) }
685         | STRING                 { do s <- code (newStringCLit $1); 
686                                       return (CmmLit s) }
687         | reg                    { $1 }
688         | type '[' expr ']'      { do e <- $3; return (CmmLoad e $1) }
689         | '%' NAME '(' exprs0 ')' {% exprOp $2 $4 }
690         | '(' expr ')'           { $2 }
691
692
693 -- leaving out the type of a literal gives you the native word size in C--
694 maybe_ty :: { CmmType }
695         : {- empty -}                   {% do dflags <- getDynFlags; return $ bWord dflags }
696         | '::' type                     { $2 }
697
698 cmm_hint_exprs0 :: { [CmmParse (CmmExpr, ForeignHint)] }
699         : {- empty -}                   { [] }
700         | cmm_hint_exprs                { $1 }
701
702 cmm_hint_exprs :: { [CmmParse (CmmExpr, ForeignHint)] }
703         : cmm_hint_expr                 { [$1] }
704         | cmm_hint_expr ',' cmm_hint_exprs      { $1 : $3 }
705
706 cmm_hint_expr :: { CmmParse (CmmExpr, ForeignHint) }
707         : expr                          { do e <- $1;
708                                              return (e, inferCmmHint e) }
709         | expr STRING                   {% do h <- parseCmmHint $2;
710                                               return $ do
711                                                 e <- $1; return (e, h) }
712
713 exprs0  :: { [CmmParse CmmExpr] }
714         : {- empty -}                   { [] }
715         | exprs                         { $1 }
716
717 exprs   :: { [CmmParse CmmExpr] }
718         : expr                          { [ $1 ] }
719         | expr ',' exprs                { $1 : $3 }
720
721 reg     :: { CmmParse CmmExpr }
722         : NAME                  { lookupName $1 }
723         | GLOBALREG             { return (CmmReg (CmmGlobal $1)) }
724
725 foreign_results :: { [CmmParse (LocalReg, ForeignHint)] }
726         : {- empty -}                   { [] }
727         | '(' foreign_formals ')' '='   { $2 }
728
729 foreign_formals :: { [CmmParse (LocalReg, ForeignHint)] }
730         : foreign_formal                        { [$1] }
731         | foreign_formal ','                    { [$1] }
732         | foreign_formal ',' foreign_formals    { $1 : $3 }
733
734 foreign_formal :: { CmmParse (LocalReg, ForeignHint) }
735         : local_lreg            { do e <- $1; return (e, (inferCmmHint (CmmReg (CmmLocal e)))) }
736         | STRING local_lreg     {% do h <- parseCmmHint $1;
737                                       return $ do
738                                          e <- $2; return (e,h) }
739
740 local_lreg :: { CmmParse LocalReg }
741         : NAME                  { do e <- lookupName $1;
742                                      return $
743                                        case e of 
744                                         CmmReg (CmmLocal r) -> r
745                                         other -> pprPanic "CmmParse:" (ftext $1 <> text " not a local register") }
746
747 lreg    :: { CmmParse CmmReg }
748         : NAME                  { do e <- lookupName $1;
749                                      return $
750                                        case e of 
751                                         CmmReg r -> r
752                                         other -> pprPanic "CmmParse:" (ftext $1 <> text " not a register") }
753         | GLOBALREG             { return (CmmGlobal $1) }
754
755 maybe_formals :: { Maybe [CmmParse LocalReg] }
756         : {- empty -}           { Nothing }
757         | '(' formals0 ')'      { Just $2 }
758
759 formals0 :: { [CmmParse LocalReg] }
760         : {- empty -}           { [] }
761         | formals               { $1 }
762
763 formals :: { [CmmParse LocalReg] }
764         : formal ','            { [$1] }
765         | formal                { [$1] }
766         | formal ',' formals       { $1 : $3 }
767
768 formal :: { CmmParse LocalReg }
769         : type NAME             { newLocal $1 $2 }
770
771 type    :: { CmmType }
772         : 'bits8'               { b8 }
773         | typenot8              { $1 }
774
775 typenot8 :: { CmmType }
776         : 'bits16'              { b16 }
777         | 'bits32'              { b32 }
778         | 'bits64'              { b64 }
779         | 'bits128'             { b128 }
780         | 'float32'             { f32 }
781         | 'float64'             { f64 }
782         | 'gcptr'               {% do dflags <- getDynFlags; return $ gcWord dflags }
783
784 {
785 section :: String -> Section
786 section "text"      = Text
787 section "data"      = Data
788 section "rodata"    = ReadOnlyData
789 section "relrodata" = RelocatableReadOnlyData
790 section "bss"       = UninitialisedData
791 section s           = OtherSection s
792
793 mkString :: String -> CmmStatic
794 mkString s = CmmString (map (fromIntegral.ord) s)
795
796 -- |
797 -- Given an info table, decide what the entry convention for the proc
798 -- is.  That is, for an INFO_TABLE_RET we want the return convention,
799 -- otherwise it is a NativeNodeCall.
800 --
801 infoConv :: Maybe CmmInfoTable -> Convention
802 infoConv Nothing = NativeNodeCall
803 infoConv (Just info)
804   | isStackRep (cit_rep info) = NativeReturn
805   | otherwise                 = NativeNodeCall
806
807 -- mkMachOp infers the type of the MachOp from the type of its first
808 -- argument.  We assume that this is correct: for MachOps that don't have
809 -- symmetrical args (e.g. shift ops), the first arg determines the type of
810 -- the op.
811 mkMachOp :: (Width -> MachOp) -> [CmmParse CmmExpr] -> CmmParse CmmExpr
812 mkMachOp fn args = do
813   dflags <- getDynFlags
814   arg_exprs <- sequence args
815   return (CmmMachOp (fn (typeWidth (cmmExprType dflags (head arg_exprs)))) arg_exprs)
816
817 getLit :: CmmExpr -> CmmLit
818 getLit (CmmLit l) = l
819 getLit (CmmMachOp (MO_S_Neg _) [CmmLit (CmmInt i r)])  = CmmInt (negate i) r
820 getLit _ = panic "invalid literal" -- TODO messy failure
821
822 nameToMachOp :: FastString -> P (Width -> MachOp)
823 nameToMachOp name =
824   case lookupUFM machOps name of
825         Nothing -> fail ("unknown primitive " ++ unpackFS name)
826         Just m  -> return m
827
828 exprOp :: FastString -> [CmmParse CmmExpr] -> P (CmmParse CmmExpr)
829 exprOp name args_code = do
830   dflags <- getDynFlags
831   case lookupUFM (exprMacros dflags) name of
832      Just f  -> return $ do
833         args <- sequence args_code
834         return (f args)
835      Nothing -> do
836         mo <- nameToMachOp name
837         return $ mkMachOp mo args_code
838
839 exprMacros :: DynFlags -> UniqFM ([CmmExpr] -> CmmExpr)
840 exprMacros dflags = listToUFM [
841   ( fsLit "ENTRY_CODE",   \ [x] -> entryCode dflags x ),
842   ( fsLit "INFO_PTR",     \ [x] -> closureInfoPtr dflags x ),
843   ( fsLit "STD_INFO",     \ [x] -> infoTable dflags x ),
844   ( fsLit "FUN_INFO",     \ [x] -> funInfoTable dflags x ),
845   ( fsLit "GET_ENTRY",    \ [x] -> entryCode dflags (closureInfoPtr dflags x) ),
846   ( fsLit "GET_STD_INFO", \ [x] -> infoTable dflags (closureInfoPtr dflags x) ),
847   ( fsLit "GET_FUN_INFO", \ [x] -> funInfoTable dflags (closureInfoPtr dflags x) ),
848   ( fsLit "INFO_TYPE",    \ [x] -> infoTableClosureType dflags x ),
849   ( fsLit "INFO_PTRS",    \ [x] -> infoTablePtrs dflags x ),
850   ( fsLit "INFO_NPTRS",   \ [x] -> infoTableNonPtrs dflags x )
851   ]
852
853 -- we understand a subset of C-- primitives:
854 machOps = listToUFM $
855         map (\(x, y) -> (mkFastString x, y)) [
856         ( "add",        MO_Add ),
857         ( "sub",        MO_Sub ),
858         ( "eq",         MO_Eq ),
859         ( "ne",         MO_Ne ),
860         ( "mul",        MO_Mul ),
861         ( "neg",        MO_S_Neg ),
862         ( "quot",       MO_S_Quot ),
863         ( "rem",        MO_S_Rem ),
864         ( "divu",       MO_U_Quot ),
865         ( "modu",       MO_U_Rem ),
866
867         ( "ge",         MO_S_Ge ),
868         ( "le",         MO_S_Le ),
869         ( "gt",         MO_S_Gt ),
870         ( "lt",         MO_S_Lt ),
871
872         ( "geu",        MO_U_Ge ),
873         ( "leu",        MO_U_Le ),
874         ( "gtu",        MO_U_Gt ),
875         ( "ltu",        MO_U_Lt ),
876
877         ( "and",        MO_And ),
878         ( "or",         MO_Or ),
879         ( "xor",        MO_Xor ),
880         ( "com",        MO_Not ),
881         ( "shl",        MO_Shl ),
882         ( "shrl",       MO_U_Shr ),
883         ( "shra",       MO_S_Shr ),
884
885         ( "fadd",       MO_F_Add ),
886         ( "fsub",       MO_F_Sub ),
887         ( "fneg",       MO_F_Neg ),
888         ( "fmul",       MO_F_Mul ),
889         ( "fquot",      MO_F_Quot ),
890
891         ( "feq",        MO_F_Eq ),
892         ( "fne",        MO_F_Ne ),
893         ( "fge",        MO_F_Ge ),
894         ( "fle",        MO_F_Le ),
895         ( "fgt",        MO_F_Gt ),
896         ( "flt",        MO_F_Lt ),
897
898         ( "lobits8",  flip MO_UU_Conv W8  ),
899         ( "lobits16", flip MO_UU_Conv W16 ),
900         ( "lobits32", flip MO_UU_Conv W32 ),
901         ( "lobits64", flip MO_UU_Conv W64 ),
902
903         ( "zx16",     flip MO_UU_Conv W16 ),
904         ( "zx32",     flip MO_UU_Conv W32 ),
905         ( "zx64",     flip MO_UU_Conv W64 ),
906
907         ( "sx16",     flip MO_SS_Conv W16 ),
908         ( "sx32",     flip MO_SS_Conv W32 ),
909         ( "sx64",     flip MO_SS_Conv W64 ),
910
911         ( "f2f32",    flip MO_FF_Conv W32 ),  -- TODO; rounding mode
912         ( "f2f64",    flip MO_FF_Conv W64 ),  -- TODO; rounding mode
913         ( "f2i8",     flip MO_FS_Conv W8 ),
914         ( "f2i16",    flip MO_FS_Conv W16 ),
915         ( "f2i32",    flip MO_FS_Conv W32 ),
916         ( "f2i64",    flip MO_FS_Conv W64 ),
917         ( "i2f32",    flip MO_SF_Conv W32 ),
918         ( "i2f64",    flip MO_SF_Conv W64 )
919         ]
920
921 callishMachOps = listToUFM $
922         map (\(x, y) -> (mkFastString x, y)) [
923         ( "write_barrier", MO_WriteBarrier ),
924         ( "memcpy", MO_Memcpy ),
925         ( "memset", MO_Memset ),
926         ( "memmove", MO_Memmove )
927         -- ToDo: the rest, maybe
928     ]
929
930 parseSafety :: String -> P Safety
931 parseSafety "safe"   = return PlaySafe
932 parseSafety "unsafe" = return PlayRisky
933 parseSafety "interruptible" = return PlayInterruptible
934 parseSafety str      = fail ("unrecognised safety: " ++ str)
935
936 parseCmmHint :: String -> P ForeignHint
937 parseCmmHint "ptr"    = return AddrHint
938 parseCmmHint "signed" = return SignedHint
939 parseCmmHint str      = fail ("unrecognised hint: " ++ str)
940
941 -- labels are always pointers, so we might as well infer the hint
942 inferCmmHint :: CmmExpr -> ForeignHint
943 inferCmmHint (CmmLit (CmmLabel _)) = AddrHint
944 inferCmmHint (CmmReg (CmmGlobal g)) | isPtrGlobalReg g = AddrHint
945 inferCmmHint _ = NoHint
946
947 isPtrGlobalReg Sp                    = True
948 isPtrGlobalReg SpLim                 = True
949 isPtrGlobalReg Hp                    = True
950 isPtrGlobalReg HpLim                 = True
951 isPtrGlobalReg CCCS                  = True
952 isPtrGlobalReg CurrentTSO            = True
953 isPtrGlobalReg CurrentNursery        = True
954 isPtrGlobalReg (VanillaReg _ VGcPtr) = True
955 isPtrGlobalReg _                     = False
956
957 happyError :: P a
958 happyError = srcParseFail
959
960 -- -----------------------------------------------------------------------------
961 -- Statement-level macros
962
963 stmtMacro :: FastString -> [CmmParse CmmExpr] -> P (CmmParse ())
964 stmtMacro fun args_code = do
965   case lookupUFM stmtMacros fun of
966     Nothing -> fail ("unknown macro: " ++ unpackFS fun)
967     Just fcode -> return $ do
968         args <- sequence args_code
969         code (fcode args)
970
971 stmtMacros :: UniqFM ([CmmExpr] -> FCode ())
972 stmtMacros = listToUFM [
973   ( fsLit "CCS_ALLOC",             \[words,ccs]  -> profAlloc words ccs ),
974   ( fsLit "ENTER_CCS_THUNK",       \[e] -> enterCostCentreThunk e ),
975
976   ( fsLit "CLOSE_NURSERY",         \[]  -> emitCloseNursery ),
977   ( fsLit "OPEN_NURSERY",          \[]  -> emitOpenNursery ),
978
979   -- completely generic heap and stack checks, for use in high-level cmm.
980   ( fsLit "HP_CHK_GEN",            \[bytes] ->
981                                       heapStackCheckGen Nothing (Just bytes) ),
982   ( fsLit "STK_CHK_GEN",           \[] ->
983                                       heapStackCheckGen (Just (CmmLit CmmHighStackMark)) Nothing ),
984
985   -- A stack check for a fixed amount of stack.  Sounds a bit strange, but
986   -- we use the stack for a bit of temporary storage in a couple of primops
987   ( fsLit "STK_CHK_GEN_N",         \[bytes] ->
988                                       heapStackCheckGen (Just bytes) Nothing ),
989
990   -- A stack check on entry to a thunk, where the argument is the thunk pointer.
991   ( fsLit "STK_CHK_NP"   ,         \[node] -> entryHeapCheck' False node 0 [] (return ())),
992
993   ( fsLit "LOAD_THREAD_STATE",     \[] -> emitLoadThreadState ),
994   ( fsLit "SAVE_THREAD_STATE",     \[] -> emitSaveThreadState ),
995
996   ( fsLit "LDV_ENTER",             \[e] -> ldvEnter e ),
997   ( fsLit "LDV_RECORD_CREATE",     \[e] -> ldvRecordCreate e ),
998
999   ( fsLit "PUSH_UPD_FRAME",        \[sp,e] -> emitPushUpdateFrame sp e ),
1000   ( fsLit "SET_HDR",               \[ptr,info,ccs] ->
1001                                         emitSetDynHdr ptr info ccs ),
1002   ( fsLit "TICK_ALLOC_PRIM",       \[hdr,goods,slop] ->
1003                                         tickyAllocPrim hdr goods slop ),
1004   ( fsLit "TICK_ALLOC_PAP",        \[goods,slop] ->
1005                                         tickyAllocPAP goods slop ),
1006   ( fsLit "TICK_ALLOC_UP_THK",     \[goods,slop] ->
1007                                         tickyAllocThunk goods slop ),
1008   ( fsLit "UPD_BH_UPDATABLE",      \[reg] -> emitBlackHoleCode False reg ),
1009   ( fsLit "UPD_BH_SINGLE_ENTRY",   \[reg] -> emitBlackHoleCode True  reg )
1010  ]
1011
1012 emitPushUpdateFrame :: CmmExpr -> CmmExpr -> FCode ()
1013 emitPushUpdateFrame sp e = do
1014   dflags <- getDynFlags
1015   emitUpdateFrame dflags sp mkUpdInfoLabel e
1016
1017 pushStackFrame :: [CmmParse CmmExpr] -> CmmParse () -> CmmParse ()
1018 pushStackFrame fields body = do
1019   dflags <- getDynFlags
1020   exprs <- sequence fields
1021   updfr_off <- getUpdFrameOff
1022   let (new_updfr_off, _, g) = copyOutOflow dflags NativeReturn Ret Old
1023                                            [] updfr_off exprs
1024   emit g
1025   withUpdFrameOff new_updfr_off body
1026
1027 profilingInfo dflags desc_str ty_str
1028   = if not (gopt Opt_SccProfilingOn dflags)
1029     then NoProfilingInfo
1030     else ProfilingInfo (stringToWord8s desc_str)
1031                        (stringToWord8s ty_str)
1032
1033 staticClosure :: PackageId -> FastString -> FastString -> [CmmLit] -> CmmParse ()
1034 staticClosure pkg cl_label info payload
1035   = do dflags <- getDynFlags
1036        let lits = mkStaticClosure dflags (mkCmmInfoLabel pkg info) dontCareCCS payload [] [] []
1037        code $ emitDataLits (mkCmmDataLabel pkg cl_label) lits
1038
1039 foreignCall
1040         :: String
1041         -> [CmmParse (LocalReg, ForeignHint)]
1042         -> CmmParse CmmExpr
1043         -> [CmmParse (CmmExpr, ForeignHint)]
1044         -> Safety
1045         -> CmmReturnInfo
1046         -> P (CmmParse ())
1047 foreignCall conv_string results_code expr_code args_code safety ret
1048   = do  conv <- case conv_string of
1049           "C" -> return CCallConv
1050           "stdcall" -> return StdCallConv
1051           _ -> fail ("unknown calling convention: " ++ conv_string)
1052         return $ do
1053           dflags <- getDynFlags
1054           results <- sequence results_code
1055           expr <- expr_code
1056           args <- sequence args_code
1057           let
1058                   expr' = adjCallTarget dflags conv expr args
1059                   (arg_exprs, arg_hints) = unzip args
1060                   (res_regs,  res_hints) = unzip results
1061                   fc = ForeignConvention conv arg_hints res_hints ret
1062                   target = ForeignTarget expr' fc
1063           _ <- code $ emitForeignCall safety res_regs target arg_exprs
1064           return ()
1065
1066
1067 doReturn :: [CmmParse CmmExpr] -> CmmParse ()
1068 doReturn exprs_code = do
1069   dflags <- getDynFlags
1070   exprs <- sequence exprs_code
1071   updfr_off <- getUpdFrameOff
1072   emit (mkReturnSimple dflags exprs updfr_off)
1073
1074 mkReturnSimple  :: DynFlags -> [CmmActual] -> UpdFrameOffset -> CmmAGraph
1075 mkReturnSimple dflags actuals updfr_off =
1076   mkReturn dflags e actuals updfr_off
1077   where e = entryCode dflags (CmmLoad (CmmStackSlot Old updfr_off)
1078                              (gcWord dflags))
1079
1080 doRawJump :: CmmParse CmmExpr -> [GlobalReg] -> CmmParse ()
1081 doRawJump expr_code vols = do
1082   dflags <- getDynFlags
1083   expr <- expr_code
1084   updfr_off <- getUpdFrameOff
1085   emit (mkRawJump dflags expr updfr_off vols)
1086
1087 doJumpWithStack :: CmmParse CmmExpr -> [CmmParse CmmExpr]
1088                 -> [CmmParse CmmExpr] -> CmmParse ()
1089 doJumpWithStack expr_code stk_code args_code = do
1090   dflags <- getDynFlags
1091   expr <- expr_code
1092   stk_args <- sequence stk_code
1093   args <- sequence args_code
1094   updfr_off <- getUpdFrameOff
1095   emit (mkJumpExtra dflags NativeNodeCall expr args updfr_off stk_args)
1096
1097 doCall :: CmmParse CmmExpr -> [CmmParse LocalReg] -> [CmmParse CmmExpr]
1098        -> CmmParse ()
1099 doCall expr_code res_code args_code = do
1100   dflags <- getDynFlags
1101   expr <- expr_code
1102   args <- sequence args_code
1103   ress <- sequence res_code
1104   updfr_off <- getUpdFrameOff
1105   c <- code $ mkCall expr (NativeNodeCall,NativeReturn) ress args updfr_off []
1106   emit c
1107
1108 adjCallTarget :: DynFlags -> CCallConv -> CmmExpr -> [(CmmExpr, ForeignHint) ]
1109               -> CmmExpr
1110 -- On Windows, we have to add the '@N' suffix to the label when making
1111 -- a call with the stdcall calling convention.
1112 adjCallTarget dflags StdCallConv (CmmLit (CmmLabel lbl)) args
1113  | platformOS (targetPlatform dflags) == OSMinGW32
1114   = CmmLit (CmmLabel (addLabelSize lbl (sum (map size args))))
1115   where size (e, _) = max (wORD_SIZE dflags) (widthInBytes (typeWidth (cmmExprType dflags e)))
1116                  -- c.f. CgForeignCall.emitForeignCall
1117 adjCallTarget _ _ expr _
1118   = expr
1119
1120 primCall
1121         :: [CmmParse (CmmFormal, ForeignHint)]
1122         -> FastString
1123         -> [CmmParse CmmExpr]
1124         -> P (CmmParse ())
1125 primCall results_code name args_code
1126   = case lookupUFM callishMachOps name of
1127         Nothing -> fail ("unknown primitive " ++ unpackFS name)
1128         Just p  -> return $ do
1129                 results <- sequence results_code
1130                 args <- sequence args_code
1131                 code (emitPrimCall (map fst results) p args)
1132
1133 doStore :: CmmType -> CmmParse CmmExpr  -> CmmParse CmmExpr -> CmmParse ()
1134 doStore rep addr_code val_code
1135   = do dflags <- getDynFlags
1136        addr <- addr_code
1137        val <- val_code
1138         -- if the specified store type does not match the type of the expr
1139         -- on the rhs, then we insert a coercion that will cause the type
1140         -- mismatch to be flagged by cmm-lint.  If we don't do this, then
1141         -- the store will happen at the wrong type, and the error will not
1142         -- be noticed.
1143        let val_width = typeWidth (cmmExprType dflags val)
1144            rep_width = typeWidth rep
1145        let coerce_val
1146                 | val_width /= rep_width = CmmMachOp (MO_UU_Conv val_width rep_width) [val]
1147                 | otherwise              = val
1148        emitStore addr coerce_val
1149
1150 -- -----------------------------------------------------------------------------
1151 -- If-then-else and boolean expressions
1152
1153 data BoolExpr
1154   = BoolExpr `BoolAnd` BoolExpr
1155   | BoolExpr `BoolOr`  BoolExpr
1156   | BoolNot BoolExpr
1157   | BoolTest CmmExpr
1158
1159 -- ToDo: smart constructors which simplify the boolean expression.
1160
1161 cmmIfThenElse cond then_part else_part = do
1162      then_id <- newBlockId
1163      join_id <- newBlockId
1164      c <- cond
1165      emitCond c then_id
1166      else_part
1167      emit (mkBranch join_id)
1168      emitLabel then_id
1169      then_part
1170      -- fall through to join
1171      emitLabel join_id
1172
1173 cmmRawIf cond then_id = do
1174     c <- cond
1175     emitCond c then_id
1176
1177 -- 'emitCond cond true_id'  emits code to test whether the cond is true,
1178 -- branching to true_id if so, and falling through otherwise.
1179 emitCond (BoolTest e) then_id = do
1180   else_id <- newBlockId
1181   emit (mkCbranch e then_id else_id)
1182   emitLabel else_id
1183 emitCond (BoolNot (BoolTest (CmmMachOp op args))) then_id
1184   | Just op' <- maybeInvertComparison op
1185   = emitCond (BoolTest (CmmMachOp op' args)) then_id
1186 emitCond (BoolNot e) then_id = do
1187   else_id <- newBlockId
1188   emitCond e else_id
1189   emit (mkBranch then_id)
1190   emitLabel else_id
1191 emitCond (e1 `BoolOr` e2) then_id = do
1192   emitCond e1 then_id
1193   emitCond e2 then_id
1194 emitCond (e1 `BoolAnd` e2) then_id = do
1195         -- we'd like to invert one of the conditionals here to avoid an
1196         -- extra branch instruction, but we can't use maybeInvertComparison
1197         -- here because we can't look too closely at the expression since
1198         -- we're in a loop.
1199   and_id <- newBlockId
1200   else_id <- newBlockId
1201   emitCond e1 and_id
1202   emit (mkBranch else_id)
1203   emitLabel and_id
1204   emitCond e2 then_id
1205   emitLabel else_id
1206
1207
1208 -- -----------------------------------------------------------------------------
1209 -- Table jumps
1210
1211 -- We use a simplified form of C-- switch statements for now.  A
1212 -- switch statement always compiles to a table jump.  Each arm can
1213 -- specify a list of values (not ranges), and there can be a single
1214 -- default branch.  The range of the table is given either by the
1215 -- optional range on the switch (eg. switch [0..7] {...}), or by
1216 -- the minimum/maximum values from the branches.
1217
1218 doSwitch :: Maybe (Int,Int) -> CmmParse CmmExpr -> [([Int],Either BlockId (CmmParse ()))]
1219          -> Maybe (CmmParse ()) -> CmmParse ()
1220 doSwitch mb_range scrut arms deflt
1221    = do
1222         -- Compile code for the default branch
1223         dflt_entry <- 
1224                 case deflt of
1225                   Nothing -> return Nothing
1226                   Just e  -> do b <- forkLabelledCode e; return (Just b)
1227
1228         -- Compile each case branch
1229         table_entries <- mapM emitArm arms
1230
1231         -- Construct the table
1232         let
1233             all_entries = concat table_entries
1234             ixs = map fst all_entries
1235             (min,max) 
1236                 | Just (l,u) <- mb_range = (l,u)
1237                 | otherwise              = (minimum ixs, maximum ixs)
1238
1239             entries = elems (accumArray (\_ a -> Just a) dflt_entry (min,max)
1240                                 all_entries)
1241         expr <- scrut
1242         -- ToDo: check for out of range and jump to default if necessary
1243         emit (mkSwitch expr entries)
1244    where
1245         emitArm :: ([Int],Either BlockId (CmmParse ())) -> CmmParse [(Int,BlockId)]
1246         emitArm (ints,Left blockid) = return [ (i,blockid) | i <- ints ]
1247         emitArm (ints,Right code) = do
1248            blockid <- forkLabelledCode code
1249            return [ (i,blockid) | i <- ints ]
1250
1251 forkLabelledCode :: CmmParse () -> CmmParse BlockId
1252 forkLabelledCode p = do
1253   ag <- getCode p
1254   l <- newBlockId
1255   emitOutOfLine l ag
1256   return l
1257
1258 -- -----------------------------------------------------------------------------
1259 -- Putting it all together
1260
1261 -- The initial environment: we define some constants that the compiler
1262 -- knows about here.
1263 initEnv :: DynFlags -> Env
1264 initEnv dflags = listToUFM [
1265   ( fsLit "SIZEOF_StgHeader",
1266     VarN (CmmLit (CmmInt (fromIntegral (fixedHdrSize dflags * wORD_SIZE dflags)) (wordWidth dflags)) )),
1267   ( fsLit "SIZEOF_StgInfoTable",
1268     VarN (CmmLit (CmmInt (fromIntegral (stdInfoTableSizeB dflags)) (wordWidth dflags)) ))
1269   ]
1270
1271 parseCmmFile :: DynFlags -> FilePath -> IO (Messages, Maybe CmmGroup)
1272 parseCmmFile dflags filename = do
1273   showPass dflags "ParseCmm"
1274   buf <- hGetStringBuffer filename
1275   let
1276         init_loc = mkRealSrcLoc (mkFastString filename) 1 1
1277         init_state = (mkPState dflags buf init_loc) { lex_state = [0] }
1278                 -- reset the lex_state: the Lexer monad leaves some stuff
1279                 -- in there we don't want.
1280   case unP cmmParse init_state of
1281     PFailed span err -> do
1282         let msg = mkPlainErrMsg dflags span err
1283         return ((emptyBag, unitBag msg), Nothing)
1284     POk pst code -> do
1285         st <- initC
1286         let (cmm,_) = runC dflags no_module st (getCmm (unEC code (initEnv dflags) [] >> return ()))
1287         let ms = getMessages pst
1288         if (errorsFound dflags ms)
1289          then return (ms, Nothing)
1290          else do
1291            dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (ppr cmm)
1292            return (ms, Just cmm)
1293   where
1294         no_module = panic "parseCmmFile: no module"
1295 }