CmmParse.y 34.7 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
{-# OPTIONS -Wwarn -w #-}
13 14 15
-- 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
16
--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
17 18
-- for details

19 20
module CmmParse ( parseCmmFile ) where

21 22
import CgMonad		hiding (getDynFlags)
import CgExtCode
23 24 25 26 27 28
import CgHeapery
import CgUtils
import CgProf
import CgTicky
import CgInfoTbls
import CgForeignCall
Simon Marlow's avatar
Simon Marlow committed
29 30 31 32 33 34
import CgTailCall
import CgStackery
import ClosureInfo
import CgCallConv
import CgClosure
import CostCentre
35

36
import BlockId
37 38
import Cmm
import PprCmm
Simon Marlow's avatar
Simon Marlow committed
39
import CmmUtils
40 41
import CmmLex
import CLabel
Simon Marlow's avatar
Simon Marlow committed
42
import SMRep
43 44
import Lexer

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

63
import Control.Monad
64
import Data.Array
65
import Data.Char	( ord )
66
import System.Exit
67 68

#include "HsVersions.h"
69 70
}

71 72
%expect 0

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
%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) }
123
	'never'		{ L _ (CmmT_never) }
124
	'prim'		{ L _ (CmmT_prim) }
125
	'return'	{ L _ (CmmT_return) }
126
	'returns'	{ L _ (CmmT_returns) }
127 128 129 130 131 132 133 134 135 136
	'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) }
137
	'gcptr'	        { L _ (CmmT_gcptr) }
138 139 140 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

	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 ')' ';'  
174 175 176
		{% withThisPackage $ \pkg -> 
		   do lits <- sequence $6;
		      staticClosure pkg $3 $5 (map getLit lits) }
177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198

-- 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 }
	: 'section' STRING '{' statics '}' 
		{ do ss <- sequence $4;
		     code (emitData (section $2) (concat ss)) }

statics	:: { [ExtFCode [CmmStatic]] }
	: {- empty -}			{ [] }
	| static statics		{ $1 : $2 }

-- 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] }
199 200 201 202
	: NAME ':'	
		{% withThisPackage $ \pkg -> 
		   return [CmmDataLabel (mkCmmDataLabel pkg $1)] }

203 204 205
	| type expr ';'	{ do e <- $2;
			     return [CmmStaticLit (getLit e)] }
	| type ';'			{ return [CmmUninitialised
206
							(widthInBytes (typeWidth $1))] }
207
        | 'bits8' '[' ']' STRING ';'	{ return [mkString $4] }
208 209 210
        | 'bits8' '[' INT ']' ';'	{ return [CmmUninitialised 
							(fromIntegral $3)] }
        | typenot8 '[' INT ']' ';'	{ return [CmmUninitialised 
211
						(widthInBytes (typeWidth $1) * 
212 213 214 215 216
							fromIntegral $3)] }
	| 'align' INT ';'		{ return [CmmAlign (fromIntegral $2)] }
	| 'CLOSURE' '(' NAME lits ')'
		{ do lits <- sequence $4;
		     return $ map CmmStaticLit $
217
                       mkStaticClosure (mkForeignLabel $3 Nothing True IsData)
218 219
                         -- mkForeignLabel because these are only used
                         -- for CHARLIKE and INTLIKE closures in the RTS.
220
			 dontCareCCS (map getLit lits) [] [] [] }
221 222 223 224 225 226 227
	-- arrays of closures required for the CHARLIKE & INTLIKE arrays

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

cmmproc :: { ExtCode }
228
-- TODO: add real SRT/info tables to parsed Cmm
229
	: info maybe_formals_without_hints maybe_gc_block maybe_frame '{' body '}'
230
		{ do ((entry_ret_label, info, live, formals, gc_block, frame), stmts) <-
231
		       getCgStmtsEC' $ loopDecls $ do {
232
		         (entry_ret_label, info, live) <- $1;
233
		         formals <- sequence $2;
234 235
		         gc_block <- $3;
		         frame <- $4;
236
		         $6;
237
		         return (entry_ret_label, info, live, formals, gc_block, frame) }
238
		     blks <- code (cgStmtsToBlocks stmts)
Ian Lynagh's avatar
Ian Lynagh committed
239
		     code (emitInfoTableAndCode entry_ret_label (CmmInfo gc_block frame info) formals blks) }
240

241
	| info maybe_formals_without_hints ';'
