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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 114 - (view) (download)

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

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