Context Navigation

CmmParse.y

Visit:

Revision 98acdf083c119b018f25097593668a816dc68068, 37.0 KB (checked in by Ian Lynagh <igloo@…>, 3 months ago)

Add a Word add-with-carry primop

No special-casing in any NCGs yet

Property mode set to 100644

Line
1	-----------------------------------------------------------------------------
2	--
3	-- (c) The University of Glasgow, 2004-2006
4	--
5	-- Parser for concrete Cmm.
6	-- This doesn't just parse the Cmm file, we also do some code generation
7	-- along the way for switches and foreign calls etc.
8	--
9	-----------------------------------------------------------------------------
10
11	-- TODO: Add support for interruptible/uninterruptible foreign call specification
12
13	{
14	{-# LANGUAGE BangPatterns #-} -- required for versions of Happy before 1.18.6
15	{-# OPTIONS -Wwarn -w #-}
16	-- The above warning supression flag is a temporary kludge.
17	-- While working on this module you are encouraged to remove it and fix
18	-- any warnings in the module. See
19	-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
20	-- for details
21
22	module CmmParse ( parseCmmFile ) where
23
24	import CgMonad
25	import CgExtCode
26	import CgHeapery
27	import CgUtils
28	import CgProf
29	import CgTicky
30	import CgInfoTbls
31	import CgForeignCall
32	import CgTailCall
33	import CgStackery
34	import ClosureInfo
35	import CgCallConv
36	import CgClosure
37	import CostCentre
38
39	import BlockId
40	import OldCmm
41	import OldPprCmm()
42	import CmmUtils
43	import CmmLex
44	import CLabel
45	import SMRep
46	import Lexer
47
48	import ForeignCall
49	import Module
50	import Literal
51	import Unique
52	import UniqFM
53	import SrcLoc
54	import DynFlags
55	import StaticFlags
56	import ErrUtils
57	import StringBuffer
58	import FastString
59	import Panic
60	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	%expect 0
75
76	%token
77	':' { L _ (CmmT_SpecChar ':') }
78	';' { L _ (CmmT_SpecChar ';') }
79	'{' { L _ (CmmT_SpecChar '{') }
80	'}' { L _ (CmmT_SpecChar '}') }
81	'[' { L _ (CmmT_SpecChar '[') }
82	']' { L _ (CmmT_SpecChar ']') }
83	'(' { L _ (CmmT_SpecChar '(') }
84	')' { L _ (CmmT_SpecChar ')') }
85	'=' { L _ (CmmT_SpecChar '=') }
86	'`' { L _ (CmmT_SpecChar '`') }
87	'~' { L _ (CmmT_SpecChar '~') }
88	'/' { L _ (CmmT_SpecChar '/') }
89	'' { L _ (CmmT_SpecChar '') }
90	'%' { L _ (CmmT_SpecChar '%') }
91	'-' { L _ (CmmT_SpecChar '-') }
92	'+' { L _ (CmmT_SpecChar '+') }
93	'&' { L _ (CmmT_SpecChar '&') }
94	'^' { L _ (CmmT_SpecChar '^') }
95	'\|' { L _ (CmmT_SpecChar '\|') }
96	'>' { L _ (CmmT_SpecChar '>') }
97	'<' { L _ (CmmT_SpecChar '<') }
98	',' { L _ (CmmT_SpecChar ',') }
99	'!' { L _ (CmmT_SpecChar '!') }
100
101	'..' { L _ (CmmT_DotDot) }
102	'::' { L _ (CmmT_DoubleColon) }
103	'>>' { L _ (CmmT_Shr) }
104	'<<' { L _ (CmmT_Shl) }
105	'>=' { L _ (CmmT_Ge) }
106	'<=' { L _ (CmmT_Le) }
107	'==' { L _ (CmmT_Eq) }
108	'!=' { L _ (CmmT_Ne) }
109	'&&' { L _ (CmmT_BoolAnd) }
110	'\|\|' { L _ (CmmT_BoolOr) }
111
112	'CLOSURE' { L _ (CmmT_CLOSURE) }
113	'INFO_TABLE' { L _ (CmmT_INFO_TABLE) }
114	'INFO_TABLE_RET'{ L _ (CmmT_INFO_TABLE_RET) }
115	'INFO_TABLE_FUN'{ L _ (CmmT_INFO_TABLE_FUN) }
116	'INFO_TABLE_CONSTR'{ L _ (CmmT_INFO_TABLE_CONSTR) }
117	'INFO_TABLE_SELECTOR'{ L _ (CmmT_INFO_TABLE_SELECTOR) }
118	'else' { L _ (CmmT_else) }
119	'export' { L _ (CmmT_export) }
120	'section' { L _ (CmmT_section) }
121	'align' { L _ (CmmT_align) }
122	'goto' { L _ (CmmT_goto) }
123	'if' { L _ (CmmT_if) }
124	'jump' { L _ (CmmT_jump) }
125	'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	'import' { L _ (CmmT_import) }
131	'switch' { L _ (CmmT_switch) }
132	'case' { L _ (CmmT_case) }
133	'default' { L _ (CmmT_default) }
134	'bits8' { L _ (CmmT_bits8) }
135	'bits16' { L _ (CmmT_bits16) }
136	'bits32' { L _ (CmmT_bits32) }
137	'bits64' { L _ (CmmT_bits64) }
138	'float32' { L _ (CmmT_float32) }
139	'float64' { L _ (CmmT_float64) }
140	'gcptr' { L _ (CmmT_gcptr) }
141
142	GLOBALREG { L _ (CmmT_GlobalReg $$) }
143	NAME { L _ (CmmT_Name $$) }
144	STRING { L _ (CmmT_String $$) }
145	INT { L _ (CmmT_Int $$) }
146	FLOAT { L _ (CmmT_Float $$) }
147
148	%monad { P } { >>= } { return }
149	%lexer { cmmlex } { L _ CmmT_EOF }
150	%name cmmParse cmm
151	%tokentype { Located CmmToken }
152
153	-- C-- operator precedences, taken from the C-- spec
154	%right '\|\|' -- non-std extension, called %disjoin in C--
155	%right '&&' -- non-std extension, called %conjoin in C--
156	%right '!'
157	%nonassoc '>=' '>' '<=' '<' '!=' '=='
158	%left '\|'
159	%left '^'
160	%left '&'
161	%left '>>' '<<'
162	%left '-' '+'
163	%left '/' '*' '%'
164	%right '~'
165
166	%%
167
168	cmm :: { ExtCode }
169	: {- empty -} { return () }
170	\| cmmtop cmm { do $1; $2 }
171
172	cmmtop :: { ExtCode }
173	: cmmproc { $1 }
174	\| cmmdata { $1 }
175	\| decl { $1 }
176	\| 'CLOSURE' '(' NAME ',' NAME lits ')' ';'
177	{% withThisPackage $ \pkg ->
178	do lits <- sequence $6;
179	staticClosure pkg $3 $5 (map getLit lits) }
180
181	-- The only static closures in the RTS are dummy closures like
182	-- stg_END_TSO_QUEUE_closure and stg_dummy_ret. We don't need
183	-- to provide the full generality of static closures here.
184	-- In particular:
185	-- * CCS can always be CCS_DONT_CARE
186	-- * closure is always extern
187	-- * payload is always empty
188	-- * we can derive closure and info table labels from a single NAME
189
190	cmmdata :: { ExtCode }
191	: 'section' STRING '{' data_label statics '}'
192	{ do lbl <- $4;
193	ss <- sequence $5;
194	code (emitDecl (CmmData (section $2) (Statics lbl $ concat ss))) }
195
196	data_label :: { ExtFCode CLabel }
197	: NAME ':'
198	{% withThisPackage $ \pkg ->
199	return (mkCmmDataLabel pkg $1) }
200
201	statics :: { [ExtFCode [CmmStatic]] }
202	: {- empty -} { [] }
203	\| static statics { $1 : $2 }
204
205	-- Strings aren't used much in the RTS HC code, so it doesn't seem
206	-- worth allowing inline strings. C-- doesn't allow them anyway.
207	static :: { ExtFCode [CmmStatic] }
208	: type expr ';' { do e <- $2;
209	return [CmmStaticLit (getLit e)] }
210	\| type ';' { return [CmmUninitialised
211	(widthInBytes (typeWidth $1))] }
212	\| 'bits8' '[' ']' STRING ';' { return [mkString $4] }
213	\| 'bits8' '[' INT ']' ';' { return [CmmUninitialised
214	(fromIntegral $3)] }
215	\| typenot8 '[' INT ']' ';' { return [CmmUninitialised
216	(widthInBytes (typeWidth $1) *
217	fromIntegral $3)] }
218	\| 'CLOSURE' '(' NAME lits ')'
219	{ do lits <- sequence $4;
220	return $ map CmmStaticLit $
221	mkStaticClosure (mkForeignLabel $3 Nothing ForeignLabelInExternalPackage IsData)
222	-- mkForeignLabel because these are only used
223	-- for CHARLIKE and INTLIKE closures in the RTS.
224	dontCareCCS (map getLit lits) [] [] [] }
225	-- arrays of closures required for the CHARLIKE & INTLIKE arrays
226
227	lits :: { [ExtFCode CmmExpr] }
228	: {- empty -} { [] }
229	\| ',' expr lits { $2 : $3 }
230
231	cmmproc :: { ExtCode }
232	-- TODO: add real SRT/info tables to parsed Cmm
233	: info maybe_formals_without_hints maybe_gc_block maybe_frame '{' body '}'
234	{ do ((entry_ret_label, info, live, formals, gc_block, frame), stmts) <-
235	getCgStmtsEC' $ loopDecls $ do {
236	(entry_ret_label, info, live) <- $1;
237	formals <- sequence $2;
238	gc_block <- $3;
239	frame <- $4;
240	$6;
241	return (entry_ret_label, info, live, formals, gc_block, frame) }
242	blks <- code (cgStmtsToBlocks stmts)
243	code (emitInfoTableAndCode entry_ret_label (CmmInfo gc_block frame info) formals blks) }
244
245	\| info maybe_formals_without_hints ';'
246	{ do (entry_ret_label, info, live) <- $1;
247	formals <- sequence $2;
248	code (emitInfoTableAndCode entry_ret_label (CmmInfo Nothing Nothing info) formals []) }
249
250	\| NAME maybe_formals_without_hints maybe_gc_block maybe_frame '{' body '}'
251	{% withThisPackage $ \pkg ->
252	do newFunctionName $1 pkg
253	((formals, gc_block, frame), stmts) <-
254	getCgStmtsEC' $ loopDecls $ do {
255	formals <- sequence $2;
256	gc_block <- $3;
257	frame <- $4;
258	$6;
259	return (formals, gc_block, frame) }
260	blks <- code (cgStmtsToBlocks stmts)
261	code (emitProc (CmmInfo gc_block frame CmmNonInfoTable) (mkCmmCodeLabel pkg $1) formals blks) }
262
263	info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) }
264	: 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
265	-- ptrs, nptrs, closure type, description, type
266	{% withThisPackage $ \pkg ->
267	do let prof = profilingInfo $11 $13
268	rep = mkRTSRep (fromIntegral $9) $
269	mkHeapRep False (fromIntegral $5)
270	(fromIntegral $7) Thunk
271	-- not really Thunk, but that makes the info table
272	-- we want.
273	return (mkCmmEntryLabel pkg $3,
274	CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
275	, cit_rep = rep
276	, cit_prof = prof, cit_srt = NoC_SRT },
277	[]) }
278
279	\| 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ')'
280	-- ptrs, nptrs, closure type, description, type, fun type
281	{% withThisPackage $ \pkg ->
282	do let prof = profilingInfo $11 $13
283	ty = Fun 0 (ArgSpec (fromIntegral $15))
284	-- Arity zero, arg_type $15
285	rep = mkRTSRep (fromIntegral $9) $
286	mkHeapRep False (fromIntegral $5)
287	(fromIntegral $7) ty
288	return (mkCmmEntryLabel pkg $3,
289	CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
290	, cit_rep = rep
291	, cit_prof = prof, cit_srt = NoC_SRT },
292	[]) }
293	-- we leave most of the fields zero here. This is only used
294	-- to generate the BCO info table in the RTS at the moment.
295
296	\| 'INFO_TABLE_CONSTR' '(' NAME ',' INT ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
297	-- ptrs, nptrs, tag, closure type, description, type
298	{% withThisPackage $ \pkg ->
299	do let prof = profilingInfo $13 $15
300	ty = Constr (fromIntegral $9) -- Tag
301	(stringToWord8s $13)
302	rep = mkRTSRep (fromIntegral $11) $
303	mkHeapRep False (fromIntegral $5)
304	(fromIntegral $7) ty
305	return (mkCmmEntryLabel pkg $3,
306	CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
307	, cit_rep = rep
308	, cit_prof = prof, cit_srt = NoC_SRT },
309	[]) }
310
311	-- If profiling is on, this string gets duplicated,
312	-- but that's the way the old code did it we can fix it some other time.
313
314	\| 'INFO_TABLE_SELECTOR' '(' NAME ',' INT ',' INT ',' STRING ',' STRING ')'
315	-- selector, closure type, description, type
316	{% withThisPackage $ \pkg ->
317	do let prof = profilingInfo $9 $11
318	ty = ThunkSelector (fromIntegral $5)
319	rep = mkRTSRep (fromIntegral $7) $
320	mkHeapRep False 0 0 ty
321	return (mkCmmEntryLabel pkg $3,
322	CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
323	, cit_rep = rep
324	, cit_prof = prof, cit_srt = NoC_SRT },
325	[]) }
326
327	\| 'INFO_TABLE_RET' '(' NAME ',' INT ')'
328	-- closure type (no live regs)
329	{% withThisPackage $ \pkg ->
330	do let prof = NoProfilingInfo
331	rep = mkRTSRep (fromIntegral $5) $ mkStackRep []
332	return (mkCmmRetLabel pkg $3,
333	CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
334	, cit_rep = rep
335	, cit_prof = prof, cit_srt = NoC_SRT },
336	[]) }
337
338	\| 'INFO_TABLE_RET' '(' NAME ',' INT ',' formals_without_hints0 ')'
339	-- closure type, live regs
340	{% withThisPackage $ \pkg ->
341	do live <- sequence (map (liftM Just) $7)
342	let prof = NoProfilingInfo
343	bitmap = mkLiveness live
344	rep = mkRTSRep (fromIntegral $5) $ mkStackRep bitmap
345	return (mkCmmRetLabel pkg $3,
346	CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
347	, cit_rep = rep
348	, cit_prof = prof, cit_srt = NoC_SRT },
349	[]) }
350
351	body :: { ExtCode }
352	: {- empty -} { return () }
353	\| decl body { do $1; $2 }
354	\| stmt body { do $1; $2 }
355
356	decl :: { ExtCode }
357	: type names ';' { mapM_ (newLocal $1) $2 }
358	\| 'import' importNames ';' { mapM_ newImport $2 }
359	\| 'export' names ';' { return () } -- ignore exports
360
361
362	-- an imported function name, with optional packageId
363	importNames
364	:: { [(FastString, CLabel)] }
365	: importName { [$1] }
366	\| importName ',' importNames { $1 : $3 }
367
368	importName
369	:: { (FastString, CLabel) }
370
371	-- A label imported without an explicit packageId.
372	-- These are taken to come frome some foreign, unnamed package.
373	: NAME
374	{ ($1, mkForeignLabel $1 Nothing ForeignLabelInExternalPackage IsFunction) }
375
376	-- A label imported with an explicit packageId.
377	\| STRING NAME
378	{ ($2, mkCmmCodeLabel (fsToPackageId (mkFastString $1)) $2) }
379
380
381	names :: { [FastString] }
382	: NAME { [$1] }
383	\| NAME ',' names { $1 : $3 }
384
385	stmt :: { ExtCode }
386	: ';' { nopEC }
387
388	\| NAME ':'
389	{ do l <- newLabel $1; code (labelC l) }
390
391	\| lreg '=' expr ';'
392	{ do reg <- $1; e <- $3; stmtEC (CmmAssign reg e) }
393	\| type '[' expr ']' '=' expr ';'
394	{ doStore $1 $3 $6 }
395
396	-- Gah! We really want to say "maybe_results" but that causes
397	-- a shift/reduce conflict with assignment. We either
398	-- we expand out the no-result and single result cases or
399	-- we tweak the syntax to avoid the conflict. The later
400	-- option is taken here because the other way would require
401	-- multiple levels of expanding and get unwieldy.
402	\| maybe_results 'foreign' STRING expr '(' cmm_hint_exprs0 ')' safety vols opt_never_returns ';'
403	{% foreignCall $3 $1 $4 $6 $9 $8 $10 }
404	\| maybe_results 'prim' '%' NAME '(' cmm_hint_exprs0 ')' safety vols ';'
405	{% primCall $1 $4 $6 $9 $8 }
406	-- stmt-level macros, stealing syntax from ordinary C-- function calls.
407	-- Perhaps we ought to use the %%-form?
408	\| NAME '(' exprs0 ')' ';'
409	{% stmtMacro $1 $3 }
410	\| 'switch' maybe_range expr '{' arms default '}'
411	{ do as <- sequence $5; doSwitch $2 $3 as $6 }
412	\| 'goto' NAME ';'
413	{ do l <- lookupLabel $2; stmtEC (CmmBranch l) }
414	\| 'jump' expr vols ';'
415	{ do e <- $2; stmtEC (CmmJump e $3) }
416	\| 'return' ';'
417	{ stmtEC CmmReturn }
418	\| 'if' bool_expr 'goto' NAME
419	{ do l <- lookupLabel $4; cmmRawIf $2 l }
420	\| 'if' bool_expr '{' body '}' else
421	{ cmmIfThenElse $2 $4 $6 }
422
423	opt_never_returns :: { CmmReturnInfo }
424	: { CmmMayReturn }
425	\| 'never' 'returns' { CmmNeverReturns }
426
427	bool_expr :: { ExtFCode BoolExpr }
428	: bool_op { $1 }
429	\| expr { do e <- $1; return (BoolTest e) }
430
431	bool_op :: { ExtFCode BoolExpr }
432	: bool_expr '&&' bool_expr { do e1 <- $1; e2 <- $3;
433	return (BoolAnd e1 e2) }
434	\| bool_expr '\|\|' bool_expr { do e1 <- $1; e2 <- $3;
435	return (BoolOr e1 e2) }
436	\| '!' bool_expr { do e <- $2; return (BoolNot e) }
437	\| '(' bool_op ')' { $2 }
438
439	-- This is not C-- syntax. What to do?
440	safety :: { CmmSafety }
441	: {- empty -} { CmmUnsafe } -- Default may change soon
442	\| STRING {% parseSafety $1 }
443
444	-- This is not C-- syntax. What to do?
445	vols :: { Maybe [GlobalReg] }
446	: {- empty -} { Nothing }
447	\| '[' ']' { Just [] }
448	\| '[' globals ']' { Just $2 }
449
450	globals :: { [GlobalReg] }
451	: GLOBALREG { [$1] }
452	\| GLOBALREG ',' globals { $1 : $3 }
453
454	maybe_range :: { Maybe (Int,Int) }
455	: '[' INT '..' INT ']' { Just (fromIntegral $2, fromIntegral $4) }
456	\| {- empty -} { Nothing }
457
458	arms :: { [ExtFCode ([Int],Either BlockId ExtCode)] }
459	: {- empty -} { [] }
460	\| arm arms { $1 : $2 }
461
462	arm :: { ExtFCode ([Int],Either BlockId ExtCode) }
463	: 'case' ints ':' arm_body { do b <- $4; return ($2, b) }
464
465	arm_body :: { ExtFCode (Either BlockId ExtCode) }
466	: '{' body '}' { return (Right $2) }
467	\| 'goto' NAME ';' { do l <- lookupLabel $2; return (Left l) }
468
469	ints :: { [Int] }
470	: INT { [ fromIntegral $1 ] }
471	\| INT ',' ints { fromIntegral $1 : $3 }
472
473	default :: { Maybe ExtCode }
474	: 'default' ':' '{' body '}' { Just $4 }
475	-- taking a few liberties with the C-- syntax here; C-- doesn't have
476	-- 'default' branches
477	\| {- empty -} { Nothing }
478
479	-- Note: OldCmm doesn't support a first class 'else' statement, though
480	-- CmmNode does.
481	else :: { ExtCode }
482	: {- empty -} { nopEC }
483	\| 'else' '{' body '}' { $3 }
484
485	-- we have to write this out longhand so that Happy's precedence rules
486	-- can kick in.
487	expr :: { ExtFCode CmmExpr }
488	: expr '/' expr { mkMachOp MO_U_Quot [$1,$3] }
489	\| expr '*' expr { mkMachOp MO_Mul [$1,$3] }
490	\| expr '%' expr { mkMachOp MO_U_Rem [$1,$3] }
491	\| expr '-' expr { mkMachOp MO_Sub [$1,$3] }
492	\| expr '+' expr { mkMachOp MO_Add [$1,$3] }
493	\| expr '>>' expr { mkMachOp MO_U_Shr [$1,$3] }
494	\| expr '<<' expr { mkMachOp MO_Shl [$1,$3] }
495	\| expr '&' expr { mkMachOp MO_And [$1,$3] }
496	\| expr '^' expr { mkMachOp MO_Xor [$1,$3] }
497	\| expr '\|' expr { mkMachOp MO_Or [$1,$3] }
498	\| expr '>=' expr { mkMachOp MO_U_Ge [$1,$3] }
499	\| expr '>' expr { mkMachOp MO_U_Gt [$1,$3] }
500	\| expr '<=' expr { mkMachOp MO_U_Le [$1,$3] }
501	\| expr '<' expr { mkMachOp MO_U_Lt [$1,$3] }
502	\| expr '!=' expr { mkMachOp MO_Ne [$1,$3] }
503	\| expr '==' expr { mkMachOp MO_Eq [$1,$3] }
504	\| '~' expr { mkMachOp MO_Not [$2] }
505	\| '-' expr { mkMachOp MO_S_Neg [$2] }
506	\| expr0 '`' NAME '`' expr0 {% do { mo <- nameToMachOp $3 ;
507	return (mkMachOp mo [$1,$5]) } }
508	\| expr0 { $1 }
509
510	expr0 :: { ExtFCode CmmExpr }
511	: INT maybe_ty { return (CmmLit (CmmInt $1 (typeWidth $2))) }
512	\| FLOAT maybe_ty { return (CmmLit (CmmFloat $1 (typeWidth $2))) }
513	\| STRING { do s <- code (newStringCLit $1);
514	return (CmmLit s) }
515	\| reg { $1 }
516	\| type '[' expr ']' { do e <- $3; return (CmmLoad e $1) }
517	\| '%' NAME '(' exprs0 ')' {% exprOp $2 $4 }
518	\| '(' expr ')' { $2 }
519
520
521	-- leaving out the type of a literal gives you the native word size in C--
522	maybe_ty :: { CmmType }
523	: {- empty -} { bWord }
524	\| '::' type { $2 }
525
526	maybe_actuals :: { [ExtFCode HintedCmmActual] }
527	: {- empty -} { [] }
528	\| '(' cmm_hint_exprs0 ')' { $2 }
529
530	cmm_hint_exprs0 :: { [ExtFCode HintedCmmActual] }
531	: {- empty -} { [] }
532	\| cmm_hint_exprs { $1 }
533
534	cmm_hint_exprs :: { [ExtFCode HintedCmmActual] }
535	: cmm_hint_expr { [$1] }
536	\| cmm_hint_expr ',' cmm_hint_exprs { $1 : $3 }
537
538	cmm_hint_expr :: { ExtFCode HintedCmmActual }
539	: expr { do e <- $1; return (CmmHinted e (inferCmmHint e)) }
540	\| expr STRING {% do h <- parseCmmHint $2;
541	return $ do
542	e <- $1; return (CmmHinted e h) }
543
544	exprs0 :: { [ExtFCode CmmExpr] }
545	: {- empty -} { [] }
546	\| exprs { $1 }
547
548	exprs :: { [ExtFCode CmmExpr] }
549	: expr { [ $1 ] }
550	\| expr ',' exprs { $1 : $3 }
551
552	reg :: { ExtFCode CmmExpr }
553	: NAME { lookupName $1 }
554	\| GLOBALREG { return (CmmReg (CmmGlobal $1)) }
555
556	maybe_results :: { [ExtFCode HintedCmmFormal] }
557	: {- empty -} { [] }
558	\| '(' cmm_formals ')' '=' { $2 }
559
560	cmm_formals :: { [ExtFCode HintedCmmFormal] }
561	: cmm_formal { [$1] }
562	\| cmm_formal ',' { [$1] }
563	\| cmm_formal ',' cmm_formals { $1 : $3 }
564
565	cmm_formal :: { ExtFCode HintedCmmFormal }
566	: local_lreg { do e <- $1; return (CmmHinted e (inferCmmHint (CmmReg (CmmLocal e)))) }
567	\| STRING local_lreg {% do h <- parseCmmHint $1;
568	return $ do
569	e <- $2; return (CmmHinted e h) }
570
571	local_lreg :: { ExtFCode LocalReg }
572	: NAME { do e <- lookupName $1;
573	return $
574	case e of
575	CmmReg (CmmLocal r) -> r
576	other -> pprPanic "CmmParse:" (ftext $1 <> text " not a local register") }
577
578	lreg :: { ExtFCode CmmReg }
579	: NAME { do e <- lookupName $1;
580	return $
581	case e of
582	CmmReg r -> r
583	other -> pprPanic "CmmParse:" (ftext $1 <> text " not a register") }
584	\| GLOBALREG { return (CmmGlobal $1) }
585
586	maybe_formals_without_hints :: { [ExtFCode LocalReg] }
587	: {- empty -} { [] }
588	\| '(' formals_without_hints0 ')' { $2 }
589
590	formals_without_hints0 :: { [ExtFCode LocalReg] }
591	: {- empty -} { [] }
592	\| formals_without_hints { $1 }
593
594	formals_without_hints :: { [ExtFCode LocalReg] }
595	: formal_without_hint ',' { [$1] }
596	\| formal_without_hint { [$1] }
597	\| formal_without_hint ',' formals_without_hints { $1 : $3 }
598
599	formal_without_hint :: { ExtFCode LocalReg }
600	: type NAME { newLocal $1 $2 }
601
602	maybe_frame :: { ExtFCode (Maybe UpdateFrame) }
603	: {- empty -} { return Nothing }
604	\| 'jump' expr '(' exprs0 ')' { do { target <- $2;
605	args <- sequence $4;
606	return $ Just (UpdateFrame target args) } }
607
608	maybe_gc_block :: { ExtFCode (Maybe BlockId) }
609	: {- empty -} { return Nothing }
610	\| 'goto' NAME
611	{ do l <- lookupLabel $2; return (Just l) }
612
613	type :: { CmmType }
614	: 'bits8' { b8 }
615	\| typenot8 { $1 }
616
617	typenot8 :: { CmmType }
618	: 'bits16' { b16 }
619	\| 'bits32' { b32 }
620	\| 'bits64' { b64 }
621	\| 'float32' { f32 }
622	\| 'float64' { f64 }
623	\| 'gcptr' { gcWord }
624	{
625	section :: String -> Section
626	section "text" = Text
627	section "data" = Data
628	section "rodata" = ReadOnlyData
629	section "relrodata" = RelocatableReadOnlyData
630	section "bss" = UninitialisedData
631	section s = OtherSection s
632
633	mkString :: String -> CmmStatic
634	mkString s = CmmString (map (fromIntegral.ord) s)
635
636	-- mkMachOp infers the type of the MachOp from the type of its first
637	-- argument. We assume that this is correct: for MachOps that don't have
638	-- symmetrical args (e.g. shift ops), the first arg determines the type of
639	-- the op.
640	mkMachOp :: (Width -> MachOp) -> [ExtFCode CmmExpr] -> ExtFCode CmmExpr
641	mkMachOp fn args = do
642	arg_exprs <- sequence args
643	return (CmmMachOp (fn (typeWidth (cmmExprType (head arg_exprs)))) arg_exprs)
644
645	getLit :: CmmExpr -> CmmLit
646	getLit (CmmLit l) = l
647	getLit (CmmMachOp (MO_S_Neg _) [CmmLit (CmmInt i r)]) = CmmInt (negate i) r
648	getLit _ = panic "invalid literal" -- TODO messy failure
649
650	nameToMachOp :: FastString -> P (Width -> MachOp)
651	nameToMachOp name =
652	case lookupUFM machOps name of
653	Nothing -> fail ("unknown primitive " ++ unpackFS name)
654	Just m -> return m
655
656	exprOp :: FastString -> [ExtFCode CmmExpr] -> P (ExtFCode CmmExpr)
657	exprOp name args_code =
658	case lookupUFM exprMacros name of
659	Just f -> return $ do
660	args <- sequence args_code
661	return (f args)
662	Nothing -> do
663	mo <- nameToMachOp name
664	return $ mkMachOp mo args_code
665
666	exprMacros :: UniqFM ([CmmExpr] -> CmmExpr)
667	exprMacros = listToUFM [
668	( fsLit "ENTRY_CODE", \ [x] -> entryCode x ),
669	( fsLit "INFO_PTR", \ [x] -> closureInfoPtr x ),
670	( fsLit "STD_INFO", \ [x] -> infoTable x ),
671	( fsLit "FUN_INFO", \ [x] -> funInfoTable x ),
672	( fsLit "GET_ENTRY", \ [x] -> entryCode (closureInfoPtr x) ),
673	( fsLit "GET_STD_INFO", \ [x] -> infoTable (closureInfoPtr x) ),
674	( fsLit "GET_FUN_INFO", \ [x] -> funInfoTable (closureInfoPtr x) ),
675	( fsLit "INFO_TYPE", \ [x] -> infoTableClosureType x ),
676	( fsLit "INFO_PTRS", \ [x] -> infoTablePtrs x ),
677	( fsLit "INFO_NPTRS", \ [x] -> infoTableNonPtrs x )
678	]
679
680	-- we understand a subset of C-- primitives:
681	machOps = listToUFM $
682	map (\(x, y) -> (mkFastString x, y)) [
683	( "add", MO_Add ),
684	( "sub", MO_Sub ),
685	( "eq", MO_Eq ),
686	( "ne", MO_Ne ),
687	( "mul", MO_Mul ),
688	( "neg", MO_S_Neg ),
689	( "quot", MO_S_Quot ),
690	( "rem", MO_S_Rem ),
691	( "divu", MO_U_Quot ),
692	( "modu", MO_U_Rem ),
693
694	( "ge", MO_S_Ge ),
695	( "le", MO_S_Le ),
696	( "gt", MO_S_Gt ),
697	( "lt", MO_S_Lt ),
698
699	( "geu", MO_U_Ge ),
700	( "leu", MO_U_Le ),
701	( "gtu", MO_U_Gt ),
702	( "ltu", MO_U_Lt ),
703
704	( "and", MO_And ),
705	( "or", MO_Or ),
706	( "xor", MO_Xor ),
707	( "com", MO_Not ),
708	( "shl", MO_Shl ),
709	( "shrl", MO_U_Shr ),
710	( "shra", MO_S_Shr ),
711
712	( "fadd", MO_F_Add ),
713	( "fsub", MO_F_Sub ),
714	( "fneg", MO_F_Neg ),
715	( "fmul", MO_F_Mul ),
716	( "fquot", MO_F_Quot ),
717
718	( "feq", MO_F_Eq ),
719	( "fne", MO_F_Ne ),
720	( "fge", MO_F_Ge ),
721	( "fle", MO_F_Le ),
722	( "fgt", MO_F_Gt ),
723	( "flt", MO_F_Lt ),
724
725	( "lobits8", flip MO_UU_Conv W8 ),
726	( "lobits16", flip MO_UU_Conv W16 ),
727	( "lobits32", flip MO_UU_Conv W32 ),
728	( "lobits64", flip MO_UU_Conv W64 ),
729
730	( "zx16", flip MO_UU_Conv W16 ),
731	( "zx32", flip MO_UU_Conv W32 ),
732	( "zx64", flip MO_UU_Conv W64 ),
733
734	( "sx16", flip MO_SS_Conv W16 ),
735	( "sx32", flip MO_SS_Conv W32 ),
736	( "sx64", flip MO_SS_Conv W64 ),
737
738	( "f2f32", flip MO_FF_Conv W32 ), -- TODO; rounding mode
739	( "f2f64", flip MO_FF_Conv W64 ), -- TODO; rounding mode
740	( "f2i8", flip MO_FS_Conv W8 ),
741	( "f2i16", flip MO_FS_Conv W16 ),
742	( "f2i32", flip MO_FS_Conv W32 ),
743	( "f2i64", flip MO_FS_Conv W64 ),
744	( "i2f32", flip MO_SF_Conv W32 ),
745	( "i2f64", flip MO_SF_Conv W64 )
746	]
747
748	callishMachOps = listToUFM $
749	map (\(x, y) -> (mkFastString x, y)) [
750	( "write_barrier", MO_WriteBarrier ),
751	( "memcpy", MO_Memcpy ),
752	( "memset", MO_Memset ),
753	( "memmove", MO_Memmove )
754	-- ToDo: the rest, maybe
755	]
756
757	parseSafety :: String -> P CmmSafety
758	parseSafety "safe" = return (CmmSafe NoC_SRT)
759	parseSafety "unsafe" = return CmmUnsafe
760	parseSafety "interruptible" = return CmmInterruptible
761	parseSafety str = fail ("unrecognised safety: " ++ str)
762
763	parseCmmHint :: String -> P ForeignHint
764	parseCmmHint "ptr" = return AddrHint
765	parseCmmHint "signed" = return SignedHint
766	parseCmmHint str = fail ("unrecognised hint: " ++ str)
767
768	-- labels are always pointers, so we might as well infer the hint
769	inferCmmHint :: CmmExpr -> ForeignHint
770	inferCmmHint (CmmLit (CmmLabel _)) = AddrHint
771	inferCmmHint (CmmReg (CmmGlobal g)) \| isPtrGlobalReg g = AddrHint
772	inferCmmHint _ = NoHint
773
774	isPtrGlobalReg Sp = True
775	isPtrGlobalReg SpLim = True
776	isPtrGlobalReg Hp = True
777	isPtrGlobalReg HpLim = True
778	isPtrGlobalReg CCCS = True
779	isPtrGlobalReg CurrentTSO = True
780	isPtrGlobalReg CurrentNursery = True
781	isPtrGlobalReg (VanillaReg _ VGcPtr) = True
782	isPtrGlobalReg _ = False
783
784	happyError :: P a
785	happyError = srcParseFail
786
787	-- -----------------------------------------------------------------------------
788	-- Statement-level macros
789
790	stmtMacro :: FastString -> [ExtFCode CmmExpr] -> P ExtCode
791	stmtMacro fun args_code = do
792	case lookupUFM stmtMacros fun of
793	Nothing -> fail ("unknown macro: " ++ unpackFS fun)
794	Just fcode -> return $ do
795	args <- sequence args_code
796	code (fcode args)
797
798	stmtMacros :: UniqFM ([CmmExpr] -> Code)
799	stmtMacros = listToUFM [
800	( fsLit "CCS_ALLOC", \[words,ccs] -> profAlloc words ccs ),
801	( fsLit "CLOSE_NURSERY", \[] -> emitCloseNursery ),
802	( fsLit "ENTER_CCS_THUNK", \[e] -> enterCostCentreThunk e ),
803	( fsLit "HP_CHK_GEN", \[words,liveness,reentry] ->
804	hpChkGen words liveness reentry ),
805	( fsLit "HP_CHK_NP_ASSIGN_SP0", \[e,f] -> hpChkNodePointsAssignSp0 e f ),
806	( fsLit "LOAD_THREAD_STATE", \[] -> emitLoadThreadState ),
807	( fsLit "LDV_ENTER", \[e] -> ldvEnter e ),
808	( fsLit "LDV_RECORD_CREATE", \[e] -> ldvRecordCreate e ),
809	( fsLit "OPEN_NURSERY", \[] -> emitOpenNursery ),
810	( fsLit "PUSH_UPD_FRAME", \[sp,e] -> emitPushUpdateFrame sp e ),
811	( fsLit "SAVE_THREAD_STATE", \[] -> emitSaveThreadState ),
812	( fsLit "SET_HDR", \[ptr,info,ccs] ->
813	emitSetDynHdr ptr info ccs ),
814	( fsLit "STK_CHK_GEN", \[words,liveness,reentry] ->
815	stkChkGen words liveness reentry ),
816	( fsLit "STK_CHK_NP", \[e] -> stkChkNodePoints e ),
817	( fsLit "TICK_ALLOC_PRIM", \[hdr,goods,slop] ->
818	tickyAllocPrim hdr goods slop ),
819	( fsLit "TICK_ALLOC_PAP", \[goods,slop] ->
820	tickyAllocPAP goods slop ),
821	( fsLit "TICK_ALLOC_UP_THK", \[goods,slop] ->
822	tickyAllocThunk goods slop ),
823	( fsLit "UPD_BH_UPDATABLE", \[] -> emitBlackHoleCode False ),
824	( fsLit "UPD_BH_SINGLE_ENTRY", \[] -> emitBlackHoleCode True ),
825
826	( fsLit "RET_P", \[a] -> emitRetUT [(PtrArg,a)]),
827	( fsLit "RET_N", \[a] -> emitRetUT [(NonPtrArg,a)]),
828	( fsLit "RET_PP", \[a,b] -> emitRetUT [(PtrArg,a),(PtrArg,b)]),
829	( fsLit "RET_NN", \[a,b] -> emitRetUT [(NonPtrArg,a),(NonPtrArg,b)]),
830	( fsLit "RET_NP", \[a,b] -> emitRetUT [(NonPtrArg,a),(PtrArg,b)]),
831	( fsLit "RET_PPP", \[a,b,c] -> emitRetUT [(PtrArg,a),(PtrArg,b),(PtrArg,c)]),
832	( fsLit "RET_NPP", \[a,b,c] -> emitRetUT [(NonPtrArg,a),(PtrArg,b),(PtrArg,c)]),
833	( fsLit "RET_NNP", \[a,b,c] -> emitRetUT [(NonPtrArg,a),(NonPtrArg,b),(PtrArg,c)]),
834	( fsLit "RET_NNN", \[a,b,c] -> emitRetUT [(NonPtrArg,a),(NonPtrArg,b),(NonPtrArg,c)]),
835	( fsLit "RET_NNNN", \[a,b,c,d] -> emitRetUT [(NonPtrArg,a),(NonPtrArg,b),(NonPtrArg,c),(NonPtrArg,d)]),
836	( fsLit "RET_NNNP", \[a,b,c,d] -> emitRetUT [(NonPtrArg,a),(NonPtrArg,b),(NonPtrArg,c),(PtrArg,d)]),
837	( fsLit "RET_NPNP", \[a,b,c,d] -> emitRetUT [(NonPtrArg,a),(PtrArg,b),(NonPtrArg,c),(PtrArg,d)])
838
839	]
840
841
842	profilingInfo desc_str ty_str
843	\| not opt_SccProfilingOn = NoProfilingInfo
844	\| otherwise = ProfilingInfo (stringToWord8s desc_str)
845	(stringToWord8s ty_str)
846
847	staticClosure :: PackageId -> FastString -> FastString -> [CmmLit] -> ExtCode
848	staticClosure pkg cl_label info payload
849	= code $ emitDataLits (mkCmmDataLabel pkg cl_label) lits
850	where lits = mkStaticClosure (mkCmmInfoLabel pkg info) dontCareCCS payload [] [] []
851
852	foreignCall
853	:: String
854	-> [ExtFCode HintedCmmFormal]
855	-> ExtFCode CmmExpr
856	-> [ExtFCode HintedCmmActual]
857	-> Maybe [GlobalReg]
858	-> CmmSafety
859	-> CmmReturnInfo
860	-> P ExtCode
861	foreignCall conv_string results_code expr_code args_code vols safety ret
862	= do convention <- case conv_string of
863	"C" -> return CCallConv
864	"stdcall" -> return StdCallConv
865	"C--" -> return CmmCallConv
866	_ -> fail ("unknown calling convention: " ++ conv_string)
867	return $ do
868	results <- sequence results_code
869	expr <- expr_code
870	args <- sequence args_code
871	case convention of
872	-- Temporary hack so at least some functions are CmmSafe
873	CmmCallConv -> code (stmtC (CmmCall (CmmCallee expr convention) results args ret))
874	_ ->
875	let expr' = adjCallTarget convention expr args in
876	case safety of
877	CmmUnsafe ->
878	code (emitForeignCall' PlayRisky results
879	(CmmCallee expr' convention) args vols NoC_SRT ret)
880	CmmSafe srt ->
881	code (emitForeignCall' PlaySafe results
882	(CmmCallee expr' convention) args vols NoC_SRT ret) where
883	CmmInterruptible ->
884	code (emitForeignCall' PlayInterruptible results
885	(CmmCallee expr' convention) args vols NoC_SRT ret)
886
887	adjCallTarget :: CCallConv -> CmmExpr -> [CmmHinted CmmExpr] -> CmmExpr
888	#ifdef mingw32_TARGET_OS
889	-- On Windows, we have to add the '@N' suffix to the label when making
890	-- a call with the stdcall calling convention.
891	adjCallTarget StdCallConv (CmmLit (CmmLabel lbl)) args
892	= CmmLit (CmmLabel (addLabelSize lbl (sum (map size args))))
893	where size (CmmHinted e _) = max wORD_SIZE (widthInBytes (typeWidth (cmmExprType e)))
894	-- c.f. CgForeignCall.emitForeignCall
895	#endif
896	adjCallTarget _ expr _
897	= expr
898
899	primCall
900	:: [ExtFCode HintedCmmFormal]
901	-> FastString
902	-> [ExtFCode HintedCmmActual]
903	-> Maybe [GlobalReg]
904	-> CmmSafety
905	-> P ExtCode
906	primCall results_code name args_code vols safety
907	= case lookupUFM callishMachOps name of
908	Nothing -> fail ("unknown primitive " ++ unpackFS name)
909	Just p -> return $ do
910	results <- sequence results_code
911	args <- sequence args_code
912	case safety of
913	CmmUnsafe ->
914	code (emitForeignCall' PlayRisky results
915	(CmmPrim p Nothing) args vols NoC_SRT CmmMayReturn)
916	CmmSafe srt ->
917	code (emitForeignCall' PlaySafe results
918	(CmmPrim p Nothing) args vols NoC_SRT CmmMayReturn) where
919	CmmInterruptible ->
920	code (emitForeignCall' PlayInterruptible results
921	(CmmPrim p Nothing) args vols NoC_SRT CmmMayReturn)
922
923	doStore :: CmmType -> ExtFCode CmmExpr -> ExtFCode CmmExpr -> ExtCode
924	doStore rep addr_code val_code
925	= do addr <- addr_code
926	val <- val_code
927	-- if the specified store type does not match the type of the expr
928	-- on the rhs, then we insert a coercion that will cause the type
929	-- mismatch to be flagged by cmm-lint. If we don't do this, then
930	-- the store will happen at the wrong type, and the error will not
931	-- be noticed.
932	let val_width = typeWidth (cmmExprType val)
933	rep_width = typeWidth rep
934	let coerce_val
935	\| val_width /= rep_width = CmmMachOp (MO_UU_Conv val_width rep_width) [val]
936	\| otherwise = val
937	stmtEC (CmmStore addr coerce_val)
938
939	-- Return an unboxed tuple.
940	emitRetUT :: [(CgRep,CmmExpr)] -> Code
941	emitRetUT args = do
942	tickyUnboxedTupleReturn (length args) -- TICK
943	(sp, stmts, live) <- pushUnboxedTuple 0 args
944	emitSimultaneously stmts -- NB. the args might overlap with the stack slots
945	-- or regs that we assign to, so better use
946	-- simultaneous assignments here (#3546)
947	when (sp /= 0) $ stmtC (CmmAssign spReg (cmmRegOffW spReg (-sp)))
948	stmtC $ CmmJump (entryCode (CmmLoad (cmmRegOffW spReg sp) bWord)) (Just live)
949
950	-- -----------------------------------------------------------------------------
951	-- If-then-else and boolean expressions
952
953	data BoolExpr
954	= BoolExpr `BoolAnd` BoolExpr
955	\| BoolExpr `BoolOr` BoolExpr
956	\| BoolNot BoolExpr
957	\| BoolTest CmmExpr
958
959	-- ToDo: smart constructors which simplify the boolean expression.
960
961	cmmIfThenElse cond then_part else_part = do
962	then_id <- code newLabelC
963	join_id <- code newLabelC
964	c <- cond
965	emitCond c then_id
966	else_part
967	stmtEC (CmmBranch join_id)
968	code (labelC then_id)
969	then_part
970	-- fall through to join
971	code (labelC join_id)
972
973	cmmRawIf cond then_id = do
974	c <- cond
975	emitCond c then_id
976
977	-- 'emitCond cond true_id' emits code to test whether the cond is true,
978	-- branching to true_id if so, and falling through otherwise.
979	emitCond (BoolTest e) then_id = do
980	stmtEC (CmmCondBranch e then_id)
981	emitCond (BoolNot (BoolTest (CmmMachOp op args))) then_id
982	\| Just op' <- maybeInvertComparison op
983	= emitCond (BoolTest (CmmMachOp op' args)) then_id
984	emitCond (BoolNot e) then_id = do
985	else_id <- code newLabelC
986	emitCond e else_id
987	stmtEC (CmmBranch then_id)
988	code (labelC else_id)
989	emitCond (e1 `BoolOr` e2) then_id = do
990	emitCond e1 then_id
991	emitCond e2 then_id
992	emitCond (e1 `BoolAnd` e2) then_id = do
993	-- we'd like to invert one of the conditionals here to avoid an
994	-- extra branch instruction, but we can't use maybeInvertComparison
995	-- here because we can't look too closely at the expression since
996	-- we're in a loop.
997	and_id <- code newLabelC
998	else_id <- code newLabelC
999	emitCond e1 and_id
1000	stmtEC (CmmBranch else_id)
1001	code (labelC and_id)
1002	emitCond e2 then_id
1003	code (labelC else_id)
1004
1005
1006	-- -----------------------------------------------------------------------------
1007	-- Table jumps
1008
1009	-- We use a simplified form of C-- switch statements for now. A
1010	-- switch statement always compiles to a table jump. Each arm can
1011	-- specify a list of values (not ranges), and there can be a single
1012	-- default branch. The range of the table is given either by the
1013	-- optional range on the switch (eg. switch [0..7] {...}), or by
1014	-- the minimum/maximum values from the branches.
1015
1016	doSwitch :: Maybe (Int,Int) -> ExtFCode CmmExpr -> [([Int],Either BlockId ExtCode)]
1017	-> Maybe ExtCode -> ExtCode
1018	doSwitch mb_range scrut arms deflt
1019	= do
1020	-- Compile code for the default branch
1021	dflt_entry <-
1022	case deflt of
1023	Nothing -> return Nothing
1024	Just e -> do b <- forkLabelledCodeEC e; return (Just b)
1025
1026	-- Compile each case branch
1027	table_entries <- mapM emitArm arms
1028
1029	-- Construct the table
1030	let
1031	all_entries = concat table_entries
1032	ixs = map fst all_entries
1033	(min,max)
1034	\| Just (l,u) <- mb_range = (l,u)
1035	\| otherwise = (minimum ixs, maximum ixs)
1036
1037	entries = elems (accumArray (\_ a -> Just a) dflt_entry (min,max)
1038	all_entries)
1039	expr <- scrut
1040	-- ToDo: check for out of range and jump to default if necessary
1041	stmtEC (CmmSwitch expr entries)
1042	where
1043	emitArm :: ([Int],Either BlockId ExtCode) -> ExtFCode [(Int,BlockId)]
1044	emitArm (ints,Left blockid) = return [ (i,blockid) \| i <- ints ]
1045	emitArm (ints,Right code) = do
1046	blockid <- forkLabelledCodeEC code
1047	return [ (i,blockid) \| i <- ints ]
1048
1049	-- -----------------------------------------------------------------------------
1050	-- Putting it all together
1051
1052	-- The initial environment: we define some constants that the compiler
1053	-- knows about here.
1054	initEnv :: Env
1055	initEnv = listToUFM [
1056	( fsLit "SIZEOF_StgHeader",
1057	VarN (CmmLit (CmmInt (fromIntegral (fixedHdrSize * wORD_SIZE)) wordWidth) )),
1058	( fsLit "SIZEOF_StgInfoTable",
1059	VarN (CmmLit (CmmInt (fromIntegral stdInfoTableSizeB) wordWidth) ))
1060	]
1061
1062	parseCmmFile :: DynFlags -> FilePath -> IO (Messages, Maybe CmmGroup)
1063	parseCmmFile dflags filename = do
1064	showPass dflags "ParseCmm"
1065	buf <- hGetStringBuffer filename
1066	let
1067	init_loc = mkRealSrcLoc (mkFastString filename) 1 1
1068	init_state = (mkPState dflags buf init_loc) { lex_state = [0] }
1069	-- reset the lex_state: the Lexer monad leaves some stuff
1070	-- in there we don't want.
1071	case unP cmmParse init_state of
1072	PFailed span err -> do
1073	let msg = mkPlainErrMsg span err
1074	return ((emptyBag, unitBag msg), Nothing)
1075	POk pst code -> do
1076	cmm <- initC dflags no_module (getCmm (unEC code initEnv [] >> return ()))
1077	let ms = getMessages pst
1078	if (errorsFound dflags ms)
1079	then return (ms, Nothing)
1080	else do
1081	dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (pprPlatform (targetPlatform dflags) cmm)
1082	return (ms, Just cmm)
1083	where
1084	no_module = panic "parseCmmFile: no module"
1085	}

Note: See TracBrowser for help on using the browser.

Download in other formats:

Original Format