CmmParse.y 37 KB
Newer Older
1 2
-----------------------------------------------------------------------------
--
Simon Marlow's avatar
Simon Marlow committed
3
-- (c) The University of Glasgow, 2004-2006
4 5
--
-- Parser for concrete Cmm.
6 7
-- This doesn't just parse the Cmm file, we also do some code generation
-- along the way for switches and foreign calls etc.
8 9 10
--
-----------------------------------------------------------------------------

11 12
-- TODO: Add support for interruptible/uninterruptible foreign call specification

13
{
14
{-# LANGUAGE BangPatterns #-} -- required for versions of Happy before 1.18.6
15
{-# OPTIONS -Wwarn -w #-}
16 17 18
-- 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
19
--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
20 21
-- for details

22 23
module CmmParse ( parseCmmFile ) where

24
import CgMonad
25
import CgExtCode
26 27 28 29 30 31
import CgHeapery
import CgUtils
import CgProf
import CgTicky
import CgInfoTbls
import CgForeignCall
Simon Marlow's avatar
Simon Marlow committed
32 33 34 35 36 37
import CgTailCall
import CgStackery
import ClosureInfo
import CgCallConv
import CgClosure
import CostCentre
38

39
import BlockId
40 41
import OldCmm
import OldPprCmm()
Simon Marlow's avatar
Simon Marlow committed
42
import CmmUtils
43 44
import CmmLex
import CLabel
Simon Marlow's avatar
Simon Marlow committed
45
import SMRep
46 47
import Lexer

Simon Marlow's avatar
Simon Marlow committed
48
import ForeignCall
49
import Module
Simon Marlow's avatar
Simon Marlow committed
50
import Literal
51 52 53
import Unique
import UniqFM
import SrcLoc
Simon Marlow's avatar
Simon Marlow committed
54 55 56 57
import DynFlags
import StaticFlags
import ErrUtils
import StringBuffer
58
import FastString
Simon Marlow's avatar
Simon Marlow committed
59 60
import Panic
import Constants
61
import Outputable
62
import BasicTypes
63
import Bag              ( emptyBag, unitBag )
64
import Var
65

66
import Control.Monad
67
import Data.Array
68
import Data.Char	( ord )
69
import System.Exit
70 71

#include "HsVersions.h"
72 73
}

74 75
%expect 0

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
%token
	':'	{ 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) }
        '&&'    { L _ (CmmT_BoolAnd) }
        '||'    { L _ (CmmT_BoolOr) }

	'CLOSURE'	{ L _ (CmmT_CLOSURE) }
	'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) }
	'jump'		{ L _ (CmmT_jump) }
	'foreign'	{ L _ (CmmT_foreign) }
126
	'never'		{ L _ (CmmT_never) }
127
	'prim'		{ L _ (CmmT_prim) }
128
	'return'	{ L _ (CmmT_return) }
129
	'returns'	{ L _ (CmmT_returns) }
130 131 132 133 134 135 136 137 138 139
	'import'	{ L _ (CmmT_import) }
	'switch'	{ L _ (CmmT_switch) }
	'case'		{ L _ (CmmT_case) }
	'default'	{ L _ (CmmT_default) }
	'bits8'		{ L _ (CmmT_bits8) }
	'bits16'	{ L _ (CmmT_bits16) }
	'bits32'	{ L _ (CmmT_bits32) }
	'bits64'	{ L _ (CmmT_bits64) }
	'float32'	{ L _ (CmmT_float32) }
	'float64'	{ L _ (CmmT_float64) }
140
	'gcptr'	        { L _ (CmmT_gcptr) }
141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176

	GLOBALREG	{ L _ (CmmT_GlobalReg   $$) }
  	NAME		{ L _ (CmmT_Name	$$) }
	STRING		{ L _ (CmmT_String	$$) }
	INT		{ L _ (CmmT_Int		$$) }
	FLOAT		{ L _ (CmmT_Float	$$) }

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

-- C-- operator precedences, taken from the C-- spec
%right '||'	-- non-std extension, called %disjoin in C--
%right '&&'	-- non-std extension, called %conjoin in C--
%right '!'
%nonassoc '>=' '>' '<=' '<' '!=' '=='
%left '|'
%left '^'
%left '&'
%left '>>' '<<'
%left '-' '+'
%left '/' '*' '%'
%right '~'

%%

cmm	:: { ExtCode }
	: {- empty -}			{ return () }
	| cmmtop cmm			{ do $1; $2 }

cmmtop	:: { ExtCode }
	: cmmproc			{ $1 }
	| cmmdata			{ $1 }
	| decl				{ $1 } 
	| 'CLOSURE' '(' NAME ',' NAME lits ')' ';'  
177 178 179
		{% withThisPackage $ \pkg -> 
		   do lits <- sequence $6;
		      staticClosure pkg $3 $5 (map getLit lits) }
180 181 182 183 184 185 186 187 188 189 190

-- 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:
-- 	* 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

cmmdata :: { ExtCode }
191
	: 'section' STRING '{' data_label statics '}' 
192 193
		{ do lbl <- $4;
		     ss <- sequence $5;
194
		     code (emitDecl (CmmData (section $2) (Statics lbl $ concat ss))) }
195

196
data_label :: { ExtFCode CLabel }
197 198 199
    : NAME ':'	
		{% withThisPackage $ \pkg -> 
		   return (mkCmmDataLabel pkg $1) }
200 201 202 203

statics	:: { [ExtFCode [CmmStatic]] }
	: {- empty -}			{ [] }
	| static statics		{ $1 : $2 }
204
    
205 206 207
-- 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.
static 	:: { ExtFCode [CmmStatic] }
208
	: type expr ';'	{ do e <- $2;
209 210
			     return [CmmStaticLit (getLit e)] }
	| type ';'			{ return [CmmUninitialised
211
							(widthInBytes (typeWidth $1))] }
212
        | 'bits8' '[' ']' STRING ';'	{ return [mkString $4] }
213 214 215
        | 'bits8' '[' INT ']' ';'	{ return [CmmUninitialised 
							(fromIntegral $3)] }
        | typenot8 '[' INT ']' ';'	{ return [CmmUninitialised 
216
						(widthInBytes (typeWidth $1) * 
217 218
							fromIntegral $3)] }
	| 'CLOSURE' '(' NAME lits ')'
219 220 221 222
		{ do { lits <- sequence $4
             ; dflags <- getDynFlags
		     ; return $ map CmmStaticLit $
                        mkStaticClosure dflags (mkForeignLabel $3 Nothing ForeignLabelInExternalPackage IsData)
223 224
                         -- mkForeignLabel because these are only used
                         -- for CHARLIKE and INTLIKE closures in the RTS.
225
                        dontCareCCS (map getLit lits) [] [] [] } }
226 227 228 229 230 231 232
	-- arrays of closures required for the CHARLIKE & INTLIKE arrays

lits	:: { [ExtFCode CmmExpr] }
	: {- empty -}		{ [] }
	| ',' expr lits		{ $2 : $3 }

cmmproc :: { ExtCode }
233
-- TODO: add real SRT/info tables to parsed Cmm
Simon Marlow's avatar
Simon Marlow committed
234 235
        : info maybe_formals_without_hints '{' body '}'
                { do ((entry_ret_label, info, live, formals), stmts) <-
236
		       getCgStmtsEC' $ loopDecls $ do {
237
		         (entry_ret_label, info, live) <- $1;
238
		         formals <- sequence $2;
Simon Marlow's avatar
Simon Marlow committed
239 240
                         $4;
                         return (entry_ret_label, info, live, formals) }
241
		     blks <- code (cgStmtsToBlocks stmts)
Simon Marlow's avatar
Simon Marlow committed
242
                     code (emitInfoTableAndCode entry_ret_label info formals blks) }
