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/compiler/FLINT/cps/ppcps.sml
ViewVC logotype

Annotation of /sml/trunk/compiler/FLINT/cps/ppcps.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 4813 - (view) (download)

1 : jhr 4446 (* ppcps.sml
2 :     *
3 : jhr 4540 * COPYRIGHT (c) 2018 The Fellowship of SML/NJ (http://www.smlnj.org)
4 : jhr 4446 * All rights reserved.
5 :     *)
6 : monnier 245
7 :     signature PPCPS =
8 : jhr 4540 sig
9 : monnier 245
10 : jhr 4540 val value2str : CPS.value -> string
11 : monnier 245
12 : jhr 4540 val printcps : (CPS.function * LtyDef.lty IntHashTable.hash_table) -> unit
13 :     val printcps0: CPS.function -> unit
14 :     val prcps : CPS.cexp -> unit
15 :    
16 :     end (* signature PPCPS *)
17 :    
18 : monnier 245 structure PPCps : PPCPS =
19 :     struct
20 :    
21 :     local open CPS
22 :     structure LV = LambdaVar
23 :     in
24 :    
25 :     val say = Control.Print.say
26 :    
27 : monnier 475 val sayt = say o CPS.ctyToString
28 : monnier 245
29 : jhr 4540 fun value2str (VAR v) = LV.lvarName v
30 :     | value2str (LABEL v) = "(L)" ^ LV.lvarName v
31 : jhr 4560 | value2str (NUM{ival, ty={sz=0, ...}}) = "(II)" ^ IntInf.toString ival
32 :     | value2str (NUM{ival, ty={tag=true, ...}}) = "(I)" ^ IntInf.toString ival
33 :     | value2str (NUM{ival, ty={sz, ...}}) = concat[
34 :     "(I", Int.toString sz, ")", IntInf.toString ival
35 :     ]
36 : jhr 4540 | value2str (REAL{rval, ty}) = concat[
37 :     "(R", Int.toString ty, ")", RealLit.toString rval
38 :     ]
39 :     | value2str (STRING s) = concat["\"", String.toString s, "\""]
40 :     | value2str (VOID) = "(void)"
41 :    
42 : monnier 245 fun numkindName (P.INT bits) = "i" ^ Int.toString bits
43 :     | numkindName (P.UINT bits) = "u" ^ Int.toString bits
44 :     | numkindName (P.FLOAT bits) = "f" ^ Int.toString bits
45 :    
46 :     fun lookerName P.! = "!"
47 :     | lookerName P.gethdlr = "gethdlr"
48 :     | lookerName P.subscript = "subscript"
49 :     | lookerName (P.numsubscript{kind}) = ("numsubscript" ^ numkindName kind)
50 :     | lookerName P.getvar = "getvar"
51 :     | lookerName P.getspecial = "getspecial"
52 :     | lookerName P.getpseudo = "getpseudo"
53 : blume 772 | lookerName (P.rawload {kind}) = ("rawload" ^ numkindName kind)
54 : monnier 245
55 :     fun branchName P.boxed = "boxed"
56 :     | branchName P.unboxed = "unboxed"
57 :     | branchName (P.cmp{oper, kind}) =
58 :     (numkindName kind ^
59 : jhr 4446 (case oper
60 :     of P.> => ">"
61 : monnier 245 | P.< => "<"
62 : jhr 4446 | P.>= => ">="
63 : monnier 245 | P.<= => "<="
64 :     | P.eql => "="
65 : jhr 4446 | P.neq => "<>"
66 : monnier 245 (*esac*)))
67 : jhr 4446 | branchName(P.fcmp{oper, size}) =
68 : monnier 245 (numkindName (P.FLOAT size) ^
69 : jhr 4446 (case oper
70 : monnier 245 of P.fEQ => "="
71 :     | P.fULG => "?<>"
72 :     | P.fGT => ">"
73 :     | P.fGE => ">="
74 :     | P.fLT => "<"
75 :     | P.fLE => "<="
76 :     | P.fLG => "<>"
77 :     | P.fLEG => "<=>"
78 :     | P.fUGT => "?>"
79 :     | P.fUGE => "?>="
80 :     | P.fULT => "?<"
81 :     | P.fULE => "?<="
82 :     | P.fUE => "?="
83 :     | P.fUN => "?"
84 : gkuan 2732 | P.fsgn => "sgn"
85 : jhr 4446 (*esac*)))
86 : monnier 245 | branchName P.pneq = "pneq"
87 :     | branchName P.peql = "peql"
88 :     | branchName P.streq = "streq"
89 :     | branchName P.strneq = "strneq"
90 :    
91 :     fun setterName P.unboxedupdate = "unboxedupdate"
92 :     | setterName P.update = "update"
93 :     | setterName (P.numupdate{kind}) = ("numupdate" ^ numkindName kind)
94 :     | setterName P.unboxedassign = "unboxedassign"
95 :     | setterName P.assign = "assign"
96 :     | setterName P.sethdlr = "sethdlr"
97 :     | setterName P.setvar = "setvar"
98 :     | setterName P.free = "free"
99 :     | setterName P.setspecial = "setspecial"
100 :     | setterName P.setpseudo = "setpseudo"
101 :     | setterName P.setmark = "setmark"
102 :     | setterName P.acclink = "acclink"
103 : blume 772 | setterName (P.rawstore {kind}) = ("rawstore" ^ numkindName kind)
104 : leunga 1094 | setterName (P.rawupdate cty) = ("rawupdate" ^ CPS.ctyToString cty)
105 : monnier 245
106 : mblume 1347 val cvtParam = Int.toString
107 :     fun cvtParams(from, to) = concat [cvtParam from, "_", cvtParam to]
108 : monnier 245
109 :     fun arithName (P.arith{oper,kind}) =
110 :     ((case oper of P.+ => "+" | P.- => "-" | P.* => "*"
111 : jhr 4446 | P./ => "/" | P.~ => "~" | P.abs => "abs"
112 : gkuan 2732 | P.fsqrt => "fsqrt"
113 : george 717 | P.fsin => "sin" | P.fcos => "cos" | P.ftan => "tan"
114 : monnier 245 | P.rshift => "rshift" | P.rshiftl => "rshiftl"
115 :     | P.lshift => "lshift" | P.andb => "andb"
116 : blume 1183 | P.orb => "orb" | P.xorb => "xorb" | P.notb => "notb"
117 :     | P.rem => "rem" | P.div => "div" | P.mod => "mod")
118 : monnier 245 ^ numkindName kind)
119 :     | arithName(P.test arg) = "test_" ^ cvtParams arg
120 :     | arithName(P.testu arg) = "testu_" ^ cvtParams arg
121 : mblume 1347 | arithName(P.test_inf i) = "test_inf_" ^ cvtParam i
122 : monnier 245 | arithName (P.round{floor=true,fromkind=P.FLOAT 64,tokind=P.INT 31}) =
123 :     "floor"
124 :     | arithName (P.round{floor=false,fromkind=P.FLOAT 64,tokind=P.INT 31}) =
125 :     "round"
126 :     | arithName (P.round{floor,fromkind,tokind}) =
127 :     ((if floor then "floor" else "round")
128 :     ^ numkindName fromkind ^ "_" ^ numkindName tokind)
129 :    
130 :     fun pureName P.length = "length"
131 :     | pureName (P.pure_arith x) = arithName(P.arith x)
132 :     | pureName P.objlength = "objlength"
133 :     | pureName P.makeref = "makeref"
134 :     | pureName (P.extend arg) = "extend_" ^ cvtParams arg
135 :     | pureName (P.copy arg) = "copy_" ^ cvtParams arg
136 :     | pureName (P.trunc arg) = "trunc_" ^ cvtParams arg
137 : mblume 1347 | pureName (P.trunc_inf i) = "trunc_inf_" ^ cvtParam i
138 :     | pureName (P.copy_inf i) = concat ["copy_", cvtParam i, "_inf"]
139 :     | pureName (P.extend_inf i) = concat ["extend_", cvtParam i, "_inf"]
140 : monnier 245 | pureName (P.real{fromkind=P.FLOAT 64,tokind=P.INT 31}) = "real"
141 :     | pureName (P.real{fromkind,tokind}) =
142 :     ("real" ^ numkindName fromkind ^ "_" ^ numkindName tokind)
143 :     | pureName P.subscriptv = "subscriptv"
144 :     | pureName (P.pure_numsubscript{kind}) = ("numsubscriptv" ^ numkindName kind)
145 :     | pureName P.gettag = "gettag"
146 :     | pureName P.mkspecial = "mkspecial"
147 :     | pureName P.wrap = "wrap"
148 :     | pureName P.unwrap = "unwrap"
149 :     | pureName P.cast = "cast"
150 :     | pureName P.getcon = "getcon"
151 :     | pureName P.getexn = "getexn"
152 :     | pureName P.fwrap = "fwrap"
153 :     | pureName P.funwrap = "funwrap"
154 :     | pureName P.iwrap = "iwrap"
155 :     | pureName P.iunwrap = "iunwrap"
156 : jhr 4813 | pureName P.i32wrap = "i32wrap" (* 64BIT: FIXME *)
157 :     | pureName P.i32unwrap = "i32unwrap" (* 64BIT: FIXME *)
158 : monnier 245 | pureName P.getseqdata = "getseqdata"
159 :     | pureName P.recsubscript = "recsubscript"
160 :     | pureName P.raw64subscript = "raw64subscript"
161 :     | pureName P.newarray0 = "newarray0"
162 : blume 1178 | pureName (P.rawrecord rk) =
163 :     "rawrecord_"^getOpt(Option.map rkstring rk, "notag")
164 : monnier 245
165 : jhr 4446 and rkstring rk = (case rk
166 : leunga 1094 of RK_VECTOR => "RK_VECTOR"
167 :     | RK_RECORD => "RK_RECORD"
168 :     | RK_SPILL => "RK_SPILL"
169 :     | RK_ESCAPE => "RK_ESCAPE"
170 :     | RK_EXN => "RK_EXN"
171 :     | RK_CONT => "RK_CONT"
172 :     | RK_FCONT => "RK_FCONT"
173 :     | RK_KNOWN => "RK_KNOWN"
174 :     | RK_BLOCK => "RK_BLOCK"
175 :     | RK_FBLOCK => "RK_FBLOCK"
176 :     | RK_I32BLOCK => "RK_I32BLOCK")
177 :    
178 : monnier 245 fun show0 say =
179 :     let fun sayc (#"\n") = say "\\n"
180 :     | sayc c = say(String.str c)
181 : jhr 4446
182 : jhr 4540 fun sayv v = say(value2str v)
183 : monnier 245
184 :     fun sayvlist [v] = sayv v
185 :     | sayvlist nil = ()
186 :     | sayvlist (v::vl) = (sayv v; say ","; sayvlist vl)
187 :    
188 :     fun sayrk(RK_RECORD,n) = ()
189 :     | sayrk(RK_VECTOR,n) = ()
190 :     | sayrk(k,n : int) = (say (rkstring k); say " ";
191 :     say (Int.toString n); say ",")
192 :    
193 :     fun sayparam ([v],[ct]) = (sayv v; sayt ct)
194 :     | sayparam (nil,nil) = ()
195 :     | sayparam (v::vl,ct::cl) = (sayv v; sayt ct; say ","; sayparam(vl,cl))
196 :     | sayparam _ = ErrorMsg.impossible "sayparam in ppcps.sml"
197 :    
198 :     fun saypath(OFFp 0) = ()
199 :     | saypath(OFFp i) = (say "+"; say(Int.toString i))
200 :     | saypath(SELp(j,p)) = (say "."; say(Int.toString j); saypath p)
201 :     fun sayvp (v,path) = (sayv v; saypath path)
202 : jhr 4446 fun saylist f [x] = f x | saylist f nil = ()
203 : monnier 245 | saylist f (x::r) = (f x; say ","; saylist f r)
204 :     fun indent n =
205 :     let fun space 0 = () | space k = (say " "; space(k-1))
206 :     fun nl() = say "\n"
207 :     val rec f =
208 :     fn RECORD(k,vl,v,c) => (
209 :     space n;
210 :     case k of RK_VECTOR => say "#{" | _ => say "{";
211 :     sayrk(k,length vl);
212 :     saylist sayvp vl; say "} -> ";
213 :     sayv(VAR v);
214 :     nl(); f c)
215 :     | SELECT(i,v,w,t,c) =>
216 :     (space n; sayv v; say "."; say(Int.toString i); say " -> ";
217 :     sayv(VAR w); sayt(t); nl(); f c)
218 :     | OFFSET(i,v,w,c) =>
219 :     (space n; sayv v; say "+"; say(Int.toString i); say " -> ";
220 :     sayv(VAR w); nl(); f c)
221 : jhr 4446 | APP(w,vl) =>
222 : monnier 245 (space n; sayv w; say "("; sayvlist vl; say ")\n")
223 :     | FIX(bl,c) =>
224 : jhr 4446 let fun g(_,v,wl,cl,d) =
225 :     (space n; sayv(VAR v); say "(";
226 : monnier 245 sayparam (map VAR wl,cl);
227 : jhr 4446 say ") =\n";
228 : monnier 245 indent (n+3) d)
229 :     in app g bl; f c
230 :     end
231 :     | SWITCH(v,c,cl) =>
232 :     let fun g(i,c::cl) =
233 :     (space(n+1); say(Int.toString(i:int));
234 :     say " =>\n"; indent (n+3) c; g(i+1,cl))
235 :     | g(_,nil) = ()
236 : jhr 4446 in space n; say "case "; sayv v; say " [";
237 : monnier 245 say(Int.toString(c));
238 : jhr 4446 say "] of\n";
239 : monnier 245 g(0,cl)
240 :     end
241 :     | LOOKER(i,vl,w,t,e) =>
242 :     (space n; say(lookerName i); say "("; sayvlist vl;
243 :     say ") -> "; sayv(VAR w); sayt(t); nl(); f e)
244 :     | ARITH(i,vl,w,t,e) =>
245 :     (space n; say(arithName i); say "("; sayvlist vl;
246 :     say ") -> "; sayv(VAR w); sayt(t); nl(); f e)
247 :     | PURE(i,vl,w,t,e) =>
248 :     (space n; say(pureName i); say "("; sayvlist vl;
249 :     say ") -> "; sayv(VAR w); sayt(t); nl(); f e)
250 :     | SETTER(i,vl,e) =>
251 :     (space n; say(setterName i); say "("; sayvlist vl;
252 :     say ")"; nl(); f e)
253 :     | BRANCH(i,vl,c,e1,e2) =>
254 :     (space n; say "if "; say(branchName i);
255 : jhr 4446 say "("; sayvlist vl; say ") [";
256 : monnier 245 sayv(VAR c); say "] then\n";
257 :     indent (n+3) e1;
258 :     space n; say "else\n";
259 :     indent (n+3) e2)
260 : mblume 1755 | RCC(k,l,p,vl,wtl,e) =>
261 : jhr 4446 (space n;
262 : leunga 1174 if k = REENTRANT_RCC then say "reentrant " else ();
263 :     if l = "" then () else (say l; say " ");
264 : mblume 1755 say "rcc("; sayvlist vl; say ") -> ";
265 :     app (fn (w, t) => (sayv (VAR w); sayt(t))) wtl;
266 :     nl(); f e)
267 : monnier 245 in f
268 :     end
269 :     in indent
270 :     end
271 :    
272 :     fun printcps((_,f,vl,cl,e),m)=
273 :     let fun ptv(v,t) = (say(LV.lvarName v); say " type ===>>>";
274 :     say(LtyExtern.lt_print t); say "\n")
275 : jhr 4446
276 : monnier 245 val _ = if (!Control.CG.debugRep)
277 :     then (say "************************************************\n";
278 : blume 733 IntHashTable.appi ptv m;
279 : monnier 245 say "************************************************\n")
280 :     else ()
281 :    
282 :     fun sayv(v) = say(LV.lvarName v)
283 :     fun sayparam ([v],[ct]) = (sayv v; sayt ct)
284 :     | sayparam (nil,nil) = ()
285 :     | sayparam (v::vl,ct::cl) = (sayv v; sayt ct; say ","; sayparam(vl,cl))
286 :     | sayparam _ = ErrorMsg.impossible "sayparam in ppcps.sml 3435"
287 :    
288 : jhr 4446 in
289 :     (say(LV.lvarName f); say "("; sayparam(vl,cl); say ") =\n";
290 : monnier 245 show0 say 3 e)
291 :     end
292 :    
293 :     exception NULLTABLE
294 : blume 733 val nulltable : LtyDef.lty IntHashTable.hash_table =
295 :     IntHashTable.mkTable(8,NULLTABLE)
296 : monnier 245
297 :     fun printcps0 f = printcps(f,nulltable)
298 :    
299 :     fun prcps(ce) = show0 (Control.Print.say) 1 ce
300 :    
301 :     end (* toplevel local *)
302 :     end (* structure PPCps *)
303 :    

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