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 4986 - (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 : jhr 4960 (* string conversions for various CPS.P types *)
17 :     val numkindToString : CPS.P.numkind -> string
18 :     val arithopToString : CPS.P.arithop -> string
19 :     val cmpopToString : CPS.P.cmpop -> string
20 :     val fcmpopToString : CPS.P.fcmpop -> string
21 :     val branchToString : CPS.P.branch -> string
22 :     val setterToString : CPS.P.setter -> string
23 :     val lookerToString : CPS.P.looker -> string
24 :     val arithToString : CPS.P.arith -> string
25 :     val pureToString : CPS.P.pure -> string
26 :    
27 : jhr 4540 end (* signature PPCPS *)
28 :    
29 : monnier 245 structure PPCps : PPCPS =
30 : jhr 4960 struct
31 : monnier 245
32 : jhr 4960 open CPS
33 :     structure LV = LambdaVar
34 :     structure U = CPSUtil
35 : monnier 245
36 : jhr 4960 val say = Control.Print.say
37 : monnier 245
38 : jhr 4960 val sayt = say o U.ctyToString
39 : monnier 245
40 : jhr 4960 fun value2str (VAR v) = LV.lvarName v
41 :     | value2str (LABEL v) = "(L)" ^ LV.lvarName v
42 :     | value2str (NUM{ival, ty={sz=0, ...}}) = "(II)" ^ IntInf.toString ival
43 :     | value2str (NUM{ival, ty={tag=true, ...}}) = "(I)" ^ IntInf.toString ival
44 :     | value2str (NUM{ival, ty={sz, ...}}) = concat[
45 :     "(I", Int.toString sz, ")", IntInf.toString ival
46 :     ]
47 :     | value2str (REAL{rval, ty}) = concat[
48 :     "(R", Int.toString ty, ")", RealLit.toString rval
49 :     ]
50 :     | value2str (STRING s) = concat["\"", String.toString s, "\""]
51 :     | value2str (VOID) = "(void)"
52 : jhr 4540
53 : jhr 4960 fun numkindToString (P.INT bits) = "i" ^ Int.toString bits
54 :     | numkindToString (P.UINT bits) = "u" ^ Int.toString bits
55 :     | numkindToString (P.FLOAT bits) = "f" ^ Int.toString bits
56 : monnier 245
57 : jhr 4960 fun arithopToString P.ADD = "+"
58 :     | arithopToString P.SUB = "-"
59 :     | arithopToString P.MUL = "*"
60 :     | arithopToString P.DIV = "div"
61 :     | arithopToString P.MOD = "mod"
62 :     | arithopToString P.QUOT = "quot"
63 :     | arithopToString P.REM = "rem"
64 :     | arithopToString P.FDIV = "/"
65 :     | arithopToString P.NEG = "~"
66 : jhr 4986 | arithopToString P.FABS = "fabs"
67 : jhr 4960 | arithopToString P.FSQRT = "fsqrt"
68 :     | arithopToString P.FSIN = "sin"
69 :     | arithopToString P.FCOS = "cos"
70 :     | arithopToString P.FTAN = "tan"
71 :     | arithopToString P.RSHIFT = "rshift"
72 :     | arithopToString P.RSHIFTL = "rshiftl"
73 :     | arithopToString P.LSHIFT = "lshift"
74 :     | arithopToString P.ANDB = "andb"
75 :     | arithopToString P.ORB = "orb"
76 :     | arithopToString P.XORB = "xorb"
77 :     | arithopToString P.NOTB = "notb"
78 : monnier 245
79 : jhr 4960 fun cmpopToString P.GT = ">"
80 :     | cmpopToString P.LT = "<"
81 :     | cmpopToString P.GTE = ">="
82 :     | cmpopToString P.LTE = "<="
83 :     | cmpopToString P.EQL = "="
84 :     | cmpopToString P.NEQ = "<>"
85 : monnier 245
86 : jhr 4960 fun fcmpopToString P.F_EQ = "="
87 :     | fcmpopToString P.F_ULG = "?<>"
88 :     | fcmpopToString P.F_GT = ">"
89 :     | fcmpopToString P.F_GE = ">="
90 :     | fcmpopToString P.F_LT = "<"
91 :     | fcmpopToString P.F_LE = "<="
92 :     | fcmpopToString P.F_LG = "<>"
93 :     | fcmpopToString P.F_LEG = "<="
94 :     | fcmpopToString P.F_UGT = "?>"
95 :     | fcmpopToString P.F_UGE = "?>="
96 :     | fcmpopToString P.F_ULT = "?<"
97 :     | fcmpopToString P.F_ULE = "?<="
98 :     | fcmpopToString P.F_UE = "?="
99 :     | fcmpopToString P.F_UN = "?"
100 : monnier 245
101 : jhr 4970 fun branchToString (P.CMP{oper, kind}) = numkindToString kind ^ cmpopToString oper
102 :     | branchToString (P.FCMP{oper, size}) = numkindToString (P.FLOAT size) ^ fcmpopToString oper
103 :     | branchToString (P.FSGN sz) = numkindToString (P.FLOAT sz) ^ "sgn"
104 :     | branchToString P.BOXED = "boxed"
105 : jhr 4960 | branchToString P.UNBOXED = "unboxed"
106 :     | branchToString P.PEQL = "peql"
107 :     | branchToString P.PNEQ = "pneq"
108 :     | branchToString P.STREQL = "streql"
109 :     | branchToString P.STRNEQ = "strneq"
110 : monnier 245
111 : jhr 4960 fun setterToString P.UNBOXEDUPDATE = "unboxedupdate"
112 :     | setterToString P.UPDATE = "update"
113 :     | setterToString (P.NUMUPDATE{kind}) = ("numupdate" ^ numkindToString kind)
114 :     | setterToString P.UNBOXEDASSIGN = "unboxedassign"
115 :     | setterToString P.ASSIGN = "assign"
116 :     | setterToString P.SETHDLR = "sethdlr"
117 :     | setterToString P.SETVAR = "setvar"
118 :     | setterToString P.SETSPECIAL = "setspecial"
119 :     | setterToString (P.RAWSTORE{kind}) = ("rawstore" ^ numkindToString kind)
120 :     | setterToString (P.RAWUPDATE cty) = ("rawupdate" ^ U.ctyToString cty)
121 : monnier 245
122 : jhr 4960 fun lookerToString P.DEREF = "!"
123 :     | lookerToString P.GETHDLR = "gethdlr"
124 :     | lookerToString P.SUBSCRIPT = "subscript"
125 :     | lookerToString (P.NUMSUBSCRIPT{kind}) = ("numsubscript" ^ numkindToString kind)
126 :     | lookerToString P.GETVAR = "getvar"
127 :     | lookerToString P.GETSPECIAL = "getspecial"
128 :     | lookerToString (P.RAWLOAD{kind}) = ("rawload" ^ numkindToString kind)
129 : monnier 245
130 : jhr 4960 val cvtParam = Int.toString
131 :     fun cvtParams (prefix, from, to) = concat [prefix, cvtParam from, "_", cvtParam to]
132 : leunga 1094
133 : jhr 4960 fun arithToString (P.ARITH{oper, kind}) = arithopToString oper ^ numkindToString kind
134 :     | arithToString (P.TEST{from, to}) = cvtParams ("test_", from, to)
135 :     | arithToString (P.TESTU{from, to}) = cvtParams ("testu_", from, to)
136 :     | arithToString (P.TEST_INF i) = "test_inf_" ^ cvtParam i
137 : jhr 4986 | arithToString (P.REAL_TO_INT{floor, from, to}) = concat[
138 :     if floor then "floor_" else "round_", cvtParam from, "to", cvtParam to
139 : jhr 4960 ]
140 : jhr 4446
141 : jhr 4960 fun pureToString P.LENGTH = "length"
142 :     | pureToString (P.PURE_ARITH{oper,kind}) = arithopToString oper ^ numkindToString kind
143 :     | pureToString P.OBJLENGTH = "objlength"
144 :     | pureToString P.MAKEREF = "makeref"
145 :     | pureToString (P.EXTEND{from, to}) = cvtParams ("extend_", from, to)
146 :     | pureToString (P.COPY{from, to}) = cvtParams ("copy_", from, to)
147 :     | pureToString (P.TRUNC{from, to}) = cvtParams ("trunc_", from, to)
148 :     | pureToString (P.TRUNC_INF i) = "trunc_inf_" ^ cvtParam i
149 :     | pureToString (P.COPY_INF i) = concat ["copy_", cvtParam i, "_inf"]
150 :     | pureToString (P.EXTEND_INF i) = concat ["extend_", cvtParam i, "_inf"]
151 : jhr 4986 | pureToString (P.INT_TO_REAL{from, to}) =
152 :     concat ["real", cvtParam from, "_", cvtParam to]
153 : jhr 4960 | pureToString P.SUBSCRIPTV = "subscriptv"
154 :     | pureToString (P.PURE_NUMSUBSCRIPT{kind}) = "numsubscriptv" ^ numkindToString kind
155 :     | pureToString P.GETTAG = "gettag"
156 :     | pureToString P.MKSPECIAL = "mkspecial"
157 :     | pureToString P.CAST = "cast"
158 :     | pureToString P.GETCON = "getcon"
159 :     | pureToString P.GETEXN = "getexn"
160 :     | pureToString P.BOX = "box"
161 :     | pureToString P.UNBOX = "unbox"
162 :     | pureToString (P.WRAP kind) = "wrap_" ^ numkindToString kind
163 :     | pureToString (P.UNWRAP kind) = "unwrap_" ^ numkindToString kind
164 :     | pureToString P.GETSEQDATA = "getseqdata"
165 :     | pureToString P.RECSUBSCRIPT = "recsubscript"
166 :     | pureToString P.RAW64SUBSCRIPT = "raw64subscript"
167 :     | pureToString P.NEWARRAY0 = "newarray0"
168 :     | pureToString (P.RAWRECORD rk) = "rawrecord_"^getOpt(Option.map rkstring rk, "notag")
169 : monnier 245
170 : jhr 4960 and rkstring rk = (case rk
171 :     of RK_VECTOR => "RK_VECTOR"
172 :     | RK_RECORD => "RK_RECORD"
173 :     | RK_SPILL => "RK_SPILL"
174 :     | RK_ESCAPE => "RK_ESCAPE"
175 :     | RK_EXN => "RK_EXN"
176 :     | RK_CONT => "RK_CONT"
177 :     | RK_FCONT => "RK_FCONT"
178 :     | RK_KNOWN => "RK_KNOWN"
179 :     | RK_BLOCK => "RK_BLOCK"
180 :     | RK_FBLOCK => "RK_FBLOCK"
181 :     | RK_I32BLOCK => "RK_I32BLOCK"
182 :     (* end case *))
183 : monnier 245
184 : jhr 4960 fun show0 say = let
185 :     fun sayc (#"\n") = say "\\n"
186 :     | sayc c = say(String.str c)
187 : monnier 245
188 : jhr 4960 fun sayv v = say(value2str v)
189 : monnier 245
190 : jhr 4960 fun sayvlist [v] = sayv v
191 :     | sayvlist nil = ()
192 :     | sayvlist (v::vl) = (sayv v; say ","; sayvlist vl)
193 : monnier 245
194 : jhr 4960 fun sayrk (RK_RECORD, n) = ()
195 :     | sayrk (RK_VECTOR, n) = ()
196 :     | sayrk (k, n) = (say (rkstring k); say " "; say (Int.toString n); say ",")
197 : jhr 4446
198 : jhr 4960 fun sayparam ([v],[ct]) = (sayv v; sayt ct)
199 :     | sayparam (nil,nil) = ()
200 :     | sayparam (v::vl,ct::cl) = (sayv v; sayt ct; say ","; sayparam(vl,cl))
201 :     | sayparam _ = ErrorMsg.impossible "sayparam in ppcps.sml"
202 : monnier 245
203 : jhr 4960 fun saypath(OFFp 0) = ()
204 :     | saypath(OFFp i) = (say "+"; say(Int.toString i))
205 :     | saypath(SELp(j,p)) = (say "."; say(Int.toString j); saypath p)
206 :     fun sayvp (v,path) = (sayv v; saypath path)
207 :     fun saylist f [x] = f x | saylist f nil = ()
208 :     | saylist f (x::r) = (f x; say ","; saylist f r)
209 :     fun indent n = let
210 :     fun space 0 = () | space k = (say " "; space(k-1))
211 :     fun nl() = say "\n"
212 :     fun f (RECORD(k,vl,v,c)) = (
213 :     space n;
214 :     case k of RK_VECTOR => say "#{" | _ => say "{";
215 :     sayrk(k,length vl);
216 :     saylist sayvp vl; say "} -> ";
217 :     sayv(VAR v);
218 :     nl(); f c)
219 :     | f (SELECT(i,v,w,t,c)) = (
220 :     space n; sayv v; say "."; say(Int.toString i); say " -> ";
221 :     sayv(VAR w); sayt(t); nl(); f c)
222 :     | f (OFFSET(i,v,w,c)) = (
223 :     space n; sayv v; say "+"; say(Int.toString i); say " -> ";
224 :     sayv(VAR w); nl(); f c)
225 :     | f (APP(w,vl)) = (
226 :     space n; sayv w; say "("; sayvlist vl; say ")\n")
227 :     | f (FIX(bl,c)) = let
228 :     fun g (_,v,wl,cl,d) = (
229 :     space n; sayv(VAR v); say "(";
230 :     sayparam (map VAR wl,cl);
231 :     say ") =\n";
232 :     indent (n+3) d)
233 :     in
234 :     app g bl; f c
235 :     end
236 :     | f (SWITCH(v,c,cl)) = let
237 :     fun g (i,c::cl) = (
238 :     space(n+1); say(Int.toString(i:int));
239 :     say " =>\n"; indent (n+3) c; g(i+1,cl))
240 :     | g (_,nil) = ()
241 :     in
242 :     space n; say "case "; sayv v; say " [";
243 :     say(Int.toString(c));
244 :     say "] of\n";
245 :     g(0,cl)
246 :     end
247 :     | f (LOOKER(i,vl,w,t,e)) = (
248 :     space n; say(lookerToString i); say "("; sayvlist vl;
249 :     say ") -> "; sayv(VAR w); sayt(t); nl(); f e)
250 :     | f (ARITH(i,vl,w,t,e)) = (
251 :     space n; say(arithToString i); say "("; sayvlist vl;
252 :     say ") -> "; sayv(VAR w); sayt(t); nl(); f e)
253 :     | f (PURE(i,vl,w,t,e)) = (
254 :     space n; say(pureToString i); say "("; sayvlist vl;
255 :     say ") -> "; sayv(VAR w); sayt(t); nl(); f e)
256 :     | f (SETTER(i,vl,e)) = (
257 :     space n; say(setterToString i); say "("; sayvlist vl;
258 :     say ")"; nl(); f e)
259 :     | f (BRANCH(i,vl,c,e1,e2)) = (
260 :     space n; say "if "; say(branchToString i);
261 :     say "("; sayvlist vl; say ") [";
262 :     sayv(VAR c); say "] then\n";
263 :     indent (n+3) e1;
264 :     space n; say "else\n";
265 :     indent (n+3) e2)
266 :     | f (RCC(k,l,p,vl,wtl,e)) = (
267 :     space n;
268 :     if k = REENTRANT_RCC then say "reentrant " else ();
269 :     if l = "" then () else (say l; say " ");
270 :     say "rcc("; sayvlist vl; say ") -> ";
271 :     app (fn (w, t) => (sayv (VAR w); sayt(t))) wtl;
272 :     nl(); f e)
273 :     in
274 :     f
275 :     end
276 :     in
277 :     indent
278 :     end (* show0 *)
279 : monnier 245
280 : jhr 4960 fun printcps((_,f,vl,cl,e),m) = let
281 :     fun ptv(v,t) = (say(LV.lvarName v); say " type ===>>>";
282 :     say(LtyExtern.lt_print t); say "\n")
283 :     val _ = if (!Control.CG.debugRep)
284 :     then (say "************************************************\n";
285 :     IntHashTable.appi ptv m;
286 :     say "************************************************\n")
287 :     else ()
288 :     fun sayv(v) = say(LV.lvarName v)
289 :     fun sayparam ([v],[ct]) = (sayv v; sayt ct)
290 :     | sayparam (nil,nil) = ()
291 :     | sayparam (v::vl,ct::cl) = (sayv v; sayt ct; say ","; sayparam(vl,cl))
292 :     | sayparam _ = ErrorMsg.impossible "sayparam in ppcps.sml 3435"
293 : monnier 245
294 : jhr 4960 in
295 :     say(LV.lvarName f); say "("; sayparam(vl,cl); say ") =\n";
296 :     show0 say 3 e
297 :     end
298 : monnier 245
299 : jhr 4960 exception NULLTABLE
300 :     val nulltable : LtyDef.lty IntHashTable.hash_table =
301 :     IntHashTable.mkTable(8, NULLTABLE)
302 : monnier 245
303 : jhr 4960 fun printcps0 f = printcps(f,nulltable)
304 : monnier 245
305 : jhr 4960 fun prcps(ce) = show0 (Control.Print.say) 1 ce
306 : monnier 245
307 : jhr 4960 end (* structure PPCps *)

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