Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /sml/trunk/src/compiler/FLINT/flint/ppflint.sml
ViewVC logotype

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

Parent Directory Parent Directory | Revision Log 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