Annotation of /sml/trunk/src/compiler/FLINT/flint/ppflint.sml

Parent Directory | Revision Log

---

Revision 251 - (view) (download)

1 :	monnier	16	(* COPYRIGHT (c) 1997 YALE FLINT PROJECT *)
2 :			(* ppflint.sml -- Pretty printer for Flint IL. *)
3 :
4 :
5 :			structure PPFlint :> PPFLINT =
6 :			struct
7 :			(** frequently used structures *)
8 :			structure F = FLINT
9 :	monnier	47	structure FU = FlintUtil
10 :	monnier	16	structure S = Symbol
11 :			structure LV = LambdaVar
12 :			structure LT = LtyExtern
13 :			structure PO = PrimOp
14 :			structure PU = PrintUtil
15 :	monnier	220	structure CTRL = Control.FLINT
16 :	monnier	16
17 :			(** some print utilities **)
18 :	monnier	220	val say = Control_Print.say
19 :	monnier	16	val margin = ref 0
20 :			exception Undent
21 :			fun indent n = margin := !margin + n
22 :			fun undent n = (margin := !margin - n;
23 :			if !margin < 0 then raise Undent
24 :			else ())
25 :			fun dent () = PU.tab(!margin)
26 :			val newline = PU.newline
27 :
28 :			infix &
29 :			fun op& (f1,f2) () = (f1(); f2())
30 :
31 :	monnier	47	fun toStringFFlag ff =
32 :			let fun h b = if b then "r" else "c"
33 :			in LT.ffw_var (ff, fn (b1,b2) => (h b1)^(h b2), fn _ => "f")
34 :			end
35 :	monnier	24
36 :	monnier	185	fun toStringFKind ({isrec,cconv,inline,...}:F.fkind) =
37 :			(case inline of F.IH_ALWAYS => "(i)"
38 :			| F.IH_UNROLL => "(u)"
39 :	monnier	202	| F.IH_MAYBE(s,ws) => "(i:"^(Int.toString s)^")"
40 :	monnier	185	| F.IH_SAFE => "")^
41 :	monnier	191	(case isrec
42 :			of SOME(_,F.LK_UNKNOWN) => "R"
43 :	monnier	199	| SOME(_,F.LK_LOOP) => "LR"
44 :			| SOME(_,F.LK_TAIL) => "TR"
45 :	monnier	191	| NONE => "")^
46 :	monnier	185	(case cconv
47 :			of F.CC_FCT => "FCT"
48 :			| F.CC_FUN fixed => ("FUN "^(toStringFFlag fixed)))
49 :
50 :	monnier	16	(*
51 :			fun toStringFKind F.FK_ESCAPE = "FK_ESCAPE"
52 :			| toStringFKind F.FK_KNOWN = "FK_KNOWN"
53 :			| toStringFKind F.FK_KREC = "FK_KREC"
54 :			| toStringFKind F.FK_KTAIL = "FK_KTAIL"
55 :			| toStringFKind F.FK_NOINL = "FK_NOINL"
56 :			| toStringFKind F.FK_HANDLER = "FK_HANDLER"
57 :			*)
58 :
59 :			val printFKind = say o toStringFKind
60 :
61 :			(** classifications of various kinds of records *)
62 :			fun toStringRKind (F.RK_VECTOR tyc) = "VECTOR[" ^ LT.tc_print tyc ^ "]"
63 :			| toStringRKind F.RK_STRUCT = "STRUCT"
64 :	monnier	47	| toStringRKind (F.RK_TUPLE _) = "RECORD"
65 :	monnier	16
66 :			val printRKind = say o toStringRKind
67 :
68 :			(** con: used to specify all possible switching statements. *)
69 :			fun toStringCon (F.DATAcon((symbol,_,_),_,_)) = S.name symbol
70 :			| toStringCon (F.INTcon i) = "(I)" ^ (Int.toString i)
71 :			| toStringCon (F.INT32con i) = "(I32)" ^ (Int32.toString i)
72 :			| toStringCon (F.WORDcon i) = "(W)" ^ (Word.toString i)
73 :			| toStringCon (F.WORD32con i) = "(W32)" ^ (Word32.toString i)
74 :			| toStringCon (F.REALcon r) = r
75 :			| toStringCon (F.STRINGcon s) = PU.mlstr s
76 :			| toStringCon (F.VLENcon n) = Int.toString n
77 :
78 :			val printCon = say o toStringCon
79 :
80 :			(** simple values, including variables and static constants. *)
81 :			fun toStringValue (F.VAR v) = LV.lvarName v
82 :			| toStringValue (F.INT i) = "(I)" ^ Int.toString i
83 :			| toStringValue (F.INT32 i) = "(I32)" ^ Int32.toString i
84 :			| toStringValue (F.WORD i) = "(W)" ^ Word.toString i
85 :			| toStringValue (F.WORD32 i) = "(W32)" ^ Word32.toString i
86 :			| toStringValue (F.REAL r) = r
87 :			| toStringValue (F.STRING s) = PU.mlstr s
88 :
89 :			val printSval = say o toStringValue
90 :	monnier	40	val LVarString = ref LV.lvarName
91 :	monnier	16
92 :	monnier	40	fun printVar v = say (!LVarString v)
93 :	monnier	16	val printTyc = say o LT.tc_print
94 :			val printLty = say o LT.lt_print
95 :			fun printTvTk (tv:LT.tvar,tk) =
96 :	monnier	197	say ((LV.lvarName tv)^":"^(LT.tk_print tk))
97 :	monnier	16
98 :			val parenCommaSep = ("(", ",", ")")
99 :			val printValList = PU.printClosedSequence ("[",",","]") printSval
100 :			val printVarList = PU.printClosedSequence ("[",",","]") printVar
101 :			val printTycList = PU.printClosedSequence ("[",",","]") printTyc
102 :	monnier	220	val printLtyList = PU.printClosedSequence ("[",",","]") printLty
103 :	monnier	16	val printTvTkList = PU.printClosedSequence ("[",",","]") printTvTk
104 :
105 :	monnier	47	fun printDecon (F.DATAcon((_,Access.CONSTANT _,_),_,_)) = ()
106 :			(* WARNING: a hack, but then what about constant exceptions ? *)
107 :			| printDecon (F.DATAcon((symbol,conrep,lty),tycs,lvar)) =
108 :			(* <lvar> = DECON(<symbol>,<conrep>,<lty>,[<tycs>]) *)
109 :			(printVar lvar;
110 :	monnier	16	say " = DECON(";
111 :			say (S.name symbol); say ",";
112 :			say (Access.prRep conrep); say ",";
113 :			printLty lty; say ",";
114 :			printTycList tycs; say ")";
115 :			newline(); dent())
116 :			| printDecon _ = ()
117 :
118 :	monnier	47	fun appPrint prfun sepfun [] = ()
119 :			| appPrint prfun sepfun (x::xs) =
120 :			(prfun x; app (fn y => (sepfun(); prfun y)) xs)
121 :
122 :	monnier	16	(** the definitions of the lambda expressions *)
123 :
124 :			fun complex (F.LET _) = true
125 :			| complex (F.FIX _) = true
126 :			| complex (F.TFN _) = true
127 :			| complex (F.SWITCH _) = true
128 :			| complex (F.CON _) = true
129 :			| complex (F.HANDLE _) = true
130 :			| complex _ = false
131 :
132 :			fun pLexp (F.RET values) =
133 :			(* RETURN [values] *)
134 :			(say "RETURN "; printValList values)
135 :
136 :			| pLexp (F.APP (f, args)) =
137 :			(* APP(f, [args]) *)
138 :			(say "APP(";
139 :			printSval f;
140 :			say ",";
141 :			printValList args;
142 :			say ")")
143 :
144 :			| pLexp (F.TAPP (tf, tycs)) =
145 :			(* TAPP(tf, [tycs]) *)
146 :			(say "TAPP(";
147 :			printSval tf;
148 :			say ",";
149 :			printTycList tycs;
150 :			say ")")
151 :
152 :			| pLexp (F.LET (vars, lexp, body)) =
153 :			(* [vars] = lexp OR [vars] =
154 :			* body lexp
155 :			* body
156 :			*)
157 :			(printVarList vars; say " = ";
158 :			if complex lexp then
159 :			(indent 2; newline(); dent(); pLexp lexp; undent 2)
160 :			else
161 :			let val len = (3 (* for the " = " *)
162 :			+ 2 (* for the "[]" *)
163 :			+ (length vars) (* for each comma *)
164 :			+ (foldl (* sum of varname lengths *)
165 :	monnier	40	(fn (v,n) => n + (size (!LVarString v)))
166 :	monnier	16	0 vars))
167 :			in
168 :			indent len; pLexp lexp; undent len
169 :			end;
170 :			newline(); dent(); pLexp body)
171 :
172 :			| pLexp (F.FIX (fundecs, body)) =
173 :			(* FIX(<fundec1>,
174 :			* <fundec2>,
175 :			* <fundec3>)
176 :			* <body>
177 :			*)
178 :			(say "FIX(";
179 :			indent 4;
180 :			appPrint printFundec (newline & dent) fundecs;
181 :			undent 4; say ")"; newline();
182 :			dent();
183 :			pLexp body)
184 :
185 :	monnier	220	| pLexp (F.TFN ((tfk as {inline,...}, lvar, tv_tk_list, tfnbody), body)) =
186 :	monnier	16	(* v =
187 :			* TFN([tk],lty,
188 :			* <tfnbody>)
189 :			* <body>
190 :			*)
191 :			(printVar lvar; say " = "; newline();
192 :			indent 2; dent();
193 :	monnier	220	if inline = F.IH_SAFE then () else say "i"; say "TFN(";
194 :	monnier	16	printTvTkList tv_tk_list; say ",";
195 :			(*** printLty lty; say ","; *** lty no longer available ***)
196 :			newline();
197 :			indent 2;
198 :			dent();
199 :			pLexp tfnbody;
200 :			undent 4; say ")"; newline();
201 :			dent();
202 :			pLexp body)
203 :
204 :			(** NOTE: I'm ignoring the consig here **)
205 :			| pLexp (F.SWITCH (value, consig, con_lexp_list, lexpOption)) =
206 :			(* SWITCH <value>
207 :			* <con> =>
208 :			* <lexp>
209 :			* <con> =>
210 :			* <lexp>
211 :			*)
212 :			(say "SWITCH "; printSval value; newline();
213 :			indent 2; dent();
214 :			appPrint printCase (newline & dent) con_lexp_list;
215 :			case lexpOption of
216 :			NONE => ()
217 :			| SOME lexp => (* default case *)
218 :			(newline(); dent(); say "_ => ";
219 :			indent 4; newline(); dent();
220 :			pLexp lexp; undent 4);
221 :			undent 2)
222 :
223 :	monnier	47	| pLexp (F.CON ((symbol,_,_), tycs, value, lvar, body)) =
224 :			(* <lvar> = CON(<symbol>, <tycs>, <value>)
225 :	monnier	16	* <body>
226 :			*)
227 :			(printVar lvar; say " = CON(";
228 :			say (S.name symbol); say ", ";
229 :			printTycList tycs; say ", ";
230 :	monnier	47	printSval value; say ")";
231 :	monnier	16	newline(); dent(); pLexp body)
232 :
233 :			| pLexp (F.RECORD (rkind, values, lvar, body)) =
234 :			(* <lvar> = RECORD(<rkind>, <values>)
235 :			* <body>
236 :			*)
237 :			(printVar lvar; say " = ";
238 :			printRKind rkind; say " ";
239 :			printValList values;
240 :			newline(); dent(); pLexp body)
241 :
242 :			| pLexp (F.SELECT (value, int, lvar, body)) =
243 :			(* <lvar> = SELECT(<value>, <int>)
244 :			* <body>
245 :			*)
246 :			(printVar lvar; say " = SELECT(";
247 :			printSval value; say ", ";
248 :			say (Int.toString int); say ")";
249 :			newline(); dent(); pLexp body)
250 :
251 :			| pLexp (F.RAISE (value, ltys)) =
252 :			(* NOTE: I'm ignoring the lty list here. It is the return type
253 :	monnier	47	* of the raise expression. (ltys temporarily being printed --v)
254 :	monnier	16	*)
255 :			(* RAISE(<value>) *)
256 :			(say "RAISE(";
257 :	monnier	47	printSval value; say ") : "; printLtyList ltys)
258 :	monnier	16
259 :			| pLexp (F.HANDLE (body, value)) =
260 :			(* <body>
261 :			* HANDLE(<value>)
262 :			*)
263 :			(pLexp body;
264 :			newline(); dent();
265 :			say "HANDLE("; printSval value; say ")")
266 :	monnier	47
267 :			| pLexp (F.BRANCH ((d, primop, lty, tycs), values, body1, body2)) =
268 :	monnier	71	(* IF PRIM(<primop>, <lty>, [<tycs>]) [<values>]
269 :			* THEN
270 :	monnier	47	* <body1>
271 :			* ELSE
272 :			* <body2>
273 :	monnier	16	*)
274 :	monnier	47	((case d of NONE => say "IF PRIMOP("
275 :			| _ => say "IF GENOP(");
276 :	monnier	16	say (PO.prPrimop primop); say ", ";
277 :			printLty lty; say ", ";
278 :			printTycList tycs; say ") ";
279 :	monnier	71	printValList values; newline();
280 :			dent();
281 :			appPrint printBranch (newline & dent)
282 :			[("THEN", body1), ("ELSE", body2)])
283 :	monnier	16
284 :	monnier	47	| pLexp (F.PRIMOP (p as (_, PO.MKETAG, _, _), [value], lvar, body)) =
285 :			(* <lvar> = ETAG(<value>[<tyc>])
286 :	monnier	16	* <body>
287 :			*)
288 :	monnier	47	(printVar lvar; say " = ETAG(";
289 :			printSval value; say "[";
290 :			printTyc (FU.getEtagTyc p); say "])";
291 :	monnier	16	newline(); dent(); pLexp body)
292 :	monnier	47
293 :			| pLexp (F.PRIMOP (p as (_, PO.WRAP, _, _), [value], lvar, body)) =
294 :	monnier	16	(* <lvar> = WRAP(<tyc>, <value>)
295 :			* <body>
296 :			*)
297 :			(printVar lvar; say " = WRAP(";
298 :	monnier	47	printTyc (FU.getWrapTyc p); say ", ";
299 :	monnier	16	printSval value; say ")";
300 :			newline(); dent(); pLexp body)
301 :	monnier	47
302 :			| pLexp (F.PRIMOP (p as (_, PO.UNWRAP, _, []), [value], lvar, body)) =
303 :	monnier	16	(* <lvar> = UNWRAP(<tyc>, <value>)
304 :			* <body>
305 :			*)
306 :			(printVar lvar; say " = UNWRAP(";
307 :	monnier	47	printTyc (FU.getUnWrapTyc p); say ", ";
308 :	monnier	16	printSval value; say ")";
309 :			newline(); dent(); pLexp body)
310 :
311 :	monnier	47	| pLexp (F.PRIMOP ((d, primop, lty, tycs), values, lvar, body)) =
312 :			(* <lvar> = PRIM(<primop>, <lty>, [<tycs>]) [<values>]
313 :			* <body>
314 :			*)
315 :			(printVar lvar;
316 :			(case d of NONE => say " = PRIMOP("
317 :			| _ => say " = GENOP(");
318 :			say (PO.prPrimop primop); say ", ";
319 :			printLty lty; say ", ";
320 :			printTycList tycs; say ") ";
321 :			printValList values;
322 :			newline(); dent(); pLexp body)
323 :
324 :	monnier	220	and printFundec (fkind as {cconv,...}, lvar, lvar_lty_list, body) =
325 :	monnier	16	(* <lvar> : (<fkind>) <lty> =
326 :			* FN([v1 : lty1,
327 :			* v2 : lty2],
328 :			* <body>)
329 :			*)
330 :			(printVar lvar; say " : ";
331 :			say "("; printFKind fkind; say ") ";
332 :			(*** the return-result lty no longer available ---- printLty lty; **)
333 :			say " = "; newline();
334 :			indent 2;
335 :			dent();
336 :			say "FN([";
337 :			indent 4;
338 :			(case lvar_lty_list of
339 :			[] => ()
340 :			| ((lvar,lty)::L) =>
341 :	monnier	220	(printVar lvar; say " : ";
342 :			if !CTRL.printFctTypes orelse cconv <> F.CC_FCT
343 :			then printLty lty else say "???";
344 :	monnier	16	app (fn (lvar,lty) =>
345 :			(say ","; newline(); dent();
346 :			printVar lvar; say " : "; printLty lty)) L));
347 :	monnier	47	say "],"; newline();
348 :	monnier	16	undent 2; dent();
349 :	monnier	47	pLexp body; say ")";
350 :			undent 4)
351 :	monnier	16
352 :			and printCase (con, lexp) =
353 :			(printCon con;
354 :			say " => ";
355 :			indent 4; newline(); dent();
356 :			printDecon con;
357 :			pLexp lexp; undent 4)
358 :
359 :	monnier	71	and printBranch (s, lexp) =
360 :			(say s;
361 :			indent 4; newline(); dent();
362 :			pLexp lexp; undent 4)
363 :
364 :	monnier	16	fun printLexp lexp = pLexp lexp before (newline(); newline())
365 :	monnier	47
366 :			fun printProg prog = (printFundec prog; newline())
367 :	monnier	16
368 :
369 :			end (* structure PPFlint *)

---

root@smlnj-gforge.cs.uchicago.edu	ViewVC Help
Powered by ViewVC 1.0.0