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

Annotation of /sml/trunk/src/compiler/FLINT/reps/wrapping.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 93 - (view) (download)
Original Path: sml/branches/SMLNJ/src/compiler/FLINT/reps/wrapping.sml

1 : monnier 45 (* COPYRIGHT (c) 1998 YALE FLINT PROJECT *)
2 : monnier 16 (* wrapping.sml *)
3 :    
4 : monnier 69 signature WRAPPING =
5 : monnier 16 sig
6 : monnier 69 val wrapping : FLINT.prog -> FLINT.prog
7 : monnier 16
8 :     end (* signature WRAPPING *)
9 :    
10 :     structure Wrapping : WRAPPING =
11 :     struct
12 :    
13 :     local structure CO = Coerce
14 :     structure LT = LtyExtern
15 :     structure DI = DebIndex
16 :     structure PO = PrimOp
17 : monnier 69 structure DA = Access
18 :     open FLINT
19 : monnier 16 in
20 :    
21 :     fun bug s = ErrorMsg.impossible ("Wrapping: " ^ s)
22 :     val say = Control.Print.say
23 : monnier 69 fun mkv _ = LambdaVar.mkLvar()
24 :     val fkfun = FK_FUN{isrec=NONE,known=false,inline=true, fixed=LT.ffc_fixed}
25 : monnier 16 val ident = fn le => le
26 : monnier 69 fun option f NONE = NONE
27 :     | option f (SOME x) = SOME (f x)
28 : monnier 16
29 :     (****************************************************************************
30 :     * MISC UTILITY FUNCTIONS *
31 :     ****************************************************************************)
32 : monnier 69 local val lt_upd =
33 :     let val x = LT.ltc_array (LT.ltc_tv 0)
34 :     in LT.ltc_poly([LT.tkc_mono],
35 :     [LT.ltc_arrow(LT.ffc_rrflint, [x, LT.ltc_int, LT.ltc_tv 0],
36 :     [LT.ltc_unit])])
37 :     end
38 :     val lt_sub =
39 :     let val x = LT.ltc_array (LT.ltc_tv 0)
40 :     in LT.ltc_poly([LT.tkc_mono],
41 :     [LT.ltc_arrow(LT.ffc_rrflint, [x, LT.ltc_int], [LT.ltc_tv 0])])
42 :     end
43 :     in
44 : monnier 16
45 : monnier 69 fun isArraySub t = LT.lt_eqv(t, lt_sub)
46 :     fun isArrayUpd t = LT.lt_eqv(t, lt_upd)
47 :     val f64sub = PO.NUMSUBSCRIPT{kind=PO.FLOAT 64, checked=false, immutable=false}
48 :     val f64upd = PO.NUMUPDATE{kind=PO.FLOAT 64, checked=false}
49 : monnier 16
50 : monnier 69 (* Function classPrim : primop -> primop * bool * bool takes a primop
51 :     * and classifies its kind. It returns a new primop, a flag indicates
52 :     * if this primop has been specialized, and another flag that indicates
53 :     * whether this primop is dependent on runtime type information. (ZHONG)
54 :     *)
55 :     fun classPrim(px as (d, p, lt, ts)) =
56 :     (case (p, ts)
57 :     of ((PO.NUMSUBSCRIPT _ | PO.NUMUPDATE _), _) => (* overloaded primops *)
58 :     ((d, p, LT.lt_pinst(lt, ts), []), true, false)
59 :     | (PO.SUBSCRIPT, [tc]) => (* special *)
60 :     if isArraySub lt then
61 :     if LT.tc_eqv(tc, LT.tcc_real)
62 :     then ((d, f64sub, LT.lt_pinst(lt, ts), []), true, false)
63 :     else (px, false, true)
64 :     else (px, false, false)
65 :     | (PO.UPDATE, [tc]) => (* special *)
66 :     if isArrayUpd lt then
67 :     if LT.tc_eqv(tc, LT.tcc_real)
68 :     then ((d, f64upd, LT.lt_pinst(lt, ts), []), true, false)
69 :     else ((d, LT.tc_upd_prim tc, lt, ts), false, true)
70 :     else ((d, LT.tc_upd_prim tc, lt, ts), false, false)
71 :     | _ => (px, false, false))
72 : monnier 16
73 : monnier 69 val argbase = fn vs => (vs, ident)
74 :     val resbase = fn v => (v, ident)
75 : monnier 16
76 : monnier 69 end (* utility functions *)
77 : monnier 16
78 :     (****************************************************************************
79 : monnier 69 * The "wrapping" function does the following several things: *
80 : monnier 16 * *
81 : monnier 69 * (1) representation coercions are inserted at TAPP, BRANCH, PRIMOP, *
82 :     * CON, SWITCH, and RECORD(RK_VECTOR _, _). Where CON and SWITCH *
83 :     * only wrap/unwrap the arguments of a datatype constuctor while *
84 :     * RK_VECTOR just wraps the vector elements only. *
85 :     * (2) all primops in PRIM are given type-specific meanings; *
86 :     * (3) all conreps in CON and SWITCH are given type-specific meanings ?? *
87 : monnier 16 * *
88 :     ****************************************************************************)
89 : monnier 69 fun wrapping fdec =
90 :     let (* In pass1, we calculate the old type of each variables in the FLINT
91 :     * expression. We do this for the sake of having simpler wrapping code.
92 :     *)
93 :     val {getLty=getLtyGen, cleanUp} = Recover.recover (fdec, false)
94 : monnier 16
95 : monnier 69 (** generate a set of new wrappers *)
96 :     val (tcWrap, ltWrap, tcf, ltf, cleanup2) = LT.twrap_gen true
97 : monnier 16
98 : monnier 69 fun fixDconTy lt =
99 :     if LT.ltp_ppoly lt then
100 : monnier 45 let val (ks, t) = LT.ltd_ppoly lt
101 : monnier 69 in LT.ltc_ppoly(ks, ltWrap t)
102 : monnier 45 end
103 : monnier 69 else ltWrap lt
104 : monnier 45
105 : monnier 69 (* transform : CO.wpEnv * DI.depth -> (lexp -> lexp) *)
106 :     fun transform (wenv, d) =
107 :     let val getlty = getLtyGen d
108 : monnier 16
109 : monnier 69 fun lpfd (fk, v, vts, e) =
110 :     ((case fk
111 :     of FK_FUN {isrec,known,inline,fixed} =>
112 :     let val nisrec = case isrec of SOME ts => SOME (map ltf ts)
113 :     | NONE => NONE
114 :     in FK_FUN {isrec=nisrec, known=known,
115 :     fixed=LT.ffc_fixed, inline=inline}
116 :     end
117 :     | _ => fk),
118 :     v,
119 :     map (fn (x,t) => (x, ltf t)) vts,
120 :     loop e)
121 : monnier 16
122 : monnier 69 (* lpdc : dcon * tyc list * value * bool ->
123 :     (dcon * tyc list * (lexp -> lexp) * value) *)
124 :     and lpdc (dc as (name,rep,lt), ts, u, wflag) =
125 :     let (*** fixing the potential mismatch in the type *)
126 :     val ndc = (name, rep, fixDconTy lt)
127 : monnier 16
128 : monnier 69 val aty = case LT.ltd_arrow (LT.lt_pinst(lt, ts))
129 :     of (_, [x], _) => x
130 :     | _ => bug "unexpected case in lpdc"
131 :     val (naty, oaty) = (ltWrap aty, ltf aty)
132 : monnier 16
133 : monnier 69 val hdr = if wflag then CO.wrapOp(wenv,[naty],[oaty],d)
134 :     else CO.unwrapOp(wenv,[naty],[oaty],d)
135 :    
136 :    
137 :     val nts = map tcWrap ts
138 :     in case hdr
139 :     of NONE => (ndc, nts, ident, u)
140 :     | SOME hhh =>
141 :     let val z = mkv()
142 :     val nu = VAR z
143 :     in if wflag then (* CON *)
144 :     (ndc, nts, fn xe => LET([z], hhh([u]), xe), nu)
145 :     else (* DECON *)
146 :     let val x = case u of VAR q => q
147 :     | _ => bug "unexpected case in lpdc"
148 :     in (ndc, nts,
149 :     fn xe => LET([x], hhh([nu]), xe), nu)
150 :     end
151 :     end
152 :     end (* function lpdc *)
153 :    
154 :     (* lpsw : con * lexp -> con * lexp *)
155 :     and lpsw (DATAcon(dc, ts, v), e) =
156 :     let val (ndc, nts, hdr, u) = lpdc(dc, ts, VAR v, false)
157 :     in (case u
158 :     of VAR nv => (DATAcon(ndc, nts, nv), hdr(loop e))
159 :     | _ => bug "unexpected case in lpsw")
160 :     end
161 :     | lpsw (c, e) = (c, loop e)
162 :    
163 :    
164 :     (* lprim : primop -> (primop *
165 :     * (value list -> value list * (lexp -> lexp))
166 :     * (lvar -> lvar * (lexp -> lexp)))
167 :     *)
168 :     and lprim (dict, p, lt, []) =
169 :     ((dict, p, ltf lt, []), argbase, resbase)
170 :     | lprim px =
171 :     let val ((dict, np, lt, ts), issp, isdyn) = classPrim px
172 :     val nlt = ltf lt
173 :     val wts = map tcWrap ts
174 :     in if issp then (* primop has been specialized *)
175 :     ((dict, np, nlt, wts), argbase, resbase)
176 :     else (* still a polymorphic primop *)
177 :     (let val nt = LT.lt_pinst(nlt, wts)
178 :     val (_, nta, ntr) = LT.ltd_arrow nt
179 :     val ot = ltf(LT.lt_pinst(lt, ts))
180 :     val (_, ota, otr) = LT.ltd_arrow ot
181 :     val arghdr =
182 :     (case CO.wrapOp(wenv, nta, ota, d)
183 :     of NONE => argbase
184 :     | SOME hhh =>
185 :     (fn vs =>
186 :     let val nvs = map mkv vs
187 :     in (map VAR nvs,
188 :     fn le => LET(nvs, hhh(vs), le))
189 :     end))
190 :     val reshdr =
191 :     (case CO.unwrapOp(wenv, ntr, otr, d)
192 :     of NONE => resbase
193 :     | SOME hhh =>
194 :     (fn v =>
195 :     let val nv = mkv()
196 :     in (nv,
197 :     fn le => LET([v], hhh([VAR nv]), le))
198 :     end))
199 :     val npx' = if isdyn then (dict, np, nlt, wts)
200 :     else (dict, np, nt, [])
201 :     in (npx', arghdr, reshdr)
202 :     end)
203 :     end (* function lprim *)
204 :    
205 :     and loop le =
206 :     (case le
207 :     of RET _ => le
208 :     | LET (vs, e1, e2) => LET (vs, loop e1, loop e2)
209 :     | FIX (fdecs, e) => FIX(map lpfd fdecs, loop e)
210 :     | APP _ => le
211 :     | TFN ((v, tvks, e1), e2) => (* put down all wrappers *)
212 :     let val nwenv = CO.wpNew(wenv, d)
213 :     val ne1 = transform (nwenv, DI.next d) e1
214 :     in TFN((v, tvks, CO.wpBuild(nwenv, ne1)), loop e2)
215 :     end
216 :     | TAPP (v, ts) =>
217 :     let val olt = getlty v
218 :     val nts = map tcWrap ts
219 :     val nlts = LT.lt_inst(ltf olt, nts)
220 :     val olts = map ltf (LT.lt_inst(olt, ts))
221 :     val hdr = CO.unwrapOp (wenv, nlts, olts, d)
222 :     in case hdr
223 :     of NONE => TAPP(v, nts)
224 :     | SOME hhh =>
225 :     let val nvs = map mkv nlts
226 :     in LET(nvs, TAPP(v, nts), hhh(map VAR nvs))
227 : monnier 16 end
228 : monnier 69 end
229 :     | CON (dc, ts, u, v, e) =>
230 :     let val (ndc, nts, hdr, nu) = lpdc(dc, ts, u, true)
231 :     in hdr (CON(ndc, nts, nu, v, loop e))
232 :     end
233 :     | SWITCH (v, csig, cases, opp) =>
234 :     SWITCH(v, csig, map lpsw cases, option loop opp)
235 : monnier 16
236 : monnier 69 | RECORD(RK_VECTOR t, vs, v, e) =>
237 :     let val (otc, ntc) = (tcf t, tcWrap t)
238 :     val ot = LT.ltc_tyc otc
239 :     val nt = LT.ltc_tyc ntc
240 :     in (case CO.wrapOp(wenv, [nt], [ot], d)
241 :     of NONE => RECORD(RK_VECTOR ntc, vs, v, loop e)
242 :     | SOME hhh =>
243 :     let val f = mkv() and x = mkv()
244 :     fun mh xe =
245 :     FIX([(fkfun,f,[(x,ot)],hhh([VAR x]))], xe)
246 :    
247 :     fun pass([], nvs, h) =
248 :     h(RECORD(RK_VECTOR ntc,
249 :     rev nvs, v, loop e))
250 :     | pass(u::r, nvs, h) =
251 :     let val z = mkv()
252 :     fun h0 xe =
253 :     LET([z], APP(VAR f, [u]), xe)
254 :     in pass(r, (VAR z)::nvs, h o h0)
255 :     end
256 :     in pass(vs, [], mh)
257 :     end)
258 : monnier 16 end
259 : monnier 69 | RECORD (rk, vs, v, e) => RECORD(rk, vs, v, loop e)
260 :     | SELECT (u, i, v, e) => SELECT(u, i, v, loop e)
261 :    
262 :     | RAISE (u, lts) => RAISE(u, map ltf lts)
263 :     | HANDLE (e, v) => HANDLE (loop e, v)
264 :    
265 :     (* resolving the polymorphic equality in a special way *)
266 :     | BRANCH (p as (_, PO.POLYEQL, _, _), vs, e1, e2) =>
267 :     loop(Equal.equal_branch (p, vs, e1, e2))
268 :     | PRIMOP (p as (_, PO.POLYEQL, _, _), vs, v, e) =>
269 :     bug "unexpected case in wrapping"
270 : monnier 16
271 : monnier 69 (* resolving the polymorphic mkarray *)
272 :     | PRIMOP ((dict, po as PO.INLMKARRAY, lt, ts), vs, v, e) =>
273 :     let val (nlt, nts) = (ltf lt, map tcf ts)
274 :     in (case (dict, nts)
275 :     of (SOME {default=pv, table=[(_,sv)]}, [tc]) =>
276 :     if LT.tc_eqv(tc, LT.tcc_real) then
277 :     LET([v], APP(VAR sv, vs), loop e)
278 :     else
279 :     (if LT.tc_unknown tc then
280 :     PRIMOP((dict, po, nlt, nts), vs, v, loop e)
281 :     else
282 :     let val z = mkv()
283 :     in LET([z], loop(TAPP(VAR pv, ts)),
284 :     LET([v], APP(VAR z, vs), loop e))
285 :     end)
286 :     | _ => bug "unexpected case for inlmkarray")
287 : monnier 16 end
288 :    
289 : monnier 69 (* resolving the usual primops *)
290 :     | BRANCH (p, vs, e1, e2) =>
291 :     let val (np, hg, _) = lprim p
292 :     val (nvs, nh) = hg vs
293 :     in nh(BRANCH(np, nvs, loop e1, loop e2))
294 :     end
295 :     | PRIMOP (p, vs, v, e) =>
296 :     let val (np, hg1, hg2) = lprim p
297 :     val (nvs, nh1) = hg1 vs
298 :     val (nv, nh2) = hg2 v
299 :     in nh1(PRIMOP(np, nvs, nv, nh2(loop e)))
300 :     end)
301 :     in loop
302 :     end (* function transform *)
303 : monnier 16
304 : monnier 69 val (fk, f, vts, e) = fdec
305 :     val nvts = map (fn (v, t) => (v, ltf t)) vts
306 :     val wenv = CO.initWpEnv()
307 :     val ne = transform (wenv, DI.top) e
308 :     in (fk, f, nvts, CO.wpBuild(wenv, ne)) before (cleanup2(); cleanUp())
309 :     end (* function wrapping *)
310 : monnier 16
311 :     end (* toplevel local *)
312 :     end (* structure Wrapping *)
313 : monnier 93
314 :     (*
315 :     * $Log: wrapping.sml,v $
316 :     * Revision 1.1.1.1 1998/04/08 18:39:45 george
317 :     * Version 110.5
318 :     *
319 :     *)

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