242
		{ do (entry_ret_label, info, live) <- $1;
243
		     formals <- sequence $2;
Ian Lynagh's avatar
Ian Lynagh committed
244
		     code (emitInfoTableAndCode entry_ret_label (CmmInfo Nothing Nothing info) formals []) }
245

246
	| NAME maybe_formals_without_hints maybe_gc_block maybe_frame '{' body '}'
247 248 249 250 251 252 253 254 255 256 257
		{% withThisPackage $ \pkg ->
		   do	newFunctionName $1 pkg
		   	((formals, gc_block, frame), stmts) <-
			 	getCgStmtsEC' $ loopDecls $ do {
		          		formals <- sequence $2;
		          		gc_block <- $3;
			  		frame <- $4;
		          		$6;
		          		return (formals, gc_block, frame) }
			blks <- code (cgStmtsToBlocks stmts)
			code (emitProc (CmmInfo gc_block frame CmmNonInfoTable) (mkCmmCodeLabel pkg $1) formals blks) }
258

259
info	:: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) }
260 261
	: 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
		-- ptrs, nptrs, closure type, description, type
262 263 264
		{% withThisPackage $ \pkg ->
		   do prof <- profilingInfo $11 $13
		      return (mkCmmEntryLabel pkg $3,
265
			CmmInfoTable False prof (fromIntegral $9)
266
				     (ThunkInfo (fromIntegral $5, fromIntegral $7) NoC_SRT),
267
			[]) }
268 269 270
	
	| 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ')'
		-- ptrs, nptrs, closure type, description, type, fun type
271 272 273
		{% withThisPackage $ \pkg -> 
		   do prof <- profilingInfo $11 $13
		      return (mkCmmEntryLabel pkg $3,
274
			CmmInfoTable False prof (fromIntegral $9)
275 276 277
				     (FunInfo (fromIntegral $5, fromIntegral $7) NoC_SRT
				      0  -- Arity zero
				      (ArgSpec (fromIntegral $15))
278
				      zeroCLit),
279
			[]) }
280 281
		-- we leave most of the fields zero here.  This is only used
		-- to generate the BCO info table in the RTS at the moment.
282 283 284 285

	-- A variant with a non-zero arity (needed to write Main_main in Cmm)
	| 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ',' INT ')'
		-- ptrs, nptrs, closure type, description, type, fun type, arity
286 287 288
		{% withThisPackage $ \pkg ->
		   do prof <- profilingInfo $11 $13
		      return (mkCmmEntryLabel pkg $3,
289
			CmmInfoTable False prof (fromIntegral $9)
290 291
				     (FunInfo (fromIntegral $5, fromIntegral $7) NoC_SRT (fromIntegral $17)
				      (ArgSpec (fromIntegral $15))
292 293 294 295
				      zeroCLit),
			[]) }
		-- we leave most of the fields zero here.  This is only used
		-- to generate the BCO info table in the RTS at the moment.
296 297 298
	
	| 'INFO_TABLE_CONSTR' '(' NAME ',' INT ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
		-- ptrs, nptrs, tag, closure type, description, type
299 300
		{% withThisPackage $ \pkg ->
		   do prof <- profilingInfo $13 $15
301 302
		     -- 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.
303 304
		      desc_lit <- code $ mkStringCLit $13
		      return (mkCmmEntryLabel pkg $3,
305
			CmmInfoTable False prof (fromIntegral $11)
306
				     (ConstrInfo (fromIntegral $5, fromIntegral $7) (fromIntegral $9) desc_lit),
307
			[]) }
308 309 310
	
	| 'INFO_TABLE_SELECTOR' '(' NAME ',' INT ',' INT ',' STRING ',' STRING ')'
		-- selector, closure type, description, type
311 312 313
		{% withThisPackage $ \pkg ->
		   do prof <- profilingInfo $9 $11
		      return (mkCmmEntryLabel pkg $3,
314
			CmmInfoTable False prof (fromIntegral $7)
315
				     (ThunkSelectorInfo (fromIntegral $5) NoC_SRT),
316
			[]) }
317 318 319

	| 'INFO_TABLE_RET' '(' NAME ',' INT ')'
		-- closure type (no live regs)
320 321 322
		{% withThisPackage $ \pkg ->
		   do let infoLabel = mkCmmInfoLabel pkg $3
		      return (mkCmmRetLabel pkg $3,
323
			CmmInfoTable False (ProfilingInfo zeroCLit zeroCLit) (fromIntegral $5)
324
				     (ContInfo [] NoC_SRT),
325
			[]) }
