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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 733 - (view) (download)

1 : monnier 16 (* Copyright 1996 by Bell Laboratories *)
2 :     (* cpstrans.sml *)
3 :    
4 :     signature CPSTRANS = sig
5 :     val cpstrans : CPS.function -> CPS.function
6 :     end (* signature CPSTRANS *)
7 :    
8 :     functor CPStrans(MachSpec : MACH_SPEC) : CPSTRANS = struct
9 :    
10 :     local open CPS
11 :     structure LV = LambdaVar
12 :     in
13 : monnier 100
14 :     fun bug s = ErrorMsg.impossible ("CPStrans: " ^ s)
15 :     fun ident x = x
16 :     val mkv = LV.mkLvar
17 :    
18 :     (**************************************************************************
19 :     * TOP OF THE MAIN FUNCTION *
20 :     **************************************************************************)
21 : monnier 16 fun cpstrans fe = let
22 :    
23 :     val unboxedfloat = MachSpec.unboxedFloats
24 :     val untaggedint = MachSpec.untaggedInt
25 :    
26 :     exception CPSSUBST
27 : blume 733 val M : value IntHashTable.hash_table = IntHashTable.mkTable(32,CPSSUBST)
28 :     val addvl = IntHashTable.insert M
29 :     fun mapvl v = ((IntHashTable.lookup M v) handle CPSSUBST => VAR v)
30 : monnier 16
31 :     exception CTYMAP
32 : blume 733 val CT : cty IntHashTable.hash_table = IntHashTable.mkTable(32,CTYMAP)
33 :     val addty = IntHashTable.insert CT
34 :     val getty = IntHashTable.lookup CT
35 : monnier 16 fun grabty(VAR v) = ((getty v) handle _ => BOGt)
36 :     | grabty(REAL _) = FLTt
37 :     | grabty(INT _) = INTt
38 :     | grabty(INT32 _) = INT32t
39 :     | grabty _ = BOGt
40 :    
41 :    
42 :     fun select(i,u,x,ct,ce) = SELECT(i,u,x,ct,ce)
43 :     fun record(k,ul,w,ce) = RECORD(k,ul,w,ce)
44 :    
45 :     (* wrappers around floats and ints are now dealt with in the convert phase *)
46 :     (***>>
47 :     fun unwrapfloat(u,x,ce) = PURE(P.funwrap,[u],x,FLTt,ce)
48 :     fun wrapfloat(u,x,ce) = PURE(P.fwrap,[u],x,BOGt,ce)
49 :     fun unwrapint(u,x,ce) = PURE(P.iunwrap,[u],x,INTt,ce)
50 :     fun wrapint(u,x,ce) = PURE(P.iwrap,[u],x,BOGt,ce)
51 :     fun unwrapint32(u,x,ce) = PURE(P.i32unwrap,[u],x,INT32t,ce)
52 :     fun wrapint32(u,x,ce) = PURE(P.i32wrap,[u],x,BOGt,ce)
53 :    
54 :     fun select(i,u,x,ct,ce) =
55 :     case (ct,unboxedfloat,untaggedint)
56 : monnier 100 of (FLTt,true,_) => let val v = mkv()
57 : monnier 16 in SELECT(i,u,v,BOGt,unwrapfloat(VAR v,x,ce))
58 :     end
59 : monnier 100 | (INTt,_,true) => let val v = mkv()
60 : monnier 16 in SELECT(i,u,v,BOGt,unwrapint(VAR v,x,ce))
61 :     end
62 : monnier 100 | (INT32t,_,_) => let val v = mkv()
63 : monnier 16 in SELECT(i,u,v,BOGt,unwrapint32(VAR v,x,ce))
64 :     end
65 :     | _ => SELECT(i,u,x,ct,ce)
66 :    
67 :     fun record(k,ul,w,ce) =
68 :     let fun h((FLTt,u),(l,h)) =
69 :     if unboxedfloat then
70 : monnier 100 (let val v = mkv()
71 : monnier 16 in ((VAR v,OFFp 0)::l, fn ce => wrapfloat(#1 u,v,h(ce)))
72 :     end)
73 :     else (u::l,h)
74 :     | h((INTt,u),(l,h)) =
75 :     if untaggedint then
76 : monnier 100 (let val v = mkv()
77 : monnier 16 in ((VAR v,OFFp 0)::l, fn ce => wrapint(#1 u,v,h(ce)))
78 :     end)
79 :     else (u::l,h)
80 :     | h((INT32t,u),(l,h)) =
81 : monnier 100 let val v = mkv()
82 : monnier 16 in ((VAR v,OFFp 0)::l, fn ce => wrapint32(#1 u,v,h(ce)))
83 :     end
84 :     | h((_,u),(l,h)) = (u::l,h)
85 :    
86 :     val info = map (fn (u as (v,_)) => (grabty v,u)) ul
87 : monnier 100 val (nul,header) = fold h info ([], ident)
88 : monnier 16 in header(RECORD(k,nul,w,ce))
89 :     end
90 :     <<***)
91 :    
92 : monnier 100
93 :     (**************************************************************************
94 :     * UTILITY FUNCTIONS THAT DO THE ARGUMENT SPILLING *
95 :     **************************************************************************)
96 :    
97 :     (** the following figures must be consistent with the choices made
98 :     in the closure or spilling phases *)
99 :     val fpnum = Int.min(MachSpec.numFloatRegs-2, MachSpec.numArgRegs)
100 :     val nregs = MachSpec.numRegs - MachSpec.numCalleeSaves
101 :     val gpnum = Int.min(nregs - 3, MachSpec.numArgRegs)
102 :    
103 :     fun argSpill (args, ctys) =
104 :     let fun h([], [], ngp, nfp, ovs, ots, [], [], []) = NONE
105 :     | h([], [], ngp, nfp, ovs, ots, [x], [_], []) = NONE
106 :     | h([], [], ngp, nfp, ovs, ots, gvs, gts, fvs) =
107 :     SOME(rev ovs, rev ots, rev gvs, rev gts, rev fvs)
108 :     | h(x::xs, ct::cts, ngp, nfp, ovs, ots, gvs, gts, fvs) =
109 :     (case ct
110 :     of FLTt =>
111 :     if nfp > 0 then
112 :     h(xs, cts, ngp, nfp-1, x::ovs, ct::ots, gvs, gts, fvs)
113 :     else
114 :     h(xs, cts, ngp, nfp, ovs, ots, gvs, gts, x::fvs)
115 :     | _ =>
116 :     if ngp > 0 then
117 :     h(xs, cts, ngp-1, nfp, x::ovs, ct::ots, gvs, gts, fvs)
118 :     else
119 :     h(xs, cts, ngp, nfp, ovs, ots, x::gvs, ct::gts, fvs))
120 :     | h _ = bug "unexpected case in argSpill"
121 :    
122 :     val n = length args
123 :     in if (n > fpnum) orelse (n > gpnum) then
124 :     h (args, ctys, gpnum, fpnum, [], [], [], [], [])
125 :     else NONE
126 :     end (* function argSpill *)
127 :    
128 :     fun spillIn (origargs, origctys, spgvars, spgctys, spfvars) =
129 :     let val (fhdr, spgvars, spgctys) =
130 :     case spfvars
131 :     of [] => (ident, spgvars, spgctys)
132 :     | _ => let val v = mkv()
133 :     val vs = map (fn x => (x, OFFp 0)) spfvars
134 :     val ct = PTRt(FPT (length vs))
135 :     val fh = fn e => RECORD(RK_FBLOCK, vs, v, e)
136 :     in (fh, (VAR v)::spgvars, ct::spgctys)
137 :     end
138 :     val (spgv, ghdr) =
139 :     case spgvars
140 :     of [] => (NONE, fhdr)
141 :     | [x] => (SOME x, fhdr)
142 :     | _ => let val v = mkv()
143 :     val vs = map (fn x => (x, OFFp 0)) spgvars
144 :     in (SOME (VAR v), fn e => fhdr(RECORD(RK_RECORD, vs, v, e)))
145 :     end
146 :     in case spgv of SOME x => SOME(origargs@[x], ghdr)
147 :     | NONE => NONE
148 :     end
149 :    
150 :     fun spillOut (origargs, origctys, spgvars, spgctys, spfvars) =
151 :     let val (spfv, fhdr, spgvars, spgctys) =
152 :     case spfvars
153 :     of [] => (NONE, ident, spgvars, spgctys)
154 :     | _ => let val v = mkv()
155 :     val u = VAR v
156 :     fun g (sv, (i,hdr)) =
157 : monnier 125 (i+1, fn e => hdr(SELECT(i, u, sv, FLTt, e)))
158 :     val (n,fh) = foldl g (0, ident) spfvars
159 : monnier 100 val ct = PTRt(FPT n)
160 :     in (SOME v, fh, v::spgvars, ct::spgctys)
161 :     end
162 :     val (spgv, ghdr) =
163 :     case (spgvars, spgctys)
164 :     of ([], _) => (NONE, fhdr)
165 :     | ([x], t::_) => (SOME (x,t), fhdr)
166 :     | _ => let val v = mkv()
167 :     val u = VAR v
168 : monnier 162 fun g (sv, st, (i,hdr)) =
169 :     (i+1, fn e =>hdr(SELECT(i, u, sv, st, e)))
170 :     val (n, gh) = ListPair.foldl g (0, fhdr) (spgvars,spgctys)
171 : monnier 100 val ct = PTRt(RPT n)
172 :     in (SOME (v, ct), gh)
173 :     end
174 :     in case spgv of SOME (x,t) => SOME (origargs@[x], origctys@[t], ghdr)
175 :     | NONE => NONE
176 :     end
177 :    
178 :     (* mkargin : value list -> (cexp -> cexp * value list) option *)
179 :     fun mkargin (args : value list) =
180 :     let val ctys = map grabty args
181 :     in case argSpill (args, ctys)
182 :     of SOME xx => spillIn xx
183 :     | NONE => NONE
184 :     end
185 :    
186 :     (* mkargout : lvar list -> (lvar list * cty list * cexp -> cexp) option *)
187 :     fun mkargout args =
188 :     let val ctys = map getty args
189 :     in case argSpill (args, ctys)
190 :     of SOME xx => spillOut xx
191 :     | NONE => NONE
192 :     end
193 :    
194 :     (**************************************************************************
195 :     * MAIN FUNCTIONS THAT TRANSLATE CPS CODE *
196 :     **************************************************************************)
197 : monnier 16 fun cexptrans(ce) =
198 :     case ce
199 :     of RECORD(k,vl,w,ce) => record(k,map rectrans vl,w,cexptrans ce)
200 :     | SELECT(i,v,w,t,ce) =>
201 : monnier 100 let val _ = addty(w,t)
202 :     val v' = vtrans v
203 :     val ce' = cexptrans ce
204 :     in select(i, v', w, getty w, ce')
205 :     end
206 : monnier 16 | OFFSET(i,v,w,ce) => OFFSET(i, vtrans v, w, cexptrans ce)
207 : monnier 100 | APP(v,vl) =>
208 :     (case mkargin vl
209 :     of SOME (nvl, hdr) => cexptrans(hdr(APP(v, nvl)))
210 :     | NONE => APP(vtrans v, map vtrans vl))
211 : monnier 16 | FIX(l,ce) => FIX(map functrans l, cexptrans ce)
212 :     | SWITCH(v,c,l) => SWITCH(vtrans v,c,map cexptrans l)
213 :     | LOOKER(p,vl,w,t,ce) =>
214 :     (let val _ = addty(w,t)
215 :     val vl' = map vtrans vl
216 :     val ce' = cexptrans ce
217 :     in LOOKER(p, vl', w, getty w, ce')
218 :     end)
219 :     | SETTER(p,vl,ce) =>
220 :     SETTER(p, map vtrans vl, cexptrans ce)
221 :     | ARITH(p,vl,w,t,ce) =>
222 :     (addty(w,t); ARITH(p, map vtrans vl, w, t, cexptrans ce))
223 :    
224 :    
225 :     (*** this special case is a temporary hack; ask ZHONG for details *)
226 :     (*
227 :     | PURE(P.wrap,[u],w,t as PTRt(FPT _),ce) =>
228 :     (addty(w, t); PURE(P.wrap, [vtrans u], w, t, cexptrans ce))
229 :     | PURE(P.unwrap,[u],w,t as PTRt(FPT _),ce) =>
230 :     (addty(w, t); PURE(P.unwrap, [vtrans u], w, t, cexptrans ce))
231 :     *)
232 :    
233 :     | PURE(P.wrap,[u],w,t,ce) =>
234 :     (addvl(w,vtrans u); cexptrans ce)
235 :     | PURE(P.unwrap,[u],w,t,ce) =>
236 :     (case u of VAR z => addty(z,t)
237 :     | _ => ();
238 :     addvl(w,vtrans u); cexptrans ce)
239 :     | PURE(P.fwrap,[u],w,t,ce) =>
240 :     if unboxedfloat
241 :     then (addty(w,t); PURE(P.fwrap,[vtrans u],w,t,cexptrans ce))
242 :     else (addvl(w,vtrans u); cexptrans ce)
243 :     | PURE(P.funwrap,[u],w,t,ce) =>
244 :     if unboxedfloat
245 :     then (addty(w,t); PURE(P.funwrap,[vtrans u],w,t,cexptrans ce))
246 :     else (addvl(w,vtrans u); cexptrans ce)
247 :     | PURE(P.iwrap,[u],w,t,ce) =>
248 :     if untaggedint
249 :     then (addty(w,t); PURE(P.iwrap,[vtrans u],w,t,cexptrans ce))
250 :     else (addvl(w,vtrans u); cexptrans ce)
251 :     | PURE(P.iunwrap,[u],w,t,ce) =>
252 :     if untaggedint
253 :     then (addty(w,t); PURE(P.iunwrap,[vtrans u],w,t,cexptrans ce))
254 :     else (addvl(w,vtrans u); cexptrans ce)
255 :     | PURE(P.i32wrap,[u],w,t,ce) =>
256 :     (addty(w,t); PURE(P.i32wrap,[vtrans u],w,t,cexptrans ce))
257 :     | PURE(P.i32unwrap,[u],w,t,ce) =>
258 :     (addty(w,t); PURE(P.i32unwrap,[vtrans u],w,t,cexptrans ce))
259 :     (*
260 :     | PURE(P.cast,[u],w,_,ce) =>
261 :     (addvl(w,vtrans u); cexptrans ce)
262 :     *)
263 :     | PURE(P.getcon,[u],w,t,ce) =>
264 :     (addty(w,t); select(0,vtrans u,w,t,cexptrans ce))
265 :     | PURE(P.getexn,[u],w,t,ce) =>
266 :     (addty(w,t); select(0,vtrans u,w,t,cexptrans ce))
267 :     | PURE(p,vl,w,t,ce) =>
268 :     (let val _ = addty(w,t)
269 :     val vl' = map vtrans vl
270 :     val ce' = cexptrans ce
271 :     in PURE(p, vl', w, getty w, ce')
272 :     end)
273 :     | BRANCH(p,vl,c,e1,e2) =>
274 :     BRANCH(p, map vtrans vl, c, cexptrans e1, cexptrans e2)
275 :    
276 :     and functrans(fk,v,args,cl,ce) =
277 :     let val _ = ListPair.app addty (args,cl)
278 :     val ce' = cexptrans ce
279 : monnier 100 in (case mkargout args
280 :     of SOME (nargs, nctys, fhdr) =>
281 :     (fk, v, nargs, nctys, fhdr ce')
282 :     | NONE => (fk, v, args, cl, ce'))
283 : monnier 16 end
284 : monnier 100
285 : monnier 16 and rectrans(v,acp) = (vtrans v,acp)
286 : monnier 100
287 : monnier 16 and vtrans(VAR v) = (mapvl v) | vtrans u = u
288 :    
289 :     in functrans fe
290 :     end
291 :    
292 :    
293 :     end (* toplevel local *)
294 :     end (* structure CPStrans *)
295 :    

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