CmmParse.y 48.9 KB
Newer Older
1 2
-----------------------------------------------------------------------------
--
3
-- (c) The University of Glasgow, 2004-2012
4 5 6 7 8
--
-- Parser for concrete Cmm.
--
-----------------------------------------------------------------------------

9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157
{- -----------------------------------------------------------------------------
Note [Syntax of .cmm files]

NOTE: You are very much on your own in .cmm.  There is very little
error checking at all:

  * Type errors are detected by the (optional) -dcmm-lint pass, if you
    don't turn this on then a type error will likely result in a panic
    from the native code generator.

  * Passing the wrong number of arguments or arguments of the wrong
    type is not detected.

There are two ways to write .cmm code:

 (1) High-level Cmm code delegates the stack handling to GHC, and
     never explicitly mentions Sp or registers.

 (2) Low-level Cmm manages the stack itself, and must know about
     calling conventions.

Whether you want high-level or low-level Cmm is indicated by the
presence of an argument list on a procedure.  For example:

foo ( gcptr a, bits32 b )
{
  // this is high-level cmm code

  if (b > 0) {
     // we can make tail calls passing arguments:
     jump stg_ap_0_fast(a);
  }

  push (stg_upd_frame_info, a) {
    // stack frames can be explicitly pushed

    (x,y) = call wibble(a,b,3,4);
      // calls pass arguments and return results using the native
      // Haskell calling convention.  The code generator will automatically
      // construct a stack frame and an info table for the continuation.

    return (x,y);
      // we can return multiple values from the current proc
  }
}

bar
{
  // this is low-level cmm code, indicated by the fact that we did not
  // put an argument list on bar.

  x = R1;  // the calling convention is explicit: better be careful
           // that this works on all platforms!

  jump %ENTRY_CODE(Sp(0))
}

Here is a list of rules for high-level and low-level code.  If you
break the rules, you get a panic (for using a high-level construct in
a low-level proc), or wrong code (when using low-level code in a
high-level proc).  This stuff isn't checked! (TODO!)

High-level only:

  - tail-calls with arguments, e.g.
    jump stg_fun (arg1, arg2);

  - function calls:
    (ret1,ret2) = call stg_fun (arg1, arg2);

    This makes a call with the NativeNodeCall convention, and the
    values are returned to the following code using the NativeReturn
    convention.

  - returning:
    return (ret1, ret2)

    These use the NativeReturn convention to return zero or more
    results to the caller.

  - pushing stack frames:
    push (info_ptr, field1, ..., fieldN) { ... statements ... }

Low-level only:

  - References to Sp, R1-R8, F1-F4 etc.

    NB. foreign calls may clobber the argument registers R1-R8, F1-F4
    etc., so ensure they are saved into variables around foreign
    calls.

  - SAVE_THREAD_STATE() and LOAD_THREAD_STATE(), which modify Sp
    directly.

Both high-level and low-level code can use a raw tail-call:

    jump stg_fun [R1,R2]

This always transfers control to a low-level Cmm function, but the
call can be made from high-level code.  Arguments must be passed
explicitly in R/F/D/L registers.

NB. you *must* specify the list of GlobalRegs that are passed via a
jump, otherwise the register allocator will assume that all the
GlobalRegs are dead at the jump.


A stack frame is written like this:

INFO_TABLE_RET ( label, FRAME_TYPE, info_ptr, field1, ..., fieldN )
               return ( arg1, ..., argM )
{
  ... code ...
}

where field1 ... fieldN are the fields of the stack frame (with types)
arg1...argN are the values returned to the stack frame (with types).
The return values are assumed to be passed according to the
NativeReturn convention.

On entry to the code, the stack frame looks like:

   |----------|
   | fieldN   |
   |   ...    |
   | field1   |
   |----------|
   | info_ptr |
   |----------|
   |  argN    |
   |   ...    | <- Sp

and some of the args may be in registers.

We prepend the code by a copyIn of the args, and assign all the stack
frame fields to their formals.  The initial "arg offset" for stack
layout purposes consists of the whole stack frame plus any args that
might be on the stack.

A tail-call may pass a stack frame to the callee using the following
syntax:

jump f (info_ptr, field1,..,fieldN) (arg1,..,argN)

where info_ptr and field1..fieldN describe the stack frame, and
arg1..argN are the arguments passed to f using the NativeNodeCall
convention.

----------------------------------------------------------------------------- -}
158