326

327
	| 'INFO_TABLE_RET' '(' NAME ',' INT ',' formals_without_hints0 ')'
328
		-- closure type, live regs
329 330 331
		{% withThisPackage $ \pkg ->
		   do live <- sequence (map (liftM Just) $7)
		      return (mkCmmRetLabel pkg $3,
332
			CmmInfoTable False (ProfilingInfo zeroCLit zeroCLit) (fromIntegral $5)
333
			             (ContInfo live NoC_SRT),
334
			live) }
335 336 337 338 339 340 341

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

decl	:: { ExtCode }
342
	: type names ';'		{ mapM_ (newLocal $1) $2 }
343
	| 'import' importNames ';'	{ mapM_ newImport $2 }
344 345
	| 'export' names ';'		{ return () }  -- ignore exports

346 347 348 349 350 351 352 353 354 355 356 357 358

-- an imported function name, with optional packageId
importNames  
	:: { [(Maybe PackageId, FastString)] }
	: importName			{ [$1] }
	| importName ',' importNames	{ $1 : $3 }		
	
importName
	:: { (Maybe PackageId, FastString) }
	: NAME				{ (Nothing, $1) }
	| STRING NAME			{ (Just (fsToPackageId (mkFastString $1)), $2) }
	
	
359
names 	:: { [FastString] }
360 361
	: NAME				{ [$1] }
	| NAME ',' names		{ $1 : $3 }
362 363 364 365

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

366 367
	| NAME ':'
		{ do l <- newLabel $1; code (labelC l) }
368

369 370
	| lreg '=' expr ';'
		{ do reg <- $1; e <- $3; stmtEC (CmmAssign reg e) }
371 372
	| type '[' expr ']' '=' expr ';'
		{ doStore $1 $3 $6 }
373 374 375 376 377 378 379

	-- 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.
380
	| maybe_results 'foreign' STRING expr '(' cmm_hint_exprs0 ')' safety vols opt_never_returns ';'
381
		{% foreignCall $3 $1 $4 $6 $9 $8 $10 }
382
	| maybe_results 'prim' '%' NAME '(' cmm_hint_exprs0 ')' safety vols ';'
383
		{% primCall $1 $4 $6 $9 $8 }
384 385 386 387 388 389
	-- 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 '}'
		{ doSwitch $2 $3 $5 $6 }
390 391
	| 'goto' NAME ';'
		{ do l <- lookupLabel $2; stmtEC (CmmBranch l) }
392 393 394 395
	| 'jump' expr maybe_actuals ';'
		{ do e1 <- $2; e2 <- sequence $3; stmtEC (CmmJump e1 e2) }
        | 'return' maybe_actuals ';'
		{ do e <- sequence $2; stmtEC (CmmReturn e) }
396 397 398
	| 'if' bool_expr '{' body '}' else 	
		{ ifThenElse $2 $4 $6 }

399 400 401
opt_never_returns :: { CmmReturnInfo }
        :                               { CmmMayReturn }
        | 'never' 'returns'             { CmmNeverReturns }
402

403 404 405 406 407 408 409 410 411 412 413 414
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 }

415 416 417 418 419
-- This is not C-- syntax.  What to do?
safety  :: { CmmSafety }
	: {- empty -}			{ CmmUnsafe } -- Default may change soon
	| STRING			{% parseSafety $1 }

420 421 422
-- This is not C-- syntax.  What to do?
vols 	:: { Maybe [GlobalReg] }
	: {- empty -}			{ Nothing }
423
	| '[' ']'		        { Just [] }
424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480
	| '[' 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 }

arms	:: { [([Int],ExtCode)] }
	: {- empty -}			{ [] }
	| arm arms			{ $1 : $2 }

arm	:: { ([Int],ExtCode) }
	: 'case' ints ':' '{' body '}'	{ ($2, $5) }

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 }

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 }
481 482
	: INT   maybe_ty	 { return (CmmLit (CmmInt $1 (typeWidth $2))) }
	| FLOAT maybe_ty	 { return (CmmLit (CmmFloat $1 (typeWidth $2))) }
