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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 4527 - (view) (download)
Original Path: sml/trunk/compiler/FLINT/cps/ppcps.sml

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

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