243

244
	| info maybe_formals_without_hints ';'
245
		{ do (entry_ret_label, info, live) <- $1;
246
		     formals <- sequence $2;
Simon Marlow's avatar
Simon Marlow committed
247
                     code (emitInfoTableAndCode entry_ret_label info formals []) }
248

Simon Marlow's avatar
Simon Marlow committed
249
        | NAME maybe_formals_without_hints '{' body '}'
250 251
		{% withThisPackage $ \pkg ->
		   do	newFunctionName $1 pkg
Simon Marlow's avatar
Simon Marlow committed
252
                        (formals, stmts) <-
253 254
			 	getCgStmtsEC' $ loopDecls $ do {
		          		formals <- sequence $2;
Simon Marlow's avatar
Simon Marlow committed
255 256
                                        $4;
                                        return formals }
257
			blks <- code (cgStmtsToBlocks stmts)
258
                        code (emitProc Nothing (mkCmmCodeLabel pkg $1) formals blks) }
259

260
info	:: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) }
261 262
	: 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
		-- ptrs, nptrs, closure type, description, type
263
		{% withThisPackage $ \pkg ->
264 265
                   do dflags <- getDynFlags
                      let prof = profilingInfo dflags $11 $13
266
                          rep  = mkRTSRep (fromIntegral $9) $
267
                                   mkHeapRep dflags False (fromIntegral $5)
268 269 270 271
                                                   (fromIntegral $7) Thunk
                              -- not really Thunk, but that makes the info table
                              -- we want.
                      return (mkCmmEntryLabel pkg $3,
272 273 274 275
			      CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
				           , cit_rep = rep
               				   , cit_prof = prof, cit_srt = NoC_SRT },
			      []) }
276 277 278
	
	| 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ')'
		-- ptrs, nptrs, closure type, description, type, fun type
279
		{% withThisPackage $ \pkg -> 
280 281
                   do dflags <- getDynFlags
                      let prof = profilingInfo dflags $11 $13
282 283 284
                          ty   = Fun 0 (ArgSpec (fromIntegral $15))
                                -- Arity zero, arg_type $15
                          rep = mkRTSRep (fromIntegral $9) $
285
                                    mkHeapRep dflags False (fromIntegral $5)
286 287
                                                    (fromIntegral $7) ty
                      return (mkCmmEntryLabel pkg $3,
288 289 290 291
			      CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
				           , cit_rep = rep
               				   , cit_prof = prof, cit_srt = NoC_SRT },
			      []) }
292 293
		-- we leave most of the fields zero here.  This is only used
		-- to generate the BCO info table in the RTS at the moment.
294

295
        | 'INFO_TABLE_CONSTR' '(' NAME ',' INT ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
296
		-- ptrs, nptrs, tag, closure type, description, type