483 484 485 486 487 488 489 490 491
	| STRING		 { do s <- code (mkStringCLit $1); 
				      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--
492 493
maybe_ty :: { CmmType }
	: {- empty -}			{ bWord }
494 495
	| '::' type			{ $2 }

496
maybe_actuals :: { [ExtFCode HintedCmmActual] }
497
	: {- empty -}		{ [] }
498
	| '(' cmm_hint_exprs0 ')'	{ $2 }
499

500
cmm_hint_exprs0 :: { [ExtFCode HintedCmmActual] }
501
	: {- empty -}			{ [] }
502
	| cmm_hint_exprs			{ $1 }
503

504 505 506
cmm_hint_exprs :: { [ExtFCode HintedCmmActual] }
	: cmm_hint_expr			{ [$1] }
	| cmm_hint_expr ',' cmm_hint_exprs	{ $1 : $3 }
507

508 509 510
cmm_hint_expr :: { ExtFCode HintedCmmActual }
	: expr				{ do e <- $1; return (CmmHinted e (inferCmmHint e)) }
	| expr STRING			{% do h <- parseCmmHint $2;
511
					      return $ do
512
						e <- $1; return (CmmHinted e h) }
513 514 515 516 517 518 519 520 521 522 523 524 525

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)) }

526
maybe_results :: { [ExtFCode HintedCmmFormal] }
527
	: {- empty -}		{ [] }
528
	| '(' cmm_formals ')' '='	{ $2 }
529

530
cmm_formals :: { [ExtFCode HintedCmmFormal] }
531 532 533
	: cmm_formal			{ [$1] }
	| cmm_formal ','			{ [$1] }
	| cmm_formal ',' cmm_formals	{ $1 : $3 }
534

535 536 537
cmm_formal :: { ExtFCode HintedCmmFormal }
	: local_lreg			{ do e <- $1; return (CmmHinted e (inferCmmHint (CmmReg (CmmLocal e)))) }
	| STRING local_lreg		{% do h <- parseCmmHint $1;
538
					      return $ do
539
						e <- $2; return (CmmHinted e h) }
540

541 542 543 544 545 546 547
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") }

548 549 550 551 552 553 554 555
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) }

556
maybe_formals_without_hints :: { [ExtFCode LocalReg] }
557
	: {- empty -}		{ [] }
558
	| '(' formals_without_hints0 ')'	{ $2 }
559

560
formals_without_hints0 :: { [ExtFCode LocalReg] }
561
	: {- empty -}		{ [] }
562
	| formals_without_hints		{ $1 }
563

564 565 566 567
formals_without_hints :: { [ExtFCode LocalReg] }
	: formal_without_hint ','		{ [$1] }
	| formal_without_hint		{ [$1] }
	| formal_without_hint ',' formals_without_hints	{ $1 : $3 }
568

569 570
formal_without_hint :: { ExtFCode LocalReg }
	: type NAME		{ newLocal $1 $2 }
571

572 573 574 575 576 577
maybe_frame :: { ExtFCode (Maybe UpdateFrame) }
	: {- empty -}			{ return Nothing }
	| 'jump' expr '(' exprs0 ')'	{ do { target <- $2;
					       args <- sequence $4;
					       return $ Just (UpdateFrame target args) } }

578 579 580 581 582
maybe_gc_block :: { ExtFCode (Maybe BlockId) }
	: {- empty -}			{ return Nothing }
	| 'goto' NAME
		{ do l <- lookupLabel $2; return (Just l) }

583 584
type	:: { CmmType }
	: 'bits8'		{ b8 }
585 586
	| typenot8		{ $1 }

587 588 589 590 591 592 593
typenot8 :: { CmmType }
	: 'bits16'		{ b16 }
	| 'bits32'		{ b32 }
	| 'bits64'		{ b64 }
	| 'float32'		{ f32 }
	| 'float64'		{ f64 }
	| 'gcptr'		{ gcWord }
