Implement unboxed sum primitive type
[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         -- ToDo: the rest, maybe
993         -- edit: which rest?
994         -- also: how do we tell CMM Lint how to type check callish macops?
995     ]
996   where
997     memcpyLikeTweakArgs :: (Int -> CallishMachOp) -> [CmmExpr] -> (CallishMachOp, [CmmExpr])
998     memcpyLikeTweakArgs op [] = pgmError "memcpy-like function requires at least one argument"
999     memcpyLikeTweakArgs op args@(_:_) =
1000         (op align, args')
1001       where
1002         args' = init args
1003         align = case last args of
1004           CmmLit (CmmInt alignInteger _) -> fromInteger alignInteger
1005           e -> pprPgmError "Non-constant alignment in memcpy-like function:" (ppr e)
1006         -- The alignment of memcpy-ish operations must be a
1007         -- compile-time constant. We verify this here, passing it around
1008         -- in the MO_* constructor. In order to do this, however, we
1009         -- must intercept the arguments in primCall.
1010
1011 parseSafety :: String -> PD Safety
1012 parseSafety "safe"   = return PlaySafe
1013 parseSafety "unsafe" = return PlayRisky
1014 parseSafety "interruptible" = return PlayInterruptible
1015 parseSafety str      = fail ("unrecognised safety: " ++ str)
1016
1017 parseCmmHint :: String -> PD ForeignHint
1018 parseCmmHint "ptr"    = return AddrHint
1019 parseCmmHint "signed" = return SignedHint
1020 parseCmmHint str      = fail ("unrecognised hint: " ++ str)
1021
1022 -- labels are always pointers, so we might as well infer the hint
1023 inferCmmHint :: CmmExpr -> ForeignHint
1024 inferCmmHint (CmmLit (CmmLabel _)) = AddrHint
1025 inferCmmHint (CmmReg (CmmGlobal g)) | isPtrGlobalReg g = AddrHint
1026 inferCmmHint _ = NoHint
1027
1028 isPtrGlobalReg Sp                    = True
1029 isPtrGlobalReg SpLim                 = True
1030 isPtrGlobalReg Hp                    = True
1031 isPtrGlobalReg HpLim                 = True
1032 isPtrGlobalReg CCCS                  = True
1033 isPtrGlobalReg CurrentTSO            = True
1034 isPtrGlobalReg CurrentNursery        = True
1035 isPtrGlobalReg (VanillaReg _ VGcPtr) = True
1036 isPtrGlobalReg _                     = False
1037
1038 happyError :: PD a
1039 happyError = PD $ \_ s -> unP srcParseFail s
1040
1041 -- -----------------------------------------------------------------------------
1042 -- Statement-level macros
1043
1044 stmtMacro :: FastString -> [CmmParse CmmExpr] -> PD (CmmParse ())
1045 stmtMacro fun args_code = do
1046   case lookupUFM stmtMacros fun of
1047     Nothing -> fail ("unknown macro: " ++ unpackFS fun)
1048     Just fcode -> return $ do
1049         args <- sequence args_code
1050         code (fcode args)
1051
1052 stmtMacros :: UniqFM ([CmmExpr] -> FCode ())
1053 stmtMacros = listToUFM [
1054   ( fsLit "CCS_ALLOC",             \[words,ccs]  -> profAlloc words ccs ),
1055   ( fsLit "ENTER_CCS_THUNK",       \[e] -> enterCostCentreThunk e ),
1056
1057   ( fsLit "CLOSE_NURSERY",         \[]  -> emitCloseNursery ),
1058   ( fsLit "OPEN_NURSERY",          \[]  -> emitOpenNursery ),
1059
1060   -- completely generic heap and stack checks, for use in high-level cmm.
1061   ( fsLit "HP_CHK_GEN",            \[bytes] ->
1062                                       heapStackCheckGen Nothing (Just bytes) ),
1063   ( fsLit "STK_CHK_GEN",           \[] ->
1064                                       heapStackCheckGen (Just (CmmLit CmmHighStackMark)) Nothing ),
1065
1066   -- A stack check for a fixed amount of stack.  Sounds a bit strange, but
1067   -- we use the stack for a bit of temporary storage in a couple of primops
1068   ( fsLit "STK_CHK_GEN_N",         \[bytes] ->
1069                                       heapStackCheckGen (Just bytes) Nothing ),
1070
1071   -- A stack check on entry to a thunk, where the argument is the thunk pointer.
1072   ( fsLit "STK_CHK_NP"   ,         \[node] -> entryHeapCheck' False node 0 [] (return ())),
1073
1074   ( fsLit "LOAD_THREAD_STATE",     \[] -> emitLoadThreadState ),
1075   ( fsLit "SAVE_THREAD_STATE",     \[] -> emitSaveThreadState ),
1076
1077   ( fsLit "LDV_ENTER",             \[e] -> ldvEnter e ),
1078   ( fsLit "LDV_RECORD_CREATE",     \[e] -> ldvRecordCreate e ),
1079
1080   ( fsLit "PUSH_UPD_FRAME",        \[sp,e] -> emitPushUpdateFrame sp e ),
1081   ( fsLit "SET_HDR",               \[ptr,info,ccs] ->
1082                                         emitSetDynHdr ptr info ccs ),
1083   ( fsLit "TICK_ALLOC_PRIM",       \[hdr,goods,slop] ->
1084                                         tickyAllocPrim hdr goods slop ),
1085   ( fsLit "TICK_ALLOC_PAP",        \[goods,slop] ->
1086                                         tickyAllocPAP goods slop ),
1087   ( fsLit "TICK_ALLOC_UP_THK",     \[goods,slop] ->
1088                                         tickyAllocThunk goods slop ),
1089   ( fsLit "UPD_BH_UPDATABLE",      \[reg] -> emitBlackHoleCode reg )
1090  ]
1091
1092 emitPushUpdateFrame :: CmmExpr -> CmmExpr -> FCode ()
1093 emitPushUpdateFrame sp e = do
1094   dflags <- getDynFlags
1095   emitUpdateFrame dflags sp mkUpdInfoLabel e
1096
1097 pushStackFrame :: [CmmParse CmmExpr] -> CmmParse () -> CmmParse ()
1098 pushStackFrame fields body = do
1099   dflags <- getDynFlags
1100   exprs <- sequence fields
1101   updfr_off <- getUpdFrameOff
1102   let (new_updfr_off, _, g) = copyOutOflow dflags NativeReturn Ret Old
1103                                            [] updfr_off (map CmmExprArg exprs)
1104   emit g
1105   withUpdFrameOff new_updfr_off body
1106
1107 reserveStackFrame
1108   :: CmmParse CmmExpr
1109   -> CmmParse CmmReg
1110   -> CmmParse ()
1111   -> CmmParse ()
1112 reserveStackFrame psize preg body = do
1113   dflags <- getDynFlags
1114   old_updfr_off <- getUpdFrameOff
1115   reg <- preg
1116   esize <- psize
1117   let size = case constantFoldExpr dflags esize of
1118                CmmLit (CmmInt n _) -> n
1119                _other -> pprPanic "CmmParse: not a compile-time integer: "
1120                             (ppr esize)
1121   let frame = old_updfr_off + wORD_SIZE dflags * fromIntegral size
1122   emitAssign reg (CmmStackSlot Old frame)
1123   withUpdFrameOff frame body
1124
1125 profilingInfo dflags desc_str ty_str
1126   = if not (gopt Opt_SccProfilingOn dflags)
1127     then NoProfilingInfo
1128     else ProfilingInfo (stringToWord8s desc_str)
1129                        (stringToWord8s ty_str)
1130
1131 staticClosure :: UnitId -> FastString -> FastString -> [CmmLit] -> CmmParse ()
1132 staticClosure pkg cl_label info payload
1133   = do dflags <- getDynFlags
1134        let lits = mkStaticClosure dflags (mkCmmInfoLabel pkg info) dontCareCCS payload [] [] []
1135        code $ emitDataLits (mkCmmDataLabel pkg cl_label) lits
1136
1137 foreignCall
1138         :: String
1139         -> [CmmParse (LocalReg, ForeignHint)]
1140         -> CmmParse CmmExpr
1141         -> [CmmParse (CmmExpr, ForeignHint)]
1142         -> Safety
1143         -> CmmReturnInfo
1144         -> PD (CmmParse ())
1145 foreignCall conv_string results_code expr_code args_code safety ret
1146   = do  conv <- case conv_string of
1147           "C" -> return CCallConv
1148           "stdcall" -> return StdCallConv
1149           _ -> fail ("unknown calling convention: " ++ conv_string)
1150         return $ do
1151           dflags <- getDynFlags
1152           results <- sequence results_code
1153           expr <- expr_code
1154           args <- sequence args_code
1155           let
1156                   expr' = adjCallTarget dflags conv expr args
1157                   (arg_exprs, arg_hints) = unzip args
1158                   (res_regs,  res_hints) = unzip results
1159                   fc = ForeignConvention conv arg_hints res_hints ret
1160                   target = ForeignTarget expr' fc
1161           _ <- code $ emitForeignCall safety res_regs target arg_exprs
1162           return ()
1163
1164
1165 doReturn :: [CmmParse CmmExpr] -> CmmParse ()
1166 doReturn exprs_code = do
1167   dflags <- getDynFlags
1168   exprs <- sequence exprs_code
1169   updfr_off <- getUpdFrameOff
1170   emit (mkReturnSimple dflags exprs updfr_off)
1171
1172 mkReturnSimple  :: DynFlags -> [CmmActual] -> UpdFrameOffset -> CmmAGraph
1173 mkReturnSimple dflags actuals updfr_off =
1174   mkReturn dflags e (map CmmExprArg actuals) updfr_off
1175   where e = entryCode dflags (CmmLoad (CmmStackSlot Old updfr_off)
1176                              (gcWord dflags))
1177
1178 doRawJump :: CmmParse CmmExpr -> [GlobalReg] -> CmmParse ()
1179 doRawJump expr_code vols = do
1180   dflags <- getDynFlags
1181   expr <- expr_code
1182   updfr_off <- getUpdFrameOff
1183   emit (mkRawJump dflags expr updfr_off vols)
1184
1185 doJumpWithStack :: CmmParse CmmExpr -> [CmmParse CmmExpr]
1186                 -> [CmmParse CmmExpr] -> CmmParse ()
1187 doJumpWithStack expr_code stk_code args_code = do
1188   dflags <- getDynFlags
1189   expr <- expr_code
1190   stk_args <- sequence stk_code
1191   args <- sequence args_code
1192   updfr_off <- getUpdFrameOff
1193   emit (mkJumpExtra dflags NativeNodeCall expr (map CmmExprArg args) updfr_off (map CmmExprArg stk_args))
1194
1195 doCall :: CmmParse CmmExpr -> [CmmParse LocalReg] -> [CmmParse CmmExpr]
1196        -> CmmParse ()
1197 doCall expr_code res_code args_code = do
1198   dflags <- getDynFlags
1199   expr <- expr_code
1200   args <- sequence args_code
1201   ress <- sequence res_code
1202   updfr_off <- getUpdFrameOff
1203   c <- code $ mkCall expr (NativeNodeCall,NativeReturn) ress (map CmmExprArg args) updfr_off []
1204   emit c
1205
1206 adjCallTarget :: DynFlags -> CCallConv -> CmmExpr -> [(CmmExpr, ForeignHint) ]
1207               -> CmmExpr
1208 -- On Windows, we have to add the '@N' suffix to the label when making
1209 -- a call with the stdcall calling convention.
1210 adjCallTarget dflags StdCallConv (CmmLit (CmmLabel lbl)) args
1211  | platformOS (targetPlatform dflags) == OSMinGW32
1212   = CmmLit (CmmLabel (addLabelSize lbl (sum (map size args))))
1213   where size (e, _) = max (wORD_SIZE dflags) (widthInBytes (typeWidth (cmmExprType dflags e)))
1214                  -- c.f. CgForeignCall.emitForeignCall
1215 adjCallTarget _ _ expr _
1216   = expr
1217
1218 primCall
1219         :: [CmmParse (CmmFormal, ForeignHint)]
1220         -> FastString
1221         -> [CmmParse CmmExpr]
1222         -> PD (CmmParse ())
1223 primCall results_code name args_code
1224   = case lookupUFM callishMachOps name of
1225         Nothing -> fail ("unknown primitive " ++ unpackFS name)
1226         Just f  -> return $ do
1227                 results <- sequence results_code
1228                 args <- sequence args_code
1229                 let (p, args') = f args
1230                 code (emitPrimCall (map fst results) p args')
1231
1232 doStore :: CmmType -> CmmParse CmmExpr  -> CmmParse CmmExpr -> CmmParse ()
1233 doStore rep addr_code val_code
1234   = do dflags <- getDynFlags
1235        addr <- addr_code
1236        val <- val_code
1237         -- if the specified store type does not match the type of the expr
1238         -- on the rhs, then we insert a coercion that will cause the type
1239         -- mismatch to be flagged by cmm-lint.  If we don't do this, then
1240         -- the store will happen at the wrong type, and the error will not
1241         -- be noticed.
1242        let val_width = typeWidth (cmmExprType dflags val)
1243            rep_width = typeWidth rep
1244        let coerce_val
1245                 | val_width /= rep_width = CmmMachOp (MO_UU_Conv val_width rep_width) [val]
1246                 | otherwise              = val
1247        emitStore addr coerce_val
1248
1249 -- -----------------------------------------------------------------------------
1250 -- If-then-else and boolean expressions
1251
1252 data BoolExpr
1253   = BoolExpr `BoolAnd` BoolExpr
1254   | BoolExpr `BoolOr`  BoolExpr
1255   | BoolNot BoolExpr
1256   | BoolTest CmmExpr
1257
1258 -- ToDo: smart constructors which simplify the boolean expression.
1259
1260 cmmIfThenElse cond then_part else_part = do
1261      then_id <- newBlockId
1262      join_id <- newBlockId
1263      c <- cond
1264      emitCond c then_id
1265      else_part
1266      emit (mkBranch join_id)
1267      emitLabel then_id
1268      then_part
1269      -- fall through to join
1270      emitLabel join_id
1271
1272 cmmRawIf cond then_id = do
1273     c <- cond
1274     emitCond c then_id
1275
1276 -- 'emitCond cond true_id'  emits code to test whether the cond is true,
1277 -- branching to true_id if so, and falling through otherwise.
1278 emitCond (BoolTest e) then_id = do
1279   else_id <- newBlockId
1280   emit (mkCbranch e then_id else_id Nothing)
1281   emitLabel else_id
1282 emitCond (BoolNot (BoolTest (CmmMachOp op args))) then_id
1283   | Just op' <- maybeInvertComparison op
1284   = emitCond (BoolTest (CmmMachOp op' args)) then_id
1285 emitCond (BoolNot e) then_id = do
1286   else_id <- newBlockId
1287   emitCond e else_id
1288   emit (mkBranch then_id)
1289   emitLabel else_id
1290 emitCond (e1 `BoolOr` e2) then_id = do
1291   emitCond e1 then_id
1292   emitCond e2 then_id
1293 emitCond (e1 `BoolAnd` e2) then_id = do
1294         -- we'd like to invert one of the conditionals here to avoid an
1295         -- extra branch instruction, but we can't use maybeInvertComparison
1296         -- here because we can't look too closely at the expression since
1297         -- we're in a loop.
1298   and_id <- newBlockId
1299   else_id <- newBlockId
1300   emitCond e1 and_id
1301   emit (mkBranch else_id)
1302   emitLabel and_id
1303   emitCond e2 then_id
1304   emitLabel else_id
1305
1306 -- -----------------------------------------------------------------------------
1307 -- Source code notes
1308
1309 -- | Generate a source note spanning from "a" to "b" (inclusive), then
1310 -- proceed with parsing. This allows debugging tools to reason about
1311 -- locations in Cmm code.
1312 withSourceNote :: Located a -> Located b -> CmmParse c -> CmmParse c
1313 withSourceNote a b parse = do
1314   name <- getName
1315   case combineSrcSpans (getLoc a) (getLoc b) of
1316     RealSrcSpan span -> code (emitTick (SourceNote span name)) >> parse
1317     _other           -> parse
1318
1319 -- -----------------------------------------------------------------------------
1320 -- Table jumps
1321
1322 -- We use a simplified form of C-- switch statements for now.  A
1323 -- switch statement always compiles to a table jump.  Each arm can
1324 -- specify a list of values (not ranges), and there can be a single
1325 -- default branch.  The range of the table is given either by the
1326 -- optional range on the switch (eg. switch [0..7] {...}), or by
1327 -- the minimum/maximum values from the branches.
1328
1329 doSwitch :: Maybe (Integer,Integer)
1330          -> CmmParse CmmExpr
1331          -> [([Integer],Either BlockId (CmmParse ()))]
1332          -> Maybe (CmmParse ()) -> CmmParse ()
1333 doSwitch mb_range scrut arms deflt
1334    = do
1335         -- Compile code for the default branch
1336         dflt_entry <- 
1337                 case deflt of
1338                   Nothing -> return Nothing
1339                   Just e  -> do b <- forkLabelledCode e; return (Just b)
1340
1341         -- Compile each case branch
1342         table_entries <- mapM emitArm arms
1343         let table = M.fromList (concat table_entries)
1344
1345         dflags <- getDynFlags
1346         let range = fromMaybe (0, tARGET_MAX_WORD dflags) mb_range
1347
1348         expr <- scrut
1349         -- ToDo: check for out of range and jump to default if necessary
1350         emit $ mkSwitch expr (mkSwitchTargets False range dflt_entry table)
1351    where
1352         emitArm :: ([Integer],Either BlockId (CmmParse ())) -> CmmParse [(Integer,BlockId)]
1353         emitArm (ints,Left blockid) = return [ (i,blockid) | i <- ints ]
1354         emitArm (ints,Right code) = do
1355            blockid <- forkLabelledCode code
1356            return [ (i,blockid) | i <- ints ]
1357
1358 forkLabelledCode :: CmmParse () -> CmmParse BlockId
1359 forkLabelledCode p = do
1360   (_,ag) <- getCodeScoped p
1361   l <- newBlockId
1362   emitOutOfLine l ag
1363   return l
1364
1365 -- -----------------------------------------------------------------------------
1366 -- Putting it all together
1367
1368 -- The initial environment: we define some constants that the compiler
1369 -- knows about here.
1370 initEnv :: DynFlags -> Env
1371 initEnv dflags = listToUFM [
1372   ( fsLit "SIZEOF_StgHeader",
1373     VarN (CmmLit (CmmInt (fromIntegral (fixedHdrSize dflags)) (wordWidth dflags)) )),
1374   ( fsLit "SIZEOF_StgInfoTable",
1375     VarN (CmmLit (CmmInt (fromIntegral (stdInfoTableSizeB dflags)) (wordWidth dflags)) ))
1376   ]
1377
1378 parseCmmFile :: DynFlags -> FilePath -> IO (Messages, Maybe CmmGroup)
1379 parseCmmFile dflags filename = withTiming (pure dflags) (text "ParseCmm"<+>brackets (text filename)) (\_ -> ()) $ do
1380   buf <- hGetStringBuffer filename
1381   let
1382         init_loc = mkRealSrcLoc (mkFastString filename) 1 1
1383         init_state = (mkPState dflags buf init_loc) { lex_state = [0] }
1384                 -- reset the lex_state: the Lexer monad leaves some stuff
1385                 -- in there we don't want.
1386   case unPD cmmParse dflags init_state of
1387     PFailed span err -> do
1388         let msg = mkPlainErrMsg dflags span err
1389         return ((emptyBag, unitBag msg), Nothing)
1390     POk pst code -> do
1391         st <- initC
1392         let fcode = getCmm $ unEC code "global" (initEnv dflags) [] >> return ()
1393             (cmm,_) = runC dflags no_module st fcode
1394         let ms = getMessages pst dflags
1395         if (errorsFound dflags ms)
1396          then return (ms, Nothing)
1397          else return (ms, Just cmm)
1398   where
1399         no_module = panic "parseCmmFile: no module"
1400 }