159
{
160
{-# LANGUAGE BangPatterns #-} -- required for versions of Happy before 1.18.6
161
{-# OPTIONS -Wwarn -w #-}
162 163 164
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix
-- any warnings in the module. See
Ian Lynagh's avatar
Ian Lynagh committed
165
--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
166 167
-- for details

168 169
module CmmParse ( parseCmmFile ) where

170 171 172 173 174 175 176 177 178 179 180 181
import StgCmmExtCode
import CmmCallConv
import StgCmmProf
import StgCmmHeap
import StgCmmMonad hiding ( getCode, getCodeR, emitLabel, emit, emitStore
                          , emitAssign, emitOutOfLine, withUpdFrameOff
                          , getUpdFrameOff )
import qualified StgCmmMonad as F
import StgCmmUtils
import StgCmmForeign
import StgCmmExpr
import StgCmmClosure
Simon Marlow's avatar
Simon Marlow committed
182
import StgCmmLayout     hiding (ArgRep(..))
183 184 185 186 187
import StgCmmTicky
import StgCmmBind       ( emitBlackHoleCode, emitUpdateFrame )

import MkGraph
import Cmm
Simon Marlow's avatar
Simon Marlow committed
188
import CmmUtils
189
import BlockId
190 191
import CmmLex
import CLabel
Simon Marlow's avatar
Simon Marlow committed
192
import SMRep
193 194
import Lexer

195
import CostCentre
Simon Marlow's avatar
Simon Marlow committed
196
import ForeignCall
197
import Module
198
import Platform
Simon Marlow's avatar
Simon Marlow committed
199
import Literal
200 201 202
import Unique
import UniqFM
import SrcLoc
Simon Marlow's avatar
Simon Marlow committed
203 204 205 206
import DynFlags
import StaticFlags
import ErrUtils
import StringBuffer
207
import FastString
Simon Marlow's avatar
Simon Marlow committed
208 209
import Panic
import Constants
210
import Outputable
211
import BasicTypes
212
import Bag              ( emptyBag, unitBag )
213
import Var
214

215
import Control.Monad
216
import Data.Array
217
import Data.Char        ( ord )
218
import System.Exit
219
import Data.Maybe
220 221

#include "HsVersions.h"
222 223
}

224 225
%expect 0

226
%token
227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258
        ':'     { L _ (CmmT_SpecChar ':') }
        ';'     { L _ (CmmT_SpecChar ';') }
        '{'     { L _ (CmmT_SpecChar '{') }
        '}'     { L _ (CmmT_SpecChar '}') }
        '['     { L _ (CmmT_SpecChar '[') }
        ']'     { L _ (CmmT_SpecChar ']') }
        '('     { L _ (CmmT_SpecChar '(') }
        ')'     { L _ (CmmT_SpecChar ')') }
        '='     { L _ (CmmT_SpecChar '=') }
        '`'     { L _ (CmmT_SpecChar '`') }
        '~'     { L _ (CmmT_SpecChar '~') }
        '/'     { L _ (CmmT_SpecChar '/') }
        '*'     { L _ (CmmT_SpecChar '*') }
        '%'     { L _ (CmmT_SpecChar '%') }
        '-'     { L _ (CmmT_SpecChar '-') }
        '+'     { L _ (CmmT_SpecChar '+') }
        '&'     { L _ (CmmT_SpecChar '&') }
        '^'     { L _ (CmmT_SpecChar '^') }
        '|'     { L _ (CmmT_SpecChar '|') }
        '>'     { L _ (CmmT_SpecChar '>') }
        '<'     { L _ (CmmT_SpecChar '<') }
        ','     { L _ (CmmT_SpecChar ',') }
        '!'     { L _ (CmmT_SpecChar '!') }

        '..'    { L _ (CmmT_DotDot) }
        '::'    { L _ (CmmT_DoubleColon) }
        '>>'    { L _ (CmmT_Shr) }
        '<<'    { L _ (CmmT_Shl) }
        '>='    { L _ (CmmT_Ge) }
        '<='    { L _ (CmmT_Le) }
        '=='    { L _ (CmmT_Eq) }
        '!='    { L _ (CmmT_Ne) }
259 260 261
        '&&'    { L _ (CmmT_BoolAnd) }
        '||'    { L _ (CmmT_BoolOr) }

262
        'CLOSURE'       { L _ (CmmT_CLOSURE) }
Simon Marlow's avatar
untab  
Simon Marlow committed
263 264 265 266 267 268 269 270 271 272 273
        'INFO_TABLE'    { L _ (CmmT_INFO_TABLE) }
        'INFO_TABLE_RET'{ L _ (CmmT_INFO_TABLE_RET) }
        'INFO_TABLE_FUN'{ L _ (CmmT_INFO_TABLE_FUN) }
        'INFO_TABLE_CONSTR'{ L _ (CmmT_INFO_TABLE_CONSTR) }
        'INFO_TABLE_SELECTOR'{ L _ (CmmT_INFO_TABLE_SELECTOR) }
        'else'          { L _ (CmmT_else) }
        'export'        { L _ (CmmT_export) }
        'section'       { L _ (CmmT_section) }
        'align'         { L _ (CmmT_align) }
        'goto'          { L _ (CmmT_goto) }
        'if'            { L _ (CmmT_if) }
274 275 276
        'call'          { L _ (CmmT_call) }
        'jump'          { L _ (CmmT_jump) }
        'foreign'       { L _ (CmmT_foreign) }
Simon Marlow's avatar
untab  
Simon Marlow committed
277 278 279 280 281 282 283
        'never'         { L _ (CmmT_never) }
        'prim'          { L _ (CmmT_prim) }
        'return'        { L _ (CmmT_return) }
        'returns'       { L _ (CmmT_returns) }
        'import'        { L _ (CmmT_import) }
        'switch'        { L _ (CmmT_switch) }
        'case'          { L _ (CmmT_case) }
284 285 286
        'default'       { L _ (CmmT_default) }
        'push'          { L _ (CmmT_push) }
        'bits8'         { L _ (CmmT_bits8) }
Simon Marlow's avatar
untab  
Simon Marlow committed
287 288 289 290 291 292 293 294 295 296 297 298
        'bits16'        { L _ (CmmT_bits16) }
        'bits32'        { L _ (CmmT_bits32) }
        'bits64'        { L _ (CmmT_bits64) }
        'float32'       { L _ (CmmT_float32) }
        'float64'       { L _ (CmmT_float64) }
        'gcptr'         { L _ (CmmT_gcptr) }

        GLOBALREG       { L _ (CmmT_GlobalReg   $$) }
        NAME            { L _ (CmmT_Name        $$) }
        STRING          { L _ (CmmT_String      $$) }
        INT             { L _ (CmmT_Int         $$) }
        FLOAT           { L _ (CmmT_Float       $$) }
299 300 301 302 303 304 305

%monad { P } { >>= } { return }
%lexer { cmmlex } { L _ CmmT_EOF }
%name cmmParse cmm
%tokentype { Located CmmToken }

-- C-- operator precedences, taken from the C-- spec
306 307
%right '||'     -- non-std extension, called %disjoin in C--
%right '&&'     -- non-std extension, called %conjoin in C--
308 309 310 311 312 313 314 315 316 317 318 319
%right '!'
%nonassoc '>=' '>' '<=' '<' '!=' '=='
%left '|'
%left '^'
%left '&'
%left '>>' '<<'
%left '-' '+'
%left '/' '*' '%'
%right '~'

%%

320
cmm     :: { CmmParse () }
Simon Marlow's avatar
untab  
Simon Marlow committed
321 322
        : {- empty -}                   { return () }
        | cmmtop cmm                    { do $1; $2 }
323

324
cmmtop  :: { CmmParse () }
Simon Marlow's avatar
untab  
Simon Marlow committed
325 326 327 328 329 330 331
        : cmmproc                       { $1 }
        | cmmdata                       { $1 }
        | decl                          { $1 } 
        | 'CLOSURE' '(' NAME ',' NAME lits ')' ';'  
                {% withThisPackage $ \pkg -> 
                   do lits <- sequence $6;
                      staticClosure pkg $3 $5 (map getLit lits) }
332 333 334 335 336

-- The only static closures in the RTS are dummy closures like
-- stg_END_TSO_QUEUE_closure and stg_dummy_ret.  We don't need
-- to provide the full generality of static closures here.
-- In particular:
337 338 339 340
--      * CCS can always be CCS_DONT_CARE
--      * closure is always extern
--      * payload is always empty
--      * we can derive closure and info table labels from a single NAME
341

342
cmmdata :: { CmmParse () }
Simon Marlow's avatar
untab  
Simon Marlow committed
343 344 345 346
        : 'section' STRING '{' data_label statics '}' 
                { do lbl <- $4;
                     ss <- sequence $5;
                     code (emitDecl (CmmData (section $2) (Statics lbl $ concat ss))) }
347 348

data_label :: { CmmParse CLabel }
Simon Marlow's avatar
untab  
Simon Marlow committed
349 350 351
    : NAME ':'  
                {% withThisPackage $ \pkg -> 
                   return (mkCmmDataLabel pkg $1) }
352

Simon Marlow's avatar
untab  
Simon Marlow committed
353 354 355
statics :: { [CmmParse [CmmStatic]] }
        : {- empty -}                   { [] }
        | static statics                { $1 : $2 }
356
    
357 358
-- Strings aren't used much in the RTS HC code, so it doesn't seem
-- worth allowing inline strings.  C-- doesn't allow them anyway.
359
static  :: { CmmParse [CmmStatic] }
Simon Marlow's avatar
untab  
Simon Marlow committed
360 361 362 363 364 365 366 367 368 369 370 371
        : type expr ';' { do e <- $2;
                             return [CmmStaticLit (getLit e)] }
        | type ';'                      { return [CmmUninitialised
                                                        (widthInBytes (typeWidth $1))] }
        | 'bits8' '[' ']' STRING ';'    { return [mkString $4] }
        | 'bits8' '[' INT ']' ';'       { return [CmmUninitialised 
                                                        (fromIntegral $3)] }
        | typenot8 '[' INT ']' ';'      { return [CmmUninitialised 
                                                (widthInBytes (typeWidth $1) * 
                                                        fromIntegral $3)] }
        | 'CLOSURE' '(' NAME lits ')'
                { do { lits <- sequence $4
372
                ; dflags <- getDynFlags
373
                     ; return $ map CmmStaticLit $
374
                        mkStaticClosure dflags (mkForeignLabel $3 Nothing ForeignLabelInExternalPackage IsData)
375 376
                         -- mkForeignLabel because these are only used
                         -- for CHARLIKE and INTLIKE closures in the RTS.
377
                        dontCareCCS (map getLit lits) [] [] [] } }
378
        -- arrays of closures required for the CHARLIKE & INTLIKE arrays
379

380
lits    :: { [CmmParse CmmExpr] }
Simon Marlow's avatar
untab  
Simon Marlow committed
381 382
        : {- empty -}           { [] }
        | ',' expr lits         { $2 : $3 }
383 384 385 386 387 388 389

cmmproc :: { CmmParse () }
        : info maybe_conv maybe_formals maybe_body
                { do ((entry_ret_label, info, stk_formals, formals), agraph) <-
                       getCodeR $ loopDecls $ do {
                         (entry_ret_label, info, stk_formals) <- $1;
                         formals <- sequence (fromMaybe [] $3);
Simon Marlow's avatar
Simon Marlow committed
390
                         $4;
391 392 393 394 395
                         return (entry_ret_label, info, stk_formals, formals) }
                     let do_layout = isJust $3
                     code (emitProcWithStackFrame $2 info
                                entry_ret_label stk_formals formals agraph
                                do_layout ) }
396

397 398 399
maybe_conv :: { Convention }
           : {- empty -}        { NativeNodeCall }
           | 'return'           { NativeReturn }
400

401 402 403 404 405 406
maybe_body :: { CmmParse () }
           : ';'                { return () }
           | '{' body '}'       { $2 }

info    :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }
        : NAME
Simon Marlow's avatar
untab  
Simon Marlow committed
407 408
                {% withThisPackage $ \pkg ->
                   do   newFunctionName $1 pkg
409 410 411 412
                        return (mkCmmCodeLabel pkg $1, Nothing, []) }


        | 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
Simon Marlow's avatar
untab  
Simon Marlow committed
413 414
                -- ptrs, nptrs, closure type, description, type
                {% withThisPackage $ \pkg ->
415 416
                   do dflags <- getDynFlags
                      let prof = profilingInfo dflags $11 $13
417
                          rep  = mkRTSRep (fromIntegral $9) $
418
                                   mkHeapRep dflags False (fromIntegral $5)
419 420 421 422
                                                   (fromIntegral $7) Thunk
                              -- not really Thunk, but that makes the info table
                              -- we want.
                      return (mkCmmEntryLabel pkg $3,
423
                              Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
Simon Marlow's avatar
untab  
Simon Marlow committed
424 425 426 427
                                           , cit_rep = rep
                                           , cit_prof = prof, cit_srt = NoC_SRT },
                              []) }
        
428
        | 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ')'
Simon Marlow's avatar
untab  
Simon Marlow committed
429 430
                -- ptrs, nptrs, closure type, description, type, fun type
                {% withThisPackage $ \pkg -> 
431 432
                   do dflags <- getDynFlags
                      let prof = profilingInfo dflags $11 $13
433
                          ty   = Fun 0 (ArgSpec (fromIntegral $15))
434
                                -- Arity zero, arg_type $15
435
                          rep = mkRTSRep (fromIntegral $9) $
436
                                    mkHeapRep dflags False (fromIntegral $5)
437 438
                                                    (fromIntegral $7) ty
                      return (mkCmmEntryLabel pkg $3,
439
                              Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
Simon Marlow's avatar
untab  
Simon Marlow committed
440 441 442 443 444
                                           , cit_rep = rep
                                           , cit_prof = prof, cit_srt = NoC_SRT },
                              []) }
                -- we leave most of the fields zero here.  This is only used
                -- to generate the BCO info table in the RTS at the moment.
445 446

        | 'INFO_TABLE_CONSTR' '(' NAME ',' INT ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
447 448
                -- ptrs, nptrs, tag, closure type, description, type
                {% withThisPackage $ \pkg ->
449 450
                   do dflags <- getDynFlags
                      let prof = profilingInfo dflags $13 $15
451
                          ty  = Constr (fromIntegral $9)  -- Tag
452
                                       (stringToWord8s $13)
453
                          rep = mkRTSRep (fromIntegral $11) $
454
                                  mkHeapRep dflags False (fromIntegral $5)
455 456
                                                  (fromIntegral $7) ty
                      return (mkCmmEntryLabel pkg $3,
457
                              Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
Simon Marlow's avatar
untab  
Simon Marlow committed
458 459 460
                                           , cit_rep = rep
                                           , cit_prof = prof, cit_srt = NoC_SRT },
                              []) }
461

Simon Marlow's avatar
untab  
Simon Marlow committed
462 463 464
                     -- If profiling is on, this string gets duplicated,
                     -- but that's the way the old code did it we can fix it some other time.
        
465
        | 'INFO_TABLE_SELECTOR' '(' NAME ',' INT ',' INT ',' STRING ',' STRING ')'
Simon Marlow's avatar
untab  
Simon Marlow committed
466 467
                -- selector, closure type, description, type
                {% withThisPackage $ \pkg ->
468 469
                   do dflags <- getDynFlags
                      let prof = profilingInfo dflags $9 $11
470 471
                          ty  = ThunkSelector (fromIntegral $5)
                          rep = mkRTSRep (fromIntegral $7) $
472
                                   mkHeapRep dflags False 0 0 ty
473
                      return (mkCmmEntryLabel pkg $3,
474
                              Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
Simon Marlow's avatar
untab  
Simon Marlow committed
475 476 477
                                           , cit_rep = rep
                                           , cit_prof = prof, cit_srt = NoC_SRT },
                              []) }
478 479

        | 'INFO_TABLE_RET' '(' NAME ',' INT ')'
Simon Marlow's avatar
untab  
Simon Marlow committed
480 481 482
                -- closure type (no live regs)
                {% withThisPackage $ \pkg ->
                   do let prof = NoProfilingInfo
483
                          rep  = mkRTSRep (fromIntegral $5) $ mkStackRep []
484
                      return (mkCmmRetLabel pkg $3,
485
                              Just $ CmmInfoTable { cit_lbl = mkCmmRetInfoLabel pkg $3
Simon Marlow's avatar
untab  
Simon Marlow committed
486 487 488
                                           , cit_rep = rep
                                           , cit_prof = prof, cit_srt = NoC_SRT },
                              []) }
489 490

        | 'INFO_TABLE_RET' '(' NAME ',' INT ',' formals0 ')'
Simon Marlow's avatar
untab  
Simon Marlow committed
491 492
                -- closure type, live regs
                {% withThisPackage $ \pkg ->
493
                   do dflags <- getDynFlags
494
                      live <- sequence $7
Simon Marlow's avatar
untab  
Simon Marlow committed
495
                      let prof = NoProfilingInfo
496 497 498
                          -- drop one for the info pointer
                          bitmap = mkLiveness dflags (map Just (drop 1 live))
                          rep  = mkRTSRep (fromIntegral $5) $ mkStackRep bitmap
499
                      return (mkCmmRetLabel pkg $3,
500
                              Just $ CmmInfoTable { cit_lbl = mkCmmRetInfoLabel pkg $3
Simon Marlow's avatar
untab  
Simon Marlow committed
501 502
                                           , cit_rep = rep
                                           , cit_prof = prof, cit_srt = NoC_SRT },
503
                              live) }
504

505
body    :: { CmmParse () }
Simon Marlow's avatar
untab  
Simon Marlow committed
506 507 508
        : {- empty -}                   { return () }
        | decl body                     { do $1; $2 }
        | stmt body                     { do $1; $2 }
509

510
decl    :: { CmmParse () }
Simon Marlow's avatar
untab  
Simon Marlow committed
511 512 513
        : type names ';'                { mapM_ (newLocal $1) $2 }
        | 'import' importNames ';'      { mapM_ newImport $2 }
        | 'export' names ';'            { return () }  -- ignore exports
514

515 516

-- an imported function name, with optional packageId
517 518 519 520 521
importNames
        :: { [(FastString, CLabel)] }
        : importName                    { [$1] }
        | importName ',' importNames    { $1 : $3 }

522
importName
523 524
        :: { (FastString,  CLabel) }

Simon Marlow's avatar
untab  
Simon Marlow committed
525 526 527 528 529 530 531 532 533 534 535 536 537 538 539
        -- A label imported without an explicit packageId.
        --      These are taken to come frome some foreign, unnamed package.
        : NAME  
        { ($1, mkForeignLabel $1 Nothing ForeignLabelInExternalPackage IsFunction) }

        -- A label imported with an explicit packageId.
        | STRING NAME
        { ($2, mkCmmCodeLabel (fsToPackageId (mkFastString $1)) $2) }
        
        
names   :: { [FastString] }
        : NAME                          { [$1] }
        | NAME ',' names                { $1 : $3 }

stmt    :: { CmmParse () }
540 541
        : ';'                                   { return () }

Simon Marlow's avatar
untab  
Simon Marlow committed
542
        | NAME ':'
543 544 545 546
                { do l <- newLabel $1; emitLabel l }



Simon Marlow's avatar
untab  
Simon Marlow committed
547
        | lreg '=' expr ';'
548
                { do reg <- $1; e <- $3; emitAssign reg e }
Simon Marlow's avatar
untab  
Simon Marlow committed
549 550
        | type '[' expr ']' '=' expr ';'
                { doStore $1 $3 $6 }
551 552

        -- Gah! We really want to say "foreign_results" but that causes
Simon Marlow's avatar
untab  
Simon Marlow committed
553 554 555 556 557
        -- a shift/reduce conflict with assignment.  We either
        -- we expand out the no-result and single result cases or
        -- we tweak the syntax to avoid the conflict.  The later
        -- option is taken here because the other way would require
        -- multiple levels of expanding and get unwieldy.
558 559 560 561
        | foreign_results 'foreign' STRING expr '(' cmm_hint_exprs0 ')' safety opt_never_returns ';'
                {% foreignCall $3 $1 $4 $6 $8 $9 }
        | foreign_results 'prim' '%' NAME '(' exprs0 ')' ';'
                {% primCall $1 $4 $6 }
Simon Marlow's avatar
untab  
Simon Marlow committed
562 563 564 565 566 567 568
        -- stmt-level macros, stealing syntax from ordinary C-- function calls.
        -- Perhaps we ought to use the %%-form?
        | NAME '(' exprs0 ')' ';'
                {% stmtMacro $1 $3  }
        | 'switch' maybe_range expr '{' arms default '}'
                { do as <- sequence $5; doSwitch $2 $3 as $6 }
        | 'goto' NAME ';'
569 570 571
                { do l <- lookupLabel $2; emit (mkBranch l) }
        | 'return' '(' exprs0 ')' ';'
                { doReturn $3 }
572
        | 'jump' expr vols ';'
573 574 575 576 577 578 579 580 581
                { doRawJump $2 $3 }
        | 'jump' expr '(' exprs0 ')' ';'
                { doJumpWithStack $2 [] $4 }
        | 'jump' expr '(' exprs0 ')' '(' exprs0 ')' ';'
                { doJumpWithStack $2 $4 $7 }
        | 'call' expr '(' exprs0 ')' ';'
                { doCall $2 [] $4 }
        | '(' formals ')' '=' 'call' expr '(' exprs0 ')' ';'
                { doCall $6 $2 $8 }
582
        | 'if' bool_expr 'goto' NAME
Simon Marlow's avatar
untab  
Simon Marlow committed
583 584 585
                { do l <- lookupLabel $4; cmmRawIf $2 l }
        | 'if' bool_expr '{' body '}' else      
                { cmmIfThenElse $2 $4 $6 }
586 587
        | 'push' '(' exprs0 ')' maybe_body
                { pushStackFrame $3 $5 }
588

589 590 591
opt_never_returns :: { CmmReturnInfo }
        :                               { CmmMayReturn }
        | 'never' 'returns'             { CmmNeverReturns }
592

593
bool_expr :: { CmmParse BoolExpr }
Simon Marlow's avatar
untab  
Simon Marlow committed
594 595
        : bool_op                       { $1 }
        | expr                          { do e <- $1; return (BoolTest e) }
596 597

bool_op :: { CmmParse BoolExpr }
Simon Marlow's avatar
untab  
Simon Marlow committed
598 599 600 601 602 603
        : bool_expr '&&' bool_expr      { do e1 <- $1; e2 <- $3; 
                                          return (BoolAnd e1 e2) }
        | bool_expr '||' bool_expr      { do e1 <- $1; e2 <- $3; 
                                          return (BoolOr e1 e2)  }
        | '!' bool_expr                 { do e <- $2; return (BoolNot e) }
        | '(' bool_op ')'               { $2 }
604 605 606

safety  :: { Safety }
        : {- empty -}                   { PlayRisky }
Simon Marlow's avatar
untab  
Simon Marlow committed
607
        | STRING                        {% parseSafety $1 }
608 609 610 611

vols    :: { [GlobalReg] }
        : '[' ']'                       { [] }
        | '[' '*' ']'                   {% do df <- getDynFlags
612 613 614
                                         ; return (realArgRegsCover df) }
                                           -- All of them. See comment attached
                                           -- to realArgRegsCover
615
        | '[' globals ']'               { $2 }
616 617

globals :: { [GlobalReg] }
618 619
        : GLOBALREG                     { [$1] }
        | GLOBALREG ',' globals         { $1 : $3 }
620 621

maybe_range :: { Maybe (Int,Int) }
622 623
        : '[' INT '..' INT ']'  { Just (fromIntegral $2, fromIntegral $4) }
        | {- empty -}           { Nothing }
624

625
arms    :: { [CmmParse ([Int],Either BlockId (CmmParse ()))] }
Simon Marlow's avatar
untab  
Simon Marlow committed
626 627
        : {- empty -}                   { [] }
        | arm arms                      { $1 : $2 }
628

629
arm     :: { CmmParse ([Int],Either BlockId (CmmParse ())) }
Simon Marlow's avatar
untab  
Simon Marlow committed
630
        : 'case' ints ':' arm_body      { do b <- $4; return ($2, b) }
631

632
arm_body :: { CmmParse (Either BlockId (CmmParse ())) }
Simon Marlow's avatar
untab  
Simon Marlow committed
633 634
        : '{' body '}'                  { return (Right $2) }
        | 'goto' NAME ';'               { do l <- lookupLabel $2; return (Left l) }
635

636 637 638
ints    :: { [Int] }
        : INT                           { [ fromIntegral $1 ] }
        | INT ',' ints                  { fromIntegral $1 : $3 }
639

640
default :: { Maybe (CmmParse ()) }
Simon Marlow's avatar
untab  
Simon Marlow committed
641 642 643 644
        : 'default' ':' '{' body '}'    { Just $4 }
        -- taking a few liberties with the C-- syntax here; C-- doesn't have
        -- 'default' branches
        | {- empty -}                   { Nothing }
645

646 647
-- Note: OldCmm doesn't support a first class 'else' statement, though
-- CmmNode does.
648 649
else    :: { CmmParse () }
        : {- empty -}                   { return () }
Simon Marlow's avatar
untab  
Simon Marlow committed
650
        | 'else' '{' body '}'           { $3 }
651 652 653

-- we have to write this out longhand so that Happy's precedence rules
-- can kick in.
654
expr    :: { CmmParse CmmExpr }
Simon Marlow's avatar
untab  
Simon Marlow committed
655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685
        : expr '/' expr                 { mkMachOp MO_U_Quot [$1,$3] }
        | expr '*' expr                 { mkMachOp MO_Mul [$1,$3] }
        | expr '%' expr                 { mkMachOp MO_U_Rem [$1,$3] }
        | expr '-' expr                 { mkMachOp MO_Sub [$1,$3] }
        | expr '+' expr                 { mkMachOp MO_Add [$1,$3] }
        | expr '>>' expr                { mkMachOp MO_U_Shr [$1,$3] }
        | expr '<<' expr                { mkMachOp MO_Shl [$1,$3] }
        | expr '&' expr                 { mkMachOp MO_And [$1,$3] }
        | expr '^' expr                 { mkMachOp MO_Xor [$1,$3] }
        | expr '|' expr                 { mkMachOp MO_Or [$1,$3] }
        | expr '>=' expr                { mkMachOp MO_U_Ge [$1,$3] }
        | expr '>' expr                 { mkMachOp MO_U_Gt [$1,$3] }
        | expr '<=' expr                { mkMachOp MO_U_Le [$1,$3] }
        | expr '<' expr                 { mkMachOp MO_U_Lt [$1,$3] }
        | expr '!=' expr                { mkMachOp MO_Ne [$1,$3] }
        | expr '==' expr                { mkMachOp MO_Eq [$1,$3] }
        | '~' expr                      { mkMachOp MO_Not [$2] }
        | '-' expr                      { mkMachOp MO_S_Neg [$2] }
        | expr0 '`' NAME '`' expr0      {% do { mo <- nameToMachOp $3 ;
                                                return (mkMachOp mo [$1,$5]) } }
        | expr0                         { $1 }

expr0   :: { CmmParse CmmExpr }
        : INT   maybe_ty         { return (CmmLit (CmmInt $1 (typeWidth $2))) }
        | FLOAT maybe_ty         { return (CmmLit (CmmFloat $1 (typeWidth $2))) }
        | STRING                 { do s <- code (newStringCLit $1); 
                                      return (CmmLit s) }
        | reg                    { $1 }
        | type '[' expr ']'      { do e <- $3; return (CmmLoad e $1) }
        | '%' NAME '(' exprs0 ')' {% exprOp $2 $4 }
        | '(' expr ')'           { $2 }
686 687 688


-- leaving out the type of a literal gives you the native word size in C--
689
maybe_ty :: { CmmType }
690
        : {- empty -}                   {% do dflags <- getDynFlags; return $ bWord dflags }
691
        | '::' type                     { $2 }
692

693
cmm_hint_exprs0 :: { [CmmParse (CmmExpr, ForeignHint)] }
Simon Marlow's avatar
untab  
Simon Marlow committed
694
        : {- empty -}                   { [] }
695
        | cmm_hint_exprs                { $1 }
696

697
cmm_hint_exprs :: { [CmmParse (CmmExpr, ForeignHint)] }
Simon Marlow's avatar
untab  
Simon Marlow committed
698 699
        : cmm_hint_expr                 { [$1] }
        | cmm_hint_expr ',' cmm_hint_exprs      { $1 : $3 }
700

701 702 703
cmm_hint_expr :: { CmmParse (CmmExpr, ForeignHint) }
        : expr                          { do e <- $1;
                                             return (e, inferCmmHint e) }
Simon Marlow's avatar
untab  
Simon Marlow committed
704 705
        | expr STRING                   {% do h <- parseCmmHint $2;
                                              return $ do
706
                                                e <- $1; return (e, h) }
707

708
exprs0  :: { [CmmParse CmmExpr] }
Simon Marlow's avatar
untab  
Simon Marlow committed
709 710
        : {- empty -}                   { [] }
        | exprs                         { $1 }
711

712
exprs   :: { [CmmParse CmmExpr] }
Simon Marlow's avatar
untab  
Simon Marlow committed
713 714
        : expr                          { [ $1 ] }
        | expr ',' exprs                { $1 : $3 }
715

716
reg     :: { CmmParse CmmExpr }
Simon Marlow's avatar
untab  
Simon Marlow committed
717 718
        : NAME                  { lookupName $1 }
        | GLOBALREG             { return (CmmReg (CmmGlobal $1)) }
719 720 721 722 723 724

foreign_results :: { [CmmParse (LocalReg, ForeignHint)] }
        : {- empty -}                   { [] }
        | '(' foreign_formals ')' '='   { $2 }

foreign_formals :: { [CmmParse (LocalReg, ForeignHint)] }
Simon Marlow's avatar
untab  
Simon Marlow committed
725
        : foreign_formal                        { [$1] }
726 727 728 729 730 731 732 733 734 735
        | foreign_formal ','                    { [$1] }
        | foreign_formal ',' foreign_formals    { $1 : $3 }

foreign_formal :: { CmmParse (LocalReg, ForeignHint) }
        : local_lreg            { do e <- $1; return (e, (inferCmmHint (CmmReg (CmmLocal e)))) }
        | STRING local_lreg     {% do h <- parseCmmHint $1;
                                      return $ do
                                         e <- $2; return (e,h) }

local_lreg :: { CmmParse LocalReg }
Simon Marlow's avatar
untab  
Simon Marlow committed
736 737 738 739 740 741 742 743 744 745 746 747 748
        : NAME                  { do e <- lookupName $1;
                                     return $
                                       case e of 
                                        CmmReg (CmmLocal r) -> r
                                        other -> pprPanic "CmmParse:" (ftext $1 <> text " not a local register") }

lreg    :: { CmmParse CmmReg }
        : NAME                  { do e <- lookupName $1;
                                     return $
                                       case e of 
                                        CmmReg r -> r
                                        other -> pprPanic "CmmParse:" (ftext $1 <> text " not a register") }
        | GLOBALREG             { return (CmmGlobal $1) }
749 750 751 752 753 754

maybe_formals :: { Maybe [CmmParse LocalReg] }
        : {- empty -}           { Nothing }
        | '(' formals0 ')'      { Just $2 }

formals0 :: { [CmmParse LocalReg] }
Simon Marlow's avatar
untab  
Simon Marlow committed
755
        : {- empty -}           { [] }
756 757 758 759 760 761 762 763
        | formals               { $1 }

formals :: { [CmmParse LocalReg] }
        : formal ','            { [$1] }
        | formal                { [$1] }
        | formal ',' formals       { $1 : $3 }

formal :: { CmmParse LocalReg }
Simon Marlow's avatar
untab  
Simon Marlow committed
764
        : type NAME             { newLocal $1 $2 }
765

Simon Marlow's avatar
Simon Marlow committed
766
type    :: { CmmType }
767 768
        : 'bits8'               { b8 }
        | typenot8              { $1 }
769

770
typenot8 :: { CmmType }
771 772 773 774 775
        : 'bits16'              { b16 }
        | 'bits32'              { b32 }
        | 'bits64'              { b64 }
        | 'float32'             { f32 }
        | 'float64'             { f64 }
776
        | 'gcptr'               {% do dflags <- getDynFlags; return $ gcWord dflags }
777