594 595 596 597 598
{
section :: String -> Section
section "text"	 = Text
section "data" 	 = Data
section "rodata" = ReadOnlyData
599
section "relrodata" = RelocatableReadOnlyData
600 601 602
section "bss"	 = UninitialisedData
section s	 = OtherSection s

603 604 605
mkString :: String -> CmmStatic
mkString s = CmmString (map (fromIntegral.ord) s)

606 607 608 609
-- 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.
610
mkMachOp :: (Width -> MachOp) -> [ExtFCode CmmExpr] -> ExtFCode CmmExpr
611 612
mkMachOp fn args = do
  arg_exprs <- sequence args
613
  return (CmmMachOp (fn (typeWidth (cmmExprType (head arg_exprs)))) arg_exprs)
614 615 616 617 618 619

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

620
nameToMachOp :: FastString -> P (Width -> MachOp)
621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637
nameToMachOp name = 
  case lookupUFM machOps name of
	Nothing -> fail ("unknown primitive " ++ unpackFS name)
	Just m  -> return m

exprOp :: FastString -> [ExtFCode CmmExpr] -> P (ExtFCode CmmExpr)
exprOp name args_code =
  case lookupUFM exprMacros name of
     Just f  -> return $ do
        args <- sequence args_code
	return (f args)
     Nothing -> do
	mo <- nameToMachOp name
	return $ mkMachOp mo args_code

exprMacros :: UniqFM ([CmmExpr] -> CmmExpr)
exprMacros = listToUFM [
Ian Lynagh's avatar
Ian Lynagh committed
638 639 640 641 642 643 644 645 646 647
  ( fsLit "ENTRY_CODE",   \ [x] -> entryCode x ),
  ( fsLit "INFO_PTR",     \ [x] -> closureInfoPtr x ),
  ( fsLit "STD_INFO",     \ [x] -> infoTable x ),
  ( fsLit "FUN_INFO",     \ [x] -> funInfoTable x ),
  ( fsLit "GET_ENTRY",    \ [x] -> entryCode (closureInfoPtr x) ),
  ( fsLit "GET_STD_INFO", \ [x] -> infoTable (closureInfoPtr x) ),
  ( fsLit "GET_FUN_INFO", \ [x] -> funInfoTable (closureInfoPtr x) ),
  ( fsLit "INFO_TYPE",    \ [x] -> infoTableClosureType x ),
  ( fsLit "INFO_PTRS",    \ [x] -> infoTablePtrs x ),
  ( fsLit "INFO_NPTRS",   \ [x] -> infoTableNonPtrs x )
648 649 650 651 652 653 654 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 686 687 688 689
  ]

-- 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 ),

	( "flt",	MO_S_Lt ),
	( "fle",	MO_S_Le ),
	( "feq",	MO_Eq ),
	( "fne",	MO_Ne ),
	( "fgt",	MO_S_Gt ),
	( "fge",	MO_S_Ge ),
	( "fneg",	MO_S_Neg ),

	( "and",	MO_And ),
	( "or",		MO_Or ),
	( "xor",	MO_Xor ),
	( "com",	MO_Not ),
	( "shl",	MO_Shl ),
	( "shrl",	MO_U_Shr ),
	( "shra",	MO_S_Shr ),

690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710
	( "lobits8",  flip MO_UU_Conv W8  ),
	( "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 )
711 712
	]

713 714 715 716 717 718
callishMachOps = listToUFM $
	map (\(x, y) -> (mkFastString x, y)) [
        ( "write_barrier", MO_WriteBarrier )
        -- ToDo: the rest, maybe
    ]

719 720 721 722 723
parseSafety :: String -> P CmmSafety
parseSafety "safe"   = return (CmmSafe NoC_SRT)
parseSafety "unsafe" = return CmmUnsafe
parseSafety str      = fail ("unrecognised safety: " ++ str)

724 725 726 727
parseCmmHint :: String -> P ForeignHint
parseCmmHint "ptr"    = return AddrHint
parseCmmHint "signed" = return SignedHint
parseCmmHint str      = fail ("unrecognised hint: " ++ str)
728

729
-- labels are always pointers, so we might as well infer the hint
730 731 732 733 734 735 736 737 738 739 740 741 742
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
isPtrGlobalReg CurrentTSO	     = True
isPtrGlobalReg CurrentNursery	     = True
isPtrGlobalReg (VanillaReg _ VGcPtr) = True
isPtrGlobalReg _		     = False
743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759

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
760 761 762 763 764
  ( fsLit "CCS_ALLOC",		   \[words,ccs]  -> profAlloc words ccs ),
  ( fsLit "CLOSE_NURSERY",	   \[]  -> emitCloseNursery ),
  ( fsLit "ENTER_CCS_PAP_CL",     \[e] -> enterCostCentrePAP e ),
  ( fsLit "ENTER_CCS_THUNK",      \[e] -> enterCostCentreThunk e ),
  ( fsLit "HP_CHK_GEN",           \[words,liveness,reentry] -> 
765
                                      hpChkGen words liveness reentry ),
Ian Lynagh's avatar
Ian Lynagh committed
766 767 768 769 770 771 772 773
  ( 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] -> 
774
					emitSetDynHdr ptr info ccs ),
Ian Lynagh's avatar
Ian Lynagh committed
775
  ( fsLit "STK_CHK_GEN",          \[words,liveness,reentry] -> 
776
                                      stkChkGen words liveness reentry ),
Ian Lynagh's avatar
Ian Lynagh committed
777 778
  ( fsLit "STK_CHK_NP",	   \[e] -> stkChkNodePoints e ),
  ( fsLit "TICK_ALLOC_PRIM", 	   \[hdr,goods,slop] -> 
779
					tickyAllocPrim hdr goods slop ),
Ian Lynagh's avatar
Ian Lynagh committed
780
  ( fsLit "TICK_ALLOC_PAP",       \[goods,slop] -> 
781
					tickyAllocPAP goods slop ),
Ian Lynagh's avatar
Ian Lynagh committed
782
  ( fsLit "TICK_ALLOC_UP_THK",    \[goods,slop] -> 
783
					tickyAllocThunk goods slop ),
Ian Lynagh's avatar
Ian Lynagh committed
784 785 786 787 788 789 790 791 792 793 794 795
  ( 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)]),
796
  ( fsLit "RET_NNNN",  \[a,b,c,d] -> emitRetUT [(NonPtrArg,a),(NonPtrArg,b),(NonPtrArg,c),(NonPtrArg,d)]),
Ian Lynagh's avatar
Ian Lynagh committed
797 798
  ( 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)])
799 800 801 802 803

 ]



804 805 806 807 808 809 810 811 812
profilingInfo desc_str ty_str = do
  lit1 <- if opt_SccProfilingOn 
		   then code $ mkStringCLit desc_str
		   else return (mkIntCLit 0)
  lit2 <- if opt_SccProfilingOn 
		   then code $ mkStringCLit ty_str
		   else return (mkIntCLit 0)
  return (ProfilingInfo lit1 lit2)

813

814 815 816 817
staticClosure :: PackageId -> FastString -> FastString -> [CmmLit] -> ExtCode
staticClosure pkg cl_label info payload
  = code $ emitDataLits (mkCmmDataLabel pkg cl_label) lits
  where  lits = mkStaticClosure (mkCmmInfoLabel pkg info) dontCareCCS payload [] [] []
818 819 820

foreignCall
	:: String
821
	-> [ExtFCode HintedCmmFormal]
822
	-> ExtFCode CmmExpr
823
	-> [ExtFCode HintedCmmActual]
824
	-> Maybe [GlobalReg]
825
        -> CmmSafety
826
        -> CmmReturnInfo
827
        -> P ExtCode
828
foreignCall conv_string results_code expr_code args_code vols safety ret
829 830
  = do  convention <- case conv_string of
          "C" -> return CCallConv
831
          "stdcall" -> return StdCallConv
832 833 834 835 836 837
          "C--" -> return CmmCallConv
          _ -> fail ("unknown calling convention: " ++ conv_string)
	return $ do
	  results <- sequence results_code
	  expr <- expr_code
	  args <- sequence args_code
838
	  --code (stmtC (CmmCall (CmmCallee expr convention) results args safety))
839 840
          case convention of
            -- Temporary hack so at least some functions are CmmSafe
841
            CmmCallConv -> code (stmtC (CmmCall (CmmCallee expr convention) results args safety ret))
842 843 844
            _ ->
              let expr' = adjCallTarget convention expr args in
              case safety of