297
		{% withThisPackage $ \pkg ->
298 299
                   do dflags <- getDynFlags
                      let prof = profilingInfo dflags $13 $15
300
                          ty  = Constr (fromIntegral $9)  -- Tag
301
	                           	(stringToWord8s $13)
302
                          rep = mkRTSRep (fromIntegral $11) $
303
                                  mkHeapRep dflags False (fromIntegral $5)
304 305
                                                  (fromIntegral $7) ty
                      return (mkCmmEntryLabel pkg $3,
306 307 308 309 310
			      CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
				           , cit_rep = rep
               				   , cit_prof = prof, cit_srt = NoC_SRT },
			      []) }

311 312
		     -- 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.
313 314 315
	
	| 'INFO_TABLE_SELECTOR' '(' NAME ',' INT ',' INT ',' STRING ',' STRING ')'
		-- selector, closure type, description, type
316
		{% withThisPackage $ \pkg ->
317 318
                   do dflags <- getDynFlags
                      let prof = profilingInfo dflags $9 $11
319
                          ty  = ThunkSelector (fromIntegral $5)
320
                          rep = mkRTSRep (fromIntegral $7) $
321
                                   mkHeapRep dflags False 0 0 ty
322
                      return (mkCmmEntryLabel pkg $3,
323 324 325 326
			      CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
				           , cit_rep = rep
               				   , cit_prof = prof, cit_srt = NoC_SRT },
			      []) }
327 328 329

	| 'INFO_TABLE_RET' '(' NAME ',' INT ')'
		-- closure type (no live regs)
330
		{% withThisPackage $ \pkg ->
331
		   do let prof = NoProfilingInfo
332 333
                          rep  = mkRTSRep (fromIntegral $5) $ mkStackRep []
                      return (mkCmmRetLabel pkg $3,
334 335 336 337
			      CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
				           , cit_rep = rep
               				   , cit_prof = prof, cit_srt = NoC_SRT },
			      []) }
338

339
	| 'INFO_TABLE_RET' '(' NAME ',' INT ',' formals_without_hints0 ')'
340
		-- closure type, live regs
341 342
		{% withThisPackage $ \pkg ->
		   do live <- sequence (map (liftM Just) $7)
343
		      let prof = NoProfilingInfo
344 345 346
                          bitmap = mkLiveness live
                          rep  = mkRTSRep (fromIntegral $5) $ mkStackRep bitmap
                      return (mkCmmRetLabel pkg $3,
347 348 349 350
			      CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
				           , cit_rep = rep
               				   , cit_prof = prof, cit_srt = NoC_SRT },
			      []) }
351 352 353 354 355 356 357

body	:: { ExtCode }
	: {- empty -}			{ return () }
	| decl body			{ do $1; $2 }
	| stmt body			{ do $1; $2 }

decl	:: { ExtCode }
358
	: type names ';'		{ mapM_ (newLocal $1) $2 }
359
	| 'import' importNames ';'	{ mapM_ newImport $2 }
360 361
	| 'export' names ';'		{ return () }  -- ignore exports

362 363 364

-- an imported function name, with optional packageId
importNames  
365
	:: { [(FastString, CLabel)] }
366 367 368 369
	: importName			{ [$1] }
	| importName ',' importNames	{ $1 : $3 }		
	
importName
370 371 372 373 374 375 376 377 378 379
	:: { (FastString,  CLabel) }

	-- 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) }
380 381
	
	
382
names 	:: { [FastString] }
383 384
	: NAME				{ [$1] }
	| NAME ',' names		{ $1 : $3 }
385 386 387 388

stmt	:: { ExtCode }
	: ';'					{ nopEC }

389 390
	| NAME ':'
		{ do l <- newLabel $1; code (labelC l) }
391

392 393
	| lreg '=' expr ';'
		{ do reg <- $1; e <- $3; stmtEC (CmmAssign reg e) }
394 395
	| type '[' expr ']' '=' expr ';'
		{ doStore $1 $3 $6 }
396 397 398 399 400 401 402

	-- Gah! We really want to say "maybe_results" but that causes
	-- 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.
403
	| maybe_results 'foreign' STRING expr '(' cmm_hint_exprs0 ')' safety vols opt_never_returns ';'
404
		{% foreignCall $3 $1 $4 $6 $9 $8 $10 }
405
	| maybe_results 'prim' '%' NAME '(' cmm_hint_exprs0 ')' safety vols ';'
406
		{% primCall $1 $4 $6 $9 $8 }
407 408 409 410 411
	-- 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 '}'
412
		{ do as <- sequence $5; doSwitch $2 $3 as $6 }
413 414
	| 'goto' NAME ';'
		{ do l <- lookupLabel $2; stmtEC (CmmBranch l) }
415 416
	| 'jump' expr vols ';'
		{ do e <- $2; stmtEC (CmmJump e $3) }
417 418
        | 'return' ';'
		{ stmtEC CmmReturn }
419 420
	| 'if' bool_expr 'goto' NAME
		{ do l <- lookupLabel $4; cmmRawIf $2 l }
421
	| 'if' bool_expr '{' body '}' else 	
422
		{ cmmIfThenElse $2 $4 $6 }
423

424 425 426
opt_never_returns :: { CmmReturnInfo }
        :                               { CmmMayReturn }
        | 'never' 'returns'             { CmmNeverReturns }
427

428 429 430 431 432 433 434 435 436 437 438 439
bool_expr :: { ExtFCode BoolExpr }
	: bool_op			{ $1 }
	| expr				{ do e <- $1; return (BoolTest e) }

bool_op :: { ExtFCode BoolExpr }
	: 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 }

440 441 442 443 444
-- This is not C-- syntax.  What to do?
safety  :: { CmmSafety }
	: {- empty -}			{ CmmUnsafe } -- Default may change soon
	| STRING			{% parseSafety $1 }

