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