845 846
	      CmmUnsafe ->
                code (emitForeignCall' PlayRisky results 
847
                   (CmmCallee expr' convention) args vols NoC_SRT ret)
848 849
              CmmSafe srt ->
                code (emitForeignCall' (PlaySafe unused) results 
850
                   (CmmCallee expr' convention) args vols NoC_SRT ret) where
851
	        unused = panic "not used by emitForeignCall'"
852

853
adjCallTarget :: CCallConv -> CmmExpr -> [CmmHinted CmmExpr] -> CmmExpr
854 855 856 857 858
#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))))
859
  where size (CmmHinted e _) = max wORD_SIZE (widthInBytes (typeWidth (cmmExprType e)))
860 861 862 863 864
                 -- c.f. CgForeignCall.emitForeignCall
#endif
adjCallTarget _ expr _
  = expr

865
primCall
866
	:: [ExtFCode HintedCmmFormal]
867
	-> FastString
868
	-> [ExtFCode HintedCmmActual]
869
	-> Maybe [GlobalReg]
870
        -> CmmSafety
871
        -> P ExtCode
872
primCall results_code name args_code vols safety
873 874 875 876 877
  = case lookupUFM callishMachOps name of
	Nothing -> fail ("unknown primitive " ++ unpackFS name)
	Just p  -> return $ do
		results <- sequence results_code
		args <- sequence args_code
878 879 880
		case safety of
		  CmmUnsafe ->
		    code (emitForeignCall' PlayRisky results
881
		      (CmmPrim p) args vols NoC_SRT CmmMayReturn)
882 883
		  CmmSafe srt ->
		    code (emitForeignCall' (PlaySafe unused) results 
884
		      (CmmPrim p) args vols NoC_SRT CmmMayReturn) where
885
		    unused = panic "not used by emitForeignCall'"
886

887
doStore :: CmmType -> ExtFCode CmmExpr  -> ExtFCode CmmExpr -> ExtCode
888 889 890 891 892 893 894 895
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.
896 897
       let val_width = typeWidth (cmmExprType val)
           rep_width = typeWidth rep
898
       let coerce_val 
899 900
		| val_width /= rep_width = CmmMachOp (MO_UU_Conv val_width rep_width) [val]
		| otherwise              = val
901 902 903 904 905 906 907
       stmtEC (CmmStore addr coerce_val)

-- Return an unboxed tuple.
emitRetUT :: [(CgRep,CmmExpr)] -> Code
emitRetUT args = do
  tickyUnboxedTupleReturn (length args)  -- TICK
  (sp, stmts) <- pushUnboxedTuple 0 args
908 909 910
  emitSimultaneously stmts -- NB. the args might overlap with the stack slots
                           -- or regs that we assign to, so better use
                           -- simultaneous assignments here (#3546)
911
  when (sp /= 0) $ stmtC (CmmAssign spReg (cmmRegOffW spReg (-sp)))
912
  stmtC (CmmJump (entryCode (CmmLoad (cmmRegOffW spReg sp) bWord)) [])
913
  -- TODO (when using CPS): emitStmt (CmmReturn (map snd args))
914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 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 1009 1010 1011 1012 1013 1014 1015 1016

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

ifThenElse cond then_part else_part = do
     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)

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

doSwitch :: Maybe (Int,Int) -> ExtFCode CmmExpr -> [([Int],ExtCode)]
         -> 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
	emitArm :: ([Int],ExtCode) -> ExtFCode [(Int,BlockId)]
	emitArm (ints,code) = do
	   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.
initEnv :: Env
initEnv = listToUFM [
Ian Lynagh's avatar
Ian Lynagh committed
1017
  ( fsLit "SIZEOF_StgHeader", 
1018
    Var (CmmLit (CmmInt (fromIntegral (fixedHdrSize * wORD_SIZE)) wordWidth) )),
Ian Lynagh's avatar
Ian Lynagh committed
1019
  ( fsLit "SIZEOF_StgInfoTable",
1020
    Var (CmmLit (CmmInt (fromIntegral stdInfoTableSizeB) wordWidth) ))
1021 1022
  ]

1023
parseCmmFile :: DynFlags -> FilePath -> IO (Messages, Maybe Cmm)
Simon Marlow's avatar
Simon Marlow committed
1024
parseCmmFile dflags filename = do
1025 1026 1027
  showPass dflags "ParseCmm"
  buf <- hGetStringBuffer filename
  let
1028
	init_loc = mkSrcLoc (mkFastString filename) 1 1
1029 1030 1031 1032
	init_state = (mkPState buf init_loc dflags) { lex_state = [0] }
		-- reset the lex_state: the Lexer monad leaves some stuff
		-- in there we don't want.
  case unP cmmParse init_state of
1033 1034 1035
    PFailed span err -> do
        let msg = mkPlainErrMsg span err
        return ((emptyBag, unitBag msg), Nothing)
1036
    POk pst code -> do
1037 1038 1039 1040 1041 1042 1043
        cmm <- initC dflags no_module (getCmm (unEC code initEnv [] >> return ()))
        let ms = getMessages pst
        if (errorsFound dflags ms)
         then return (ms, Nothing)
         else do
           dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (ppr cmm)
           return (ms, Just cmm)
1044 1045 1046
  where
	no_module = panic "parseCmmFile: no module"
}