778 779
{
section :: String -> Section
780 781 782
section "text"      = Text
section "data"      = Data
section "rodata"    = ReadOnlyData
783
section "relrodata" = RelocatableReadOnlyData
784 785
section "bss"       = UninitialisedData
section s           = OtherSection s
786

787 788 789
mkString :: String -> CmmStatic
mkString s = CmmString (map (fromIntegral.ord) s)

790 791 792 793 794 795 796 797 798 799 800
-- |
-- Given an info table, decide what the entry convention for the proc
-- is.  That is, for an INFO_TABLE_RET we want the return convention,
-- otherwise it is a NativeNodeCall.
--
infoConv :: Maybe CmmInfoTable -> Convention
infoConv Nothing = NativeNodeCall
infoConv (Just info)
  | isStackRep (cit_rep info) = NativeReturn
  | otherwise                 = NativeNodeCall

801 802 803 804
-- mkMachOp infers the type of the MachOp from the type of its first
-- argument.  We assume that this is correct: for MachOps that don't have
-- symmetrical args (e.g. shift ops), the first arg determines the type of
-- the op.
805
mkMachOp :: (Width -> MachOp) -> [CmmParse CmmExpr] -> CmmParse CmmExpr
806
mkMachOp fn args = do
807
  dflags <- getDynFlags
808
  arg_exprs <- sequence args
809
  return (CmmMachOp (fn (typeWidth (cmmExprType dflags (head arg_exprs)))) arg_exprs)
810 811 812 813 814 815

getLit :: CmmExpr -> CmmLit
getLit (CmmLit l) = l
getLit (CmmMachOp (MO_S_Neg _) [CmmLit (CmmInt i r)])  = CmmInt (negate i) r
getLit _ = panic "invalid literal" -- TODO messy failure

816
nameToMachOp :: FastString -> P (Width -> MachOp)
817
nameToMachOp name =
818
  case lookupUFM machOps name of
819 820
        Nothing -> fail ("unknown primitive " ++ unpackFS name)
        Just m  -> return m
821

822
exprOp :: FastString -> [CmmParse CmmExpr] -> P (CmmParse CmmExpr)
823 824 825
exprOp name args_code = do
  dflags <- getDynFlags
  case lookupUFM (exprMacros dflags) name of
826 827
     Just f  -> return $ do
        args <- sequence args_code
828
        return (f args)
829
     Nothing -> do
830 831
        mo <- nameToMachOp name
        return $ mkMachOp mo args_code
832

833 834
exprMacros :: DynFlags -> UniqFM ([CmmExpr] -> CmmExpr)
exprMacros dflags = listToUFM [
835
  ( fsLit "ENTRY_CODE",   \ [x] -> entryCode dflags x ),
836
  ( fsLit "INFO_PTR",     \ [x] -> closureInfoPtr dflags x ),
837 838
  ( fsLit "STD_INFO",     \ [x] -> infoTable dflags x ),
  ( fsLit "FUN_INFO",     \ [x] -> funInfoTable dflags x ),
839 840 841
  ( fsLit "GET_ENTRY",    \ [x] -> entryCode dflags (closureInfoPtr dflags x) ),
  ( fsLit "GET_STD_INFO", \ [x] -> infoTable dflags (closureInfoPtr dflags x) ),
  ( fsLit "GET_FUN_INFO", \ [x] -> funInfoTable dflags (closureInfoPtr dflags x) ),
842 843 844
  ( fsLit "INFO_TYPE",    \ [x] -> infoTableClosureType dflags x ),
  ( fsLit "INFO_PTRS",    \ [x] -> infoTablePtrs dflags x ),
  ( fsLit "INFO_NPTRS",   \ [x] -> infoTableNonPtrs dflags x )
845 846 847 848
  ]

-- we understand a subset of C-- primitives:
machOps = listToUFM $
849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869
        map (\(x, y) -> (mkFastString x, y)) [
        ( "add",        MO_Add ),
        ( "sub",        MO_Sub ),
        ( "eq",         MO_Eq ),
        ( "ne",         MO_Ne ),
        ( "mul",        MO_Mul ),
        ( "neg",        MO_S_Neg ),
        ( "quot",       MO_S_Quot ),
        ( "rem",        MO_S_Rem ),
        ( "divu",       MO_U_Quot ),
        ( "modu",       MO_U_Rem ),

        ( "ge",         MO_S_Ge ),
        ( "le",         MO_S_Le ),
        ( "gt",         MO_S_Gt ),
        ( "lt",         MO_S_Lt ),

        ( "geu",        MO_U_Ge ),
        ( "leu",        MO_U_Le ),
        ( "gtu",        MO_U_Gt ),
        ( "ltu",        MO_U_Lt ),
870

871
        ( "and",        MO_And ),
872 873 874 875 876 877
        ( "or",         MO_Or ),
        ( "xor",        MO_Xor ),
        ( "com",        MO_Not ),
        ( "shl",        MO_Shl ),
        ( "shrl",       MO_U_Shr ),
        ( "shra",       MO_S_Shr ),
878

879 880 881 882 883 884 885 886 887 888 889 890 891 892
        ( "fadd",       MO_F_Add ),
        ( "fsub",       MO_F_Sub ),
        ( "fneg",       MO_F_Neg ),
        ( "fmul",       MO_F_Mul ),
        ( "fquot",      MO_F_Quot ),

        ( "feq",        MO_F_Eq ),
        ( "fne",        MO_F_Ne ),
        ( "fge",        MO_F_Ge ),
        ( "fle",        MO_F_Le ),
        ( "fgt",        MO_F_Gt ),
        ( "flt",        MO_F_Lt ),

        ( "lobits8",  flip MO_UU_Conv W8  ),
893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913
        ( "lobits16", flip MO_UU_Conv W16 ),
        ( "lobits32", flip MO_UU_Conv W32 ),
        ( "lobits64", flip MO_UU_Conv W64 ),

        ( "zx16",     flip MO_UU_Conv W16 ),
        ( "zx32",     flip MO_UU_Conv W32 ),
        ( "zx64",     flip MO_UU_Conv W64 ),

        ( "sx16",     flip MO_SS_Conv W16 ),
        ( "sx32",     flip MO_SS_Conv W32 ),
        ( "sx64",     flip MO_SS_Conv W64 ),

        ( "f2f32",    flip MO_FF_Conv W32 ),  -- TODO; rounding mode
        ( "f2f64",    flip MO_FF_Conv W64 ),  -- TODO; rounding mode
        ( "f2i8",     flip MO_FS_Conv W8 ),
        ( "f2i16",    flip MO_FS_Conv W16 ),
        ( "f2i32",    flip MO_FS_Conv W32 ),
        ( "f2i64",    flip MO_FS_Conv W64 ),
        ( "i2f32",    flip MO_SF_Conv W32 ),
        ( "i2f64",    flip MO_SF_Conv W64 )
        ]
914

915
callishMachOps = listToUFM $
916
        map (\(x, y) -> (mkFastString x, y)) [
917 918 919 920
        ( "write_barrier", MO_WriteBarrier ),
        ( "memcpy", MO_Memcpy ),
        ( "memset", MO_Memset ),
        ( "memmove", MO_Memmove )
921 922 923
        -- ToDo: the rest, maybe
    ]

924 925 926 927
parseSafety :: String -> P Safety
parseSafety "safe"   = return PlaySafe
parseSafety "unsafe" = return PlayRisky
parseSafety "interruptible" = return PlayInterruptible
928 929
parseSafety str      = fail ("unrecognised safety: " ++ str)

930 931 932 933
parseCmmHint :: String -> P ForeignHint
parseCmmHint "ptr"    = return AddrHint
parseCmmHint "signed" = return SignedHint
parseCmmHint str      = fail ("unrecognised hint: " ++ str)
934

935
-- labels are always pointers, so we might as well infer the hint
936 937 938 939 940
inferCmmHint :: CmmExpr -> ForeignHint
inferCmmHint (CmmLit (CmmLabel _)) = AddrHint
inferCmmHint (CmmReg (CmmGlobal g)) | isPtrGlobalReg g = AddrHint
inferCmmHint _ = NoHint

941 942 943 944
isPtrGlobalReg Sp                    = True
isPtrGlobalReg SpLim                 = True
isPtrGlobalReg Hp                    = True
isPtrGlobalReg HpLim                 = True
945 946 947
isPtrGlobalReg CCCS                  = True
isPtrGlobalReg CurrentTSO            = True
isPtrGlobalReg CurrentNursery        = True
948
isPtrGlobalReg (VanillaReg _ VGcPtr) = True
949
isPtrGlobalReg _                     = False
950 951 952 953 954 955 956

happyError :: P a
happyError = srcParseFail

-- -----------------------------------------------------------------------------
-- Statement-level macros

957
stmtMacro :: FastString -> [CmmParse CmmExpr] -> P (CmmParse ())
958 959 960 961
stmtMacro fun args_code = do
  case lookupUFM stmtMacros fun of
    Nothing -> fail ("unknown macro: " ++ unpackFS fun)
    Just fcode -> return $ do
962 963
        args <- sequence args_code
        code (fcode args)
964

965
stmtMacros :: UniqFM ([CmmExpr] -> FCode ())
966
stmtMacros = listToUFM [
967
  ( fsLit "CCS_ALLOC",             \[words,ccs]  -> profAlloc words ccs ),
968 969
  ( fsLit "ENTER_CCS_THUNK",       \[e] -> enterCostCentreThunk e ),

970 971
  ( fsLit "CLOSE_NURSERY",         \[]  -> emitCloseNursery ),
  ( fsLit "OPEN_NURSERY",          \[]  -> emitOpenNursery ),
972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992

  -- completely generic heap and stack checks, for use in high-level cmm.
  ( fsLit "HP_CHK_GEN",            \[bytes] ->
                                      heapStackCheckGen Nothing (Just bytes) ),
  ( fsLit "STK_CHK_GEN",           \[] ->
                                      heapStackCheckGen (Just (CmmLit CmmHighStackMark)) Nothing ),

  -- A stack check for a fixed amount of stack.  Sounds a bit strange, but
  -- we use the stack for a bit of temporary storage in a couple of primops
  ( fsLit "STK_CHK_GEN_N",         \[bytes] ->
                                      heapStackCheckGen (Just bytes) Nothing ),

  -- A stack check on entry to a thunk, where the argument is the thunk pointer.
  ( fsLit "STK_CHK_NP"   ,         \[node] -> entryHeapCheck' False node 0 [] (return ())),

  ( fsLit "LOAD_THREAD_STATE",     \[] -> emitLoadThreadState ),
  ( fsLit "SAVE_THREAD_STATE",     \[] -> emitSaveThreadState ),

  ( fsLit "LDV_ENTER",             \[e] -> ldvEnter e ),
  ( fsLit "LDV_RECORD_CREATE",     \[e] -> ldvRecordCreate e ),

993 994
  ( fsLit "PUSH_UPD_FRAME",        \[sp,e] -> emitPushUpdateFrame sp e ),
  ( fsLit "SET_HDR",               \[ptr,info,ccs] ->
Simon Marlow's avatar
untab  
Simon Marlow committed
995
                                        emitSetDynHdr ptr info ccs ),
996
  ( fsLit "TICK_ALLOC_PRIM",       \[hdr,goods,slop] ->
Simon Marlow's avatar
untab  
Simon Marlow committed
997
                                        tickyAllocPrim hdr goods slop ),
998
  ( fsLit "TICK_ALLOC_PAP",        \[goods,slop] ->
Simon Marlow's avatar
untab  
Simon Marlow committed
999
                                        tickyAllocPAP goods slop ),
1000
  ( fsLit "TICK_ALLOC_UP_THK",     \[goods,slop] ->
Simon Marlow's avatar
untab  
Simon Marlow committed
1001
                                        tickyAllocThunk goods slop ),
1002 1003
  ( fsLit "UPD_BH_UPDATABLE",      \[reg] -> emitBlackHoleCode False reg ),
  ( fsLit "UPD_BH_SINGLE_ENTRY",   \[reg] -> emitBlackHoleCode True  reg )
1004 1005
 ]

1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019
emitPushUpdateFrame :: CmmExpr -> CmmExpr -> FCode ()
emitPushUpdateFrame sp e = do
  dflags <- getDynFlags
  emitUpdateFrame dflags sp mkUpdInfoLabel e

pushStackFrame :: [CmmParse CmmExpr] -> CmmParse () -> CmmParse ()
pushStackFrame fields body = do
  dflags <- getDynFlags
  exprs <- sequence fields
  updfr_off <- getUpdFrameOff
  let (new_updfr_off, _, g) = copyOutOflow dflags NativeReturn Ret Old
                                           [] updfr_off exprs
  emit g
  withUpdFrameOff new_updfr_off body
1020

1021
profilingInfo dflags desc_str ty_str
ian@well-typed.com's avatar
ian@well-typed.com committed
1022
  = if not (gopt Opt_SccProfilingOn dflags)
1023 1024 1025
    then NoProfilingInfo
    else ProfilingInfo (stringToWord8s desc_str)
                       (stringToWord8s ty_str)
1026

1027
staticClosure :: PackageId -> FastString -> FastString -> [CmmLit] -> CmmParse ()
1028
staticClosure pkg cl_label info payload
1029 1030 1031
  = do dflags <- getDynFlags
       let lits = mkStaticClosure dflags (mkCmmInfoLabel pkg info) dontCareCCS payload [] [] []
       code $ emitDataLits (mkCmmDataLabel pkg cl_label) lits
1032 1033

foreignCall
1034
        :: String
1035
        -> [CmmParse (LocalReg, ForeignHint)]
Simon Marlow's avatar
untab  
Simon Marlow committed
1036
        -> CmmParse CmmExpr
1037 1038
        -> [CmmParse (CmmExpr, ForeignHint)]
        -> Safety
1039
        -> CmmReturnInfo
1040 1041 1042
        -> P (CmmParse ())
foreignCall conv_string results_code expr_code args_code safety ret
  = do  conv <- case conv_string of
1043
          "C" -> return CCallConv
1044
          "stdcall" -> return StdCallConv
1045
          _ -> fail ("unknown calling convention: " ++ conv_string)
1046
        return $ do
1047
          dflags <- getDynFlags
1048
          results <- sequence results_code
Simon Marlow's avatar
untab  
Simon Marlow committed
1049 1050
          expr <- expr_code
          args <- sequence args_code
1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096
          let
                  expr' = adjCallTarget dflags conv expr args
                  (arg_exprs, arg_hints) = unzip args
                  (res_regs,  res_hints) = unzip results
                  fc = ForeignConvention conv arg_hints res_hints ret
                  target = ForeignTarget expr' fc
          _ <- code $ emitForeignCall safety res_regs target arg_exprs
          return ()


doReturn :: [CmmParse CmmExpr] -> CmmParse ()
doReturn exprs_code = do
  dflags <- getDynFlags
  exprs <- sequence exprs_code
  updfr_off <- getUpdFrameOff
  emit (mkReturnSimple dflags exprs updfr_off)

doRawJump :: CmmParse CmmExpr -> [GlobalReg] -> CmmParse ()
doRawJump expr_code vols = do
  dflags <- getDynFlags
  expr <- expr_code
  updfr_off <- getUpdFrameOff
  emit (mkRawJump dflags expr updfr_off vols)

doJumpWithStack :: CmmParse CmmExpr -> [CmmParse CmmExpr]
                -> [CmmParse CmmExpr] -> CmmParse ()
doJumpWithStack expr_code stk_code args_code = do
  dflags <- getDynFlags
  expr <- expr_code
  stk_args <- sequence stk_code
  args <- sequence args_code
  updfr_off <- getUpdFrameOff
  emit (mkJumpExtra dflags expr args updfr_off stk_args)

doCall :: CmmParse CmmExpr -> [CmmParse LocalReg] -> [CmmParse CmmExpr]
       -> CmmParse ()
doCall expr_code res_code args_code = do
  dflags <- getDynFlags
  expr <- expr_code
  args <- sequence args_code
  ress <- sequence res_code
  updfr_off <- getUpdFrameOff
  c <- code $ mkCall expr (NativeNodeCall,NativeReturn) ress args updfr_off []
  emit c

adjCallTarget :: DynFlags -> CCallConv -> CmmExpr -> [(CmmExpr, ForeignHint) ]
1097
              -> CmmExpr
1098 1099
-- On Windows, we have to add the '@N' suffix to the label when making
-- a call with the stdcall calling convention.
1100 1101
adjCallTarget dflags StdCallConv (CmmLit (CmmLabel lbl)) args
 | platformOS (targetPlatform dflags) == OSMinGW32
1102
  = CmmLit (CmmLabel (addLabelSize lbl (sum (map size args))))
1103
  where size (e, _) = max (wORD_SIZE dflags) (widthInBytes (typeWidth (cmmExprType dflags e)))
1104
                 -- c.f. CgForeignCall.emitForeignCall
1105
adjCallTarget _ _ expr _
1106 1107
  = expr

1108
primCall
1109
        :: [CmmParse (CmmFormal, ForeignHint)]
Simon Marlow's avatar
untab  
Simon Marlow committed
1110
        -> FastString
1111 1112 1113
        -> [CmmParse CmmExpr]
        -> P (CmmParse ())
primCall results_code name args_code
1114
  = case lookupUFM callishMachOps name of
1115
        Nothing -> fail ("unknown primitive " ++ unpackFS name)
Simon Marlow's avatar
untab  
Simon Marlow committed
1116 1117 1118
        Just p  -> return $ do
                results <- sequence results_code
                args <- sequence args_code
1119 1120 1121
                code (emitPrimCall (map fst results) p args)

doStore :: CmmType -> CmmParse CmmExpr  -> CmmParse CmmExpr -> CmmParse ()
1122
doStore rep addr_code val_code
1123 1124
  = do dflags <- getDynFlags
       addr <- addr_code
1125
       val <- val_code
1126 1127 1128 1129 1130
        -- if the specified store type does not match the type of the expr
        -- on the rhs, then we insert a coercion that will cause the type
        -- mismatch to be flagged by cmm-lint.  If we don't do this, then
        -- the store will happen at the wrong type, and the error will not
        -- be noticed.
1131
       let val_width = typeWidth (cmmExprType dflags val)
1132
           rep_width = typeWidth rep
1133 1134 1135
       let coerce_val
                | val_width /= rep_width = CmmMachOp (MO_UU_Conv val_width rep_width) [val]
                | otherwise              = val
1136
       emitStore addr coerce_val
1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148

-- -----------------------------------------------------------------------------
-- If-then-else and boolean expressions

data BoolExpr
  = BoolExpr `BoolAnd` BoolExpr
  | BoolExpr `BoolOr`  BoolExpr
  | BoolNot BoolExpr
  | BoolTest CmmExpr

-- ToDo: smart constructors which simplify the boolean expression.

1149
cmmIfThenElse cond then_part else_part = do
1150 1151
     then_id <- newBlockId
     join_id <- newBlockId
1152 1153 1154
     c <- cond
     emitCond c then_id
     else_part
1155 1156
     emit (mkBranch join_id)
     emitLabel then_id
1157 1158
     then_part
     -- fall through to join
1159
     emitLabel join_id
1160

1161 1162 1163 1164
cmmRawIf cond then_id = do
    c <- cond
    emitCond c then_id

1165 1166 1167
-- 'emitCond cond true_id'  emits code to test whether the cond is true,
-- branching to true_id if so, and falling through otherwise.
emitCond (BoolTest e) then_id = do
1168 1169 1170
  else_id <- newBlockId
  emit (mkCbranch e then_id else_id)
  emitLabel else_id
1171 1172 1173 1174
emitCond (BoolNot (BoolTest (CmmMachOp op args))) then_id
  | Just op' <- maybeInvertComparison op
  = emitCond (BoolTest (CmmMachOp op' args)) then_id
emitCond (BoolNot e) then_id = do
1175
  else_id <- newBlockId
1176
  emitCond e else_id
1177 1178
  emit (mkBranch then_id)
  emitLabel else_id
1179 1180 1181 1182
emitCond (e1 `BoolOr` e2) then_id = do
  emitCond e1 then_id
  emitCond e2 then_id
emitCond (e1 `BoolAnd` e2) then_id = do
1183
        -- we'd like to invert one of the conditionals here to avoid an
Simon Marlow's avatar
untab  
Simon Marlow committed
1184 1185 1186
        -- extra branch instruction, but we can't use maybeInvertComparison
        -- here because we can't look too closely at the expression since
        -- we're in a loop.
1187 1188
  and_id <- newBlockId
  else_id <- newBlockId
1189
  emitCond e1 and_id
1190 1191
  emit (mkBranch else_id)
  emitLabel and_id
1192
  emitCond e2 then_id
1193
  emitLabel else_id
1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205


-- -----------------------------------------------------------------------------
-- Table jumps

-- We use a simplified form of C-- switch statements for now.  A
-- switch statement always compiles to a table jump.  Each arm can
-- specify a list of values (not ranges), and there can be a single
-- default branch.  The range of the table is given either by the
-- optional range on the switch (eg. switch [0..7] {...}), or by
-- the minimum/maximum values from the branches.

1206 1207
doSwitch :: Maybe (Int,Int) -> CmmParse CmmExpr -> [([Int],Either BlockId (CmmParse ()))]
         -> Maybe (CmmParse ()) -> CmmParse ()
1208
doSwitch mb_range scrut arms deflt
1209
   = do
Simon Marlow's avatar
untab  
Simon Marlow committed
1210 1211 1212 1213
        -- Compile code for the default branch
        dflt_entry <- 
                case deflt of
                  Nothing -> return Nothing
1214 1215
                  Just e  -> do b <- forkLabelledCode e; return (Just b)

Simon Marlow's avatar
untab  
Simon Marlow committed
1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230
        -- Compile each case branch
        table_entries <- mapM emitArm arms

        -- Construct the table
        let
            all_entries = concat table_entries
            ixs = map fst all_entries
            (min,max) 
                | Just (l,u) <- mb_range = (l,u)
                | otherwise              = (minimum ixs, maximum ixs)

            entries = elems (accumArray (\_ a -> Just a) dflt_entry (min,max)
                                all_entries)
        expr <- scrut
        -- ToDo: check for out of range and jump to default if necessary
1231
        emit (mkSwitch expr entries)
1232
   where
1233
        emitArm :: ([Int],Either BlockId (CmmParse ())) -> CmmParse [(Int,BlockId)]
Simon Marlow's avatar
untab  
Simon Marlow committed
1234 1235
        emitArm (ints,Left blockid) = return [ (i,blockid) | i <- ints ]
        emitArm (ints,Right code) = do
1236
           blockid <- forkLabelledCode code
Simon Marlow's avatar
untab  
Simon Marlow committed
1237
           return [ (i,blockid) | i <- ints ]
1238 1239 1240 1241 1242 1243