445 446 447
-- This is not C-- syntax.  What to do?
vols 	:: { Maybe [GlobalReg] }
	: {- empty -}			{ Nothing }
448
	| '[' ']'		        { Just [] }
449 450 451 452 453 454 455 456 457 458
	| '[' globals ']'		{ Just $2 }

globals :: { [GlobalReg] }
	: GLOBALREG			{ [$1] }
	| GLOBALREG ',' globals		{ $1 : $3 }

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

459
arms	:: { [ExtFCode ([Int],Either BlockId ExtCode)] }
460 461 462
	: {- empty -}			{ [] }
	| arm arms			{ $1 : $2 }

463 464 465 466 467 468
arm	:: { ExtFCode ([Int],Either BlockId ExtCode) }
	: 'case' ints ':' arm_body	{ do b <- $4; return ($2, b) }

arm_body :: { ExtFCode (Either BlockId ExtCode) }
	: '{' body '}'			{ return (Right $2) }
	| 'goto' NAME ';'		{ do l <- lookupLabel $2; return (Left l) }
469 470 471 472 473 474 475 476 477 478 479

ints	:: { [Int] }
	: INT				{ [ fromIntegral $1 ] }
	| INT ',' ints			{ fromIntegral $1 : $3 }

default :: { Maybe ExtCode }
	: 'default' ':' '{' body '}'	{ Just $4 }
	-- taking a few liberties with the C-- syntax here; C-- doesn't have
	-- 'default' branches
	| {- empty -}			{ Nothing }

480 481
-- Note: OldCmm doesn't support a first class 'else' statement, though
-- CmmNode does.
482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511
else 	:: { ExtCode }
	: {- empty -}			{ nopEC }
	| 'else' '{' body '}'		{ $3 }

-- we have to write this out longhand so that Happy's precedence rules
-- can kick in.
expr	:: { ExtFCode CmmExpr } 
	: 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	:: { ExtFCode CmmExpr }
512 513
	: INT   maybe_ty	 { return (CmmLit (CmmInt $1 (typeWidth $2))) }
	| FLOAT maybe_ty	 { return (CmmLit (CmmFloat $1 (typeWidth $2))) }
514
	| STRING		 { do s <- code (newStringCLit $1); 
515 516 517 518 519 520 521 522
				      return (CmmLit s) }
	| reg			 { $1 }
	| type '[' expr ']'	 { do e <- $3; return (CmmLoad e $1) }
	| '%' NAME '(' exprs0 ')' {% exprOp $2 $4 }
	| '(' expr ')'		 { $2 }


-- leaving out the type of a literal gives you the native word size in C--
523 524
maybe_ty :: { CmmType }
	: {- empty -}			{ bWord }
525 526
	| '::' type			{ $2 }

527
maybe_actuals :: { [ExtFCode HintedCmmActual] }
528
	: {- empty -}		{ [] }
529
	| '(' cmm_hint_exprs0 ')'	{ $2 }
530

531
cmm_hint_exprs0 :: { [ExtFCode HintedCmmActual] }
532
	: {- empty -}			{ [] }
533
	| cmm_hint_exprs			{ $1 }
534

535 536 537
cmm_hint_exprs :: { [ExtFCode HintedCmmActual] }
	: cmm_hint_expr			{ [$1] }
	| cmm_hint_expr ',' cmm_hint_exprs	{ $1 : $3 }
538

539 540 541
cmm_hint_expr :: { ExtFCode HintedCmmActual }
	: expr				{ do e <- $1; return (CmmHinted e (inferCmmHint e)) }
	| expr STRING			{% do h <- parseCmmHint $2;
542
					      return $ do
543
						e <- $1; return (CmmHinted e h) }
544 545 546 547 548 549 550 551 552 553 554 555 556

exprs0  :: { [ExtFCode CmmExpr] }
	: {- empty -}			{ [] }
	| exprs				{ $1 }

exprs	:: { [ExtFCode CmmExpr] }
	: expr				{ [ $1 ] }
	| expr ',' exprs		{ $1 : $3 }

reg	:: { ExtFCode CmmExpr }
	: NAME			{ lookupName $1 }
	| GLOBALREG		{ return (CmmReg (CmmGlobal $1)) }

557
maybe_results :: { [ExtFCode HintedCmmFormal] }
558
	: {- empty -}		{ [] }
559
	| '(' cmm_formals ')' '='	{ $2 }
560

561
cmm_formals :: { [ExtFCode HintedCmmFormal] }
562 563 564
	: cmm_formal			{ [$1] }
	| cmm_formal ','			{ [$1] }
	| cmm_formal ',' cmm_formals	{ $1 : $3 }
565

566 567 568
cmm_formal :: { ExtFCode HintedCmmFormal }
	: local_lreg			{ do e <- $1; return (CmmHinted e (inferCmmHint (CmmReg (CmmLocal e)))) }
	| STRING local_lreg		{% do h <- parseCmmHint $1;
569
					      return $ do
570
						e <- $2; return (CmmHinted e h) }
571

572 573 574 575 576 577 578
local_lreg :: { ExtFCode LocalReg }
	: NAME			{ do e <- lookupName $1;
				     return $
				       case e of 
					CmmReg (CmmLocal r) -> r
					other -> pprPanic "CmmParse:" (ftext $1 <> text " not a local register") }

579 580 581 582 583 584 585 586
lreg	:: { ExtFCode 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) }

587
maybe_formals_without_hints :: { [ExtFCode LocalReg] }
588
	: {- empty -}		{ [] }
589
	| '(' formals_without_hints0 ')'	{ $2 }
590

591
formals_without_hints0 :: { [ExtFCode LocalReg] }
592
	: {- empty -}		{ [] }
593
	| formals_without_hints		{ $1 }
594

595 596 597 598
formals_without_hints :: { [ExtFCode LocalReg] }
	: formal_without_hint ','		{ [$1] }
	| formal_without_hint		{ [$1] }
	| formal_without_hint ',' formals_without_hints	{ $1 : $3 }
599

600 601
formal_without_hint :: { ExtFCode LocalReg }
	: type NAME		{ newLocal $1 $2 }
602

Simon Marlow's avatar
Simon Marlow committed
603
type    :: { CmmType }
604
	: 'bits8'		{ b8 }
605 606
	| typenot8		{ $1 }

607 608 609 610 611 612 613
typenot8 :: { CmmType }
	: 'bits16'		{ b16 }
	| 'bits32'		{ b32 }
	| 'bits64'		{ b64 }
	| 'float32'		{ f32 }
	| 'float64'		{ f64 }
	| 'gcptr'		{ gcWord }
614 615 616 617 618
{
section :: String -> Section
section "text"	 = Text
section "data" 	 = Data
section "rodata" = ReadOnlyData
619
section "relrodata" = RelocatableReadOnlyData
620 621 622
section "bss"	 = UninitialisedData
section s	 = OtherSection s

623 624 625
mkString :: String -> CmmStatic
mkString s = CmmString (map (fromIntegral.ord) s)

626 627 628 629
-- 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.
630
mkMachOp :: (Width -> MachOp) -> [ExtFCode CmmExpr] -> ExtFCode CmmExpr
631 632
mkMachOp fn args = do
  arg_exprs <- sequence args
633
  return (CmmMachOp (fn (typeWidth (cmmExprType (head arg_exprs)))) arg_exprs)
634 635 636 637 638 639

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

640
nameToMachOp :: FastString -> P (Width -> MachOp)
641 642 643 644 645 646
nameToMachOp name = 
  case lookupUFM machOps name of
	Nothing -> fail ("unknown primitive " ++ unpackFS name)
	Just m  -> return m

exprOp :: FastString -> [ExtFCode CmmExpr] -> P (ExtFCode CmmExpr)
647 648 649
exprOp name args_code = do
  dflags <- getDynFlags
  case lookupUFM (exprMacros dflags) name of
650 651 652 653 654 655 656
     Just f  -> return $ do
        args <- sequence args_code
	return (f args)
     Nothing -> do
	mo <- nameToMachOp name
	return $ mkMachOp mo args_code

657 658
exprMacros :: DynFlags -> UniqFM ([CmmExpr] -> CmmExpr)
exprMacros dflags = listToUFM [
Ian Lynagh's avatar
Ian Lynagh committed
659 660
  ( fsLit "ENTRY_CODE",   \ [x] -> entryCode x ),
  ( fsLit "INFO_PTR",     \ [x] -> closureInfoPtr x ),
661 662
  ( fsLit "STD_INFO",     \ [x] -> infoTable dflags x ),
  ( fsLit "FUN_INFO",     \ [x] -> funInfoTable dflags x ),
Ian Lynagh's avatar
Ian Lynagh committed
663
  ( fsLit "GET_ENTRY",    \ [x] -> entryCode (closureInfoPtr x) ),
664 665 666 667 668
  ( fsLit "GET_STD_INFO", \ [x] -> infoTable dflags (closureInfoPtr x) ),
  ( fsLit "GET_FUN_INFO", \ [x] -> funInfoTable dflags (closureInfoPtr x) ),
  ( fsLit "INFO_TYPE",    \ [x] -> infoTableClosureType dflags x ),
  ( fsLit "INFO_PTRS",    \ [x] -> infoTablePtrs dflags x ),
  ( fsLit "INFO_NPTRS",   \ [x] -> infoTableNonPtrs dflags x )
669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694
  ]

-- we understand a subset of C-- primitives:
machOps = listToUFM $
	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 ),

695
        ( "and",        MO_And ),
696 697 698 699 700 701 702
	( "or",		MO_Or ),
	( "xor",	MO_Xor ),
	( "com",	MO_Not ),
	( "shl",	MO_Shl ),
	( "shrl",	MO_U_Shr ),
	( "shra",	MO_S_Shr ),

703 704 705 706 707 708 709 710 711 712 713 714 715 716
        ( "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  ),
717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736
	( "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 )
737 738
	]

739 740
callishMachOps = listToUFM $
	map (\(x, y) -> (mkFastString x, y)) [
741 742 743 744
        ( "write_barrier", MO_WriteBarrier ),
        ( "memcpy", MO_Memcpy ),
        ( "memset", MO_Memset ),
        ( "memmove", MO_Memmove )
745 746 747
        -- ToDo: the rest, maybe
    ]

748 749 750
parseSafety :: String -> P CmmSafety
parseSafety "safe"   = return (CmmSafe NoC_SRT)
parseSafety "unsafe" = return CmmUnsafe
751
parseSafety "interruptible" = return CmmInterruptible
752 753
parseSafety str      = fail ("unrecognised safety: " ++ str)

754 755 756 757
parseCmmHint :: String -> P ForeignHint
parseCmmHint "ptr"    = return AddrHint
parseCmmHint "signed" = return SignedHint
parseCmmHint str      = fail ("unrecognised hint: " ++ str)
758

759
-- labels are always pointers, so we might as well infer the hint
760 761 762 763 764 765 766 767 768
inferCmmHint :: CmmExpr -> ForeignHint
inferCmmHint (CmmLit (CmmLabel _)) = AddrHint
inferCmmHint (CmmReg (CmmGlobal g)) | isPtrGlobalReg g = AddrHint
inferCmmHint _ = NoHint

isPtrGlobalReg Sp		     = True
isPtrGlobalReg SpLim		     = True
isPtrGlobalReg Hp		     = True
isPtrGlobalReg HpLim		     = True
769 770 771
isPtrGlobalReg CCCS                  = True
isPtrGlobalReg CurrentTSO            = True
isPtrGlobalReg CurrentNursery        = True
772 773
isPtrGlobalReg (VanillaReg _ VGcPtr) = True
isPtrGlobalReg _		     = False
774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790

happyError :: P a
happyError = srcParseFail

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

stmtMacro :: FastString -> [ExtFCode CmmExpr] -> P ExtCode
stmtMacro fun args_code = do
  case lookupUFM stmtMacros fun of
    Nothing -> fail ("unknown macro: " ++ unpackFS fun)
    Just fcode -> return $ do
	args <- sequence args_code
	code (fcode args)

stmtMacros :: UniqFM ([CmmExpr] -> Code)
stmtMacros = listToUFM [
Ian Lynagh's avatar
Ian Lynagh committed
791 792 793 794
  ( fsLit "CCS_ALLOC",		   \[words,ccs]  -> profAlloc words ccs ),
  ( fsLit "CLOSE_NURSERY",	   \[]  -> emitCloseNursery ),
  ( fsLit "ENTER_CCS_THUNK",      \[e] -> enterCostCentreThunk e ),
  ( fsLit "HP_CHK_GEN",           \[words,liveness,reentry] -> 
795
                                      hpChkGen words liveness reentry ),
Ian Lynagh's avatar
Ian Lynagh committed
796 797 798 799 800 801 802 803
  ( fsLit "HP_CHK_NP_ASSIGN_SP0", \[e,f] -> hpChkNodePointsAssignSp0 e f ),
  ( fsLit "LOAD_THREAD_STATE",    \[] -> emitLoadThreadState ),
  ( fsLit "LDV_ENTER",            \[e] -> ldvEnter e ),
  ( fsLit "LDV_RECORD_CREATE",    \[e] -> ldvRecordCreate e ),
  ( fsLit "OPEN_NURSERY",	   \[]  -> emitOpenNursery ),
  ( fsLit "PUSH_UPD_FRAME",	   \[sp,e] -> emitPushUpdateFrame sp e ),
  ( fsLit "SAVE_THREAD_STATE",    \[] -> emitSaveThreadState ),
  ( fsLit "SET_HDR",		   \[ptr,info,ccs] -> 
804
					emitSetDynHdr ptr info ccs ),
Ian Lynagh's avatar
Ian Lynagh committed
805
  ( fsLit "STK_CHK_GEN",          \[words,liveness,reentry] -> 
806
                                      stkChkGen words liveness reentry ),
Ian Lynagh's avatar
Ian Lynagh committed
807 808
  ( fsLit "STK_CHK_NP",	   \[e] -> stkChkNodePoints e ),
  ( fsLit "TICK_ALLOC_PRIM", 	   \[hdr,goods,slop] -> 
809
					tickyAllocPrim hdr goods slop ),
Ian Lynagh's avatar
Ian Lynagh committed
810
  ( fsLit "TICK_ALLOC_PAP",       \[goods,slop] -> 
811
					tickyAllocPAP goods slop ),
Ian Lynagh's avatar
Ian Lynagh committed
812
  ( fsLit "TICK_ALLOC_UP_THK",    \[goods,slop] -> 
813
					tickyAllocThunk goods slop ),
Ian Lynagh's avatar
Ian Lynagh committed
814 815 816 817 818 819 820 821 822 823 824 825
  ( fsLit "UPD_BH_UPDATABLE",       \[] -> emitBlackHoleCode False ),
  ( fsLit "UPD_BH_SINGLE_ENTRY",    \[] -> emitBlackHoleCode True ),

  ( fsLit "RET_P",	\[a] ->       emitRetUT [(PtrArg,a)]),
  ( fsLit "RET_N",	\[a] ->       emitRetUT [(NonPtrArg,a)]),
  ( fsLit "RET_PP",	\[a,b] ->     emitRetUT [(PtrArg,a),(PtrArg,b)]),
  ( fsLit "RET_NN",	\[a,b] ->     emitRetUT [(NonPtrArg,a),(NonPtrArg,b)]),
  ( fsLit "RET_NP",	\[a,b] ->     emitRetUT [(NonPtrArg,a),(PtrArg,b)]),
  ( fsLit "RET_PPP",	\[a,b,c] ->   emitRetUT [(PtrArg,a),(PtrArg,b),(PtrArg,c)]),
  ( fsLit "RET_NPP",	\[a,b,c] ->   emitRetUT [(NonPtrArg,a),(PtrArg,b),(PtrArg,c)]),
  ( fsLit "RET_NNP",	\[a,b,c] ->   emitRetUT [(NonPtrArg,a),(NonPtrArg,b),(PtrArg,c)]),
  ( fsLit "RET_NNN",  \[a,b,c] -> emitRetUT [(NonPtrArg,a),(NonPtrArg,b),(NonPtrArg,c)]),
826
  ( fsLit "RET_NNNN",  \[a,b,c,d] -> emitRetUT [(NonPtrArg,a),(NonPtrArg,b),(NonPtrArg,c),(NonPtrArg,d)]),
Ian Lynagh's avatar
Ian Lynagh committed
827 828
  ( fsLit "RET_NNNP",	\[a,b,c,d] -> emitRetUT [(NonPtrArg,a),(NonPtrArg,b),(NonPtrArg,c),(PtrArg,d)]),
  ( fsLit "RET_NPNP",	\[a,b,c,d] -> emitRetUT [(NonPtrArg,a),(PtrArg,b),(NonPtrArg,c),(PtrArg,d)])
829 830 831 832

 ]


833 834 835 836 837
profilingInfo dflags desc_str ty_str 
  = if not (dopt Opt_SccProfilingOn dflags)
    then NoProfilingInfo
    else ProfilingInfo (stringToWord8s desc_str)
                       (stringToWord8s ty_str)
838

839 840
staticClosure :: PackageId -> FastString -> FastString -> [CmmLit] -> ExtCode
staticClosure pkg cl_label info payload
841 842 843
  = do dflags <- getDynFlags
       let lits = mkStaticClosure dflags (mkCmmInfoLabel pkg info) dontCareCCS payload [] [] []
       code $ emitDataLits (mkCmmDataLabel pkg cl_label) lits
844 845 846

foreignCall
	:: String
847
	-> [ExtFCode HintedCmmFormal]
848
	-> ExtFCode CmmExpr
849
	-> [ExtFCode HintedCmmActual]
850
	-> Maybe [GlobalReg]
851
        -> CmmSafety
852
        -> CmmReturnInfo
853
        -> P ExtCode
854
foreignCall conv_string results_code expr_code args_code vols safety ret
855 856
  = do  convention <- case conv_string of
          "C" -> return CCallConv
857
          "stdcall" -> return StdCallConv
858 859 860 861 862 863
          "C--" -> return CmmCallConv
          _ -> fail ("unknown calling convention: " ++ conv_string)
	return $ do
	  results <- sequence results_code
	  expr <- expr_code
	  args <- sequence args_code
864 865
          case convention of
            -- Temporary hack so at least some functions are CmmSafe
866
            CmmCallConv -> code (stmtC (CmmCall (CmmCallee expr convention) results args ret))
867 868 869
            _ ->
              let expr' = adjCallTarget convention expr args in
              case safety of
870 871
	      CmmUnsafe ->
                code (emitForeignCall' PlayRisky results 
872
                   (CmmCallee expr' convention) args vols NoC_SRT ret)
873
              CmmSafe srt ->
Ian Lynagh's avatar
Ian Lynagh committed
874
                code (emitForeignCall' PlaySafe results 
875
                   (CmmCallee expr' convention) args vols NoC_SRT ret) where
876 877 878
              CmmInterruptible ->
                code (emitForeignCall' PlayInterruptible results 
                   (CmmCallee expr' convention) args vols NoC_SRT ret)
879

880
adjCallTarget :: CCallConv -> CmmExpr -> [CmmHinted CmmExpr] -> CmmExpr
881 882 883 884 885
#ifdef mingw32_TARGET_OS
-- On Windows, we have to add the '@N' suffix to the label when making
-- a call with the stdcall calling convention.
adjCallTarget StdCallConv (CmmLit (CmmLabel lbl)) args
  = CmmLit (CmmLabel (addLabelSize lbl (sum (map size args))))
886
  where size (CmmHinted e _) = max wORD_SIZE (widthInBytes (typeWidth (cmmExprType e)))
887 888 889 890 891
                 -- c.f. CgForeignCall.emitForeignCall
#endif
adjCallTarget _ expr _
  = expr

892
primCall
893
	:: [ExtFCode HintedCmmFormal]
894
	-> FastString
895
	-> [ExtFCode HintedCmmActual]
896
	-> Maybe [GlobalReg]
897
        -> CmmSafety
898
        -> P ExtCode
899
primCall results_code name args_code vols safety
900 901 902 903 904
  = case lookupUFM callishMachOps name of
	Nothing -> fail ("unknown primitive " ++ unpackFS name)
	Just p  -> return $ do
		results <- sequence results_code
		args <- sequence args_code
905 906 907
		case safety of
		  CmmUnsafe ->
		    code (emitForeignCall' PlayRisky results
908
		      (CmmPrim p Nothing) args vols NoC_SRT CmmMayReturn)
909
		  CmmSafe srt ->
Ian Lynagh's avatar
Ian Lynagh committed
910
		    code (emitForeignCall' PlaySafe results 
911
		      (CmmPrim p Nothing) args vols NoC_SRT CmmMayReturn) where
912 913
		  CmmInterruptible ->
		    code (emitForeignCall' PlayInterruptible results 
914
		      (CmmPrim p Nothing) args vols NoC_SRT CmmMayReturn)
915

916
doStore :: CmmType -> ExtFCode CmmExpr  -> ExtFCode CmmExpr -> ExtCode
917 918 919 920 921 922 923 924
doStore rep addr_code val_code
  = do addr <- addr_code
       val <- val_code
	-- 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.
925 926
       let val_width = typeWidth (cmmExprType val)
           rep_width = typeWidth rep
927
       let coerce_val 
928 929
		| val_width /= rep_width = CmmMachOp (MO_UU_Conv val_width rep_width) [val]
		| otherwise              = val
930 931 932 933 934 935
       stmtEC (CmmStore addr coerce_val)

-- Return an unboxed tuple.
emitRetUT :: [(CgRep,CmmExpr)] -> Code
emitRetUT args = do
  tickyUnboxedTupleReturn (length args)  -- TICK
936
  (sp, stmts, live) <- pushUnboxedTuple 0 args
937 938 939
  emitSimultaneously stmts -- NB. the args might overlap with the stack slots
                           -- or regs that we assign to, so better use
                           -- simultaneous assignments here (#3546)
940
  when (sp /= 0) $ stmtC (CmmAssign spReg (cmmRegOffW spReg (-sp)))
941
  stmtC $ CmmJump (entryCode (CmmLoad (cmmRegOffW spReg sp) bWord)) (Just live)
942 943 944 945 946 947 948 949 950 951 952 953

-- -----------------------------------------------------------------------------
-- 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.

954
cmmIfThenElse cond then_part else_part = do
955 956 957 958 959 960 961 962 963 964 965
     then_id <- code newLabelC
     join_id <- code newLabelC
     c <- cond
     emitCond c then_id
     else_part
     stmtEC (CmmBranch join_id)
     code (labelC then_id)
     then_part
     -- fall through to join
     code (labelC join_id)

966 967 968 969
cmmRawIf cond then_id = do
    c <- cond
    emitCond c then_id

970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008
-- '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
  stmtEC (CmmCondBranch e then_id)
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
  else_id <- code newLabelC
  emitCond e else_id
  stmtEC (CmmBranch then_id)
  code (labelC else_id)
emitCond (e1 `BoolOr` e2) then_id = do
  emitCond e1 then_id
  emitCond e2 then_id
emitCond (e1 `BoolAnd` e2) then_id = do
	-- we'd like to invert one of the conditionals here to avoid an
	-- 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.
  and_id <- code newLabelC
  else_id <- code newLabelC
  emitCond e1 and_id
  stmtEC (CmmBranch else_id)
  code (labelC and_id)
  emitCond e2 then_id
  code (labelC else_id)


-- -----------------------------------------------------------------------------
-- 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.

1009
doSwitch :: Maybe (Int,Int) -> ExtFCode CmmExpr -> [([Int],Either BlockId ExtCode)]
1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035
         -> Maybe ExtCode -> ExtCode
doSwitch mb_range scrut arms deflt
   = do 
	-- Compile code for the default branch
	dflt_entry <- 
		case deflt of
		  Nothing -> return Nothing
		  Just e  -> do b <- forkLabelledCodeEC e; return (Just b)

	-- 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
        stmtEC (CmmSwitch expr entries)
   where
1036 1037 1038
	emitArm :: ([Int],Either BlockId ExtCode) -> ExtFCode [(Int,BlockId)]
	emitArm (ints,Left blockid) = return [ (i,blockid) | i <- ints ]
	emitArm (ints,Right code) = do
1039 1040 1041 1042 1043 1044 1045 1046
	   blockid <- forkLabelledCodeEC code
	   return [ (i,blockid) | i <- ints ]

-- -----------------------------------------------------------------------------
-- Putting it all together

-- The initial environment: we define some constants that the compiler
-- knows about here.
1047 1048
initEnv :: DynFlags -> Env
initEnv dflags = listToUFM [
Ian Lynagh's avatar
Ian Lynagh committed
1049
  ( fsLit "SIZEOF_StgHeader", 
1050
    VarN (CmmLit (CmmInt (fromIntegral (fixedHdrSize dflags * wORD_SIZE)) wordWidth) )),
Ian Lynagh's avatar
Ian Lynagh committed
1051
  ( fsLit "SIZEOF_StgInfoTable",
1052
    VarN (CmmLit (CmmInt (fromIntegral (stdInfoTableSizeB dflags)) wordWidth) ))
1053 1054
  ]

Simon Peyton Jones's avatar
Simon Peyton Jones committed
1055
parseCmmFile :: DynFlags -> FilePath -> IO (Messages, Maybe CmmGroup)
Simon Marlow's avatar
Simon Marlow committed
1056
parseCmmFile dflags filename = do
1057 1058 1059
  showPass dflags "ParseCmm"
  buf <- hGetStringBuffer filename
  let
Ian Lynagh's avatar
Ian Lynagh committed
1060
	init_loc = mkRealSrcLoc (mkFastString filename) 1 1
1061
	init_state = (mkPState dflags buf init_loc) { lex_state = [0] }
1062 1063 1064
		-- reset the lex_state: the Lexer monad leaves some stuff
		-- in there we don't want.
  case unP cmmParse init_state of
1065
    PFailed span err -> do
1066
        let msg = mkPlainErrMsg dflags span err
1067
        return ((emptyBag, unitBag msg), Nothing)
1068
    POk pst code -> do
1069
        st <- initC
1070
        let (cmm,_) = runC dflags no_module st (getCmm (unEC code (initEnv dflags) [] >> return ()))
1071 1072 1073 1074
        let ms = getMessages pst
        if (errorsFound dflags ms)
         then return (ms, Nothing)
         else do
Ian Lynagh's avatar
Ian Lynagh committed
1075
           dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (ppr cmm)
1076
           return (ms, Just cmm)
1077 1078 1079
  where
	no_module = panic "parseCmmFile: no module"
}