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 422 - (view) (download)

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 : monnier 220 val say = Control_Print.say
23 : monnier 69 fun mkv _ = LambdaVar.mkLvar()
24 : monnier 184 val fkfun = {isrec=NONE,known=false,inline=IH_ALWAYS, cconv=CC_FUN 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 : monnier 251 | (PO.ASSIGN, [tc]) => (* special *)
66 :     if (LT.tc_upd_prim tc = PO.UNBOXEDUPDATE)
67 :     then ((d, PO.UNBOXEDASSIGN, lt, ts), false, false)
68 :     else ((d, p, lt, ts), false, false)
69 : monnier 69 | (PO.UPDATE, [tc]) => (* special *)
70 :     if isArrayUpd lt then
71 :     if LT.tc_eqv(tc, LT.tcc_real)
72 :     then ((d, f64upd, LT.lt_pinst(lt, ts), []), true, false)
73 :     else ((d, LT.tc_upd_prim tc, lt, ts), false, true)
74 :     else ((d, LT.tc_upd_prim tc, lt, ts), false, false)
75 :     | _ => (px, false, false))
76 : monnier 16
77 : monnier 69 val argbase = fn vs => (vs, ident)
78 :     val resbase = fn v => (v, ident)
79 : monnier 16
80 : monnier 69 end (* utility functions *)
81 : monnier 16
82 :     (****************************************************************************
83 : monnier 69 * The "wrapping" function does the following several things: *
84 : monnier 16 * *
85 : monnier 69 * (1) representation coercions are inserted at TAPP, BRANCH, PRIMOP, *
86 :     * CON, SWITCH, and RECORD(RK_VECTOR _, _). Where CON and SWITCH *
87 :     * only wrap/unwrap the arguments of a datatype constuctor while *
88 :     * RK_VECTOR just wraps the vector elements only. *
89 :     * (2) all primops in PRIM are given type-specific meanings; *
90 :     * (3) all conreps in CON and SWITCH are given type-specific meanings ?? *
91 : monnier 16 * *
92 :     ****************************************************************************)
93 : monnier 69 fun wrapping fdec =
94 :     let (* In pass1, we calculate the old type of each variables in the FLINT
95 :     * expression. We do this for the sake of having simpler wrapping code.
96 :     *)
97 : monnier 216 val {getLty=getlty, cleanUp, ...} = Recover.recover (fdec, false)
98 : monnier 16
99 : monnier 69 (** generate a set of new wrappers *)
100 :     val (tcWrap, ltWrap, tcf, ltf, cleanup2) = LT.twrap_gen true
101 : monnier 16
102 : monnier 69 fun fixDconTy lt =
103 :     if LT.ltp_ppoly lt then
104 : monnier 45 let val (ks, t) = LT.ltd_ppoly lt
105 : monnier 69 in LT.ltc_ppoly(ks, ltWrap t)
106 : monnier 45 end
107 : monnier 69 else ltWrap lt
108 : monnier 45
109 : monnier 69 (* transform : CO.wpEnv * DI.depth -> (lexp -> lexp) *)
110 :     fun transform (wenv, d) =
111 : monnier 197 let
112 : monnier 184 fun lpfd ({isrec,known,inline,cconv}, v, vts, e) =
113 :     let val nisrec = case isrec of SOME(ts,l) => SOME(map ltf ts, l)
114 :     | NONE => NONE
115 :     val ncconv = case cconv of CC_FUN fixed => CC_FUN LT.ffc_fixed
116 :     | CC_FCT => cconv
117 :     in ({isrec=nisrec, known=known,
118 :     cconv=ncconv, inline=inline},
119 :     v,
120 :     map (fn (x,t) => (x, ltf t)) vts,
121 :     loop e)
122 :     end
123 : monnier 16
124 : monnier 69 (* lpdc : dcon * tyc list * value * bool ->
125 :     (dcon * tyc list * (lexp -> lexp) * value) *)
126 :     and lpdc (dc as (name,rep,lt), ts, u, wflag) =
127 :     let (*** fixing the potential mismatch in the type *)
128 :     val ndc = (name, rep, fixDconTy lt)
129 : monnier 16
130 : monnier 69 val aty = case LT.ltd_arrow (LT.lt_pinst(lt, ts))
131 :     of (_, [x], _) => x
132 :     | _ => bug "unexpected case in lpdc"
133 :     val (naty, oaty) = (ltWrap aty, ltf aty)
134 : monnier 16
135 : monnier 69 val hdr = if wflag then CO.wrapOp(wenv,[naty],[oaty],d)
136 :     else CO.unwrapOp(wenv,[naty],[oaty],d)
137 :    
138 :    
139 :     val nts = map tcWrap ts
140 :     in case hdr
141 :     of NONE => (ndc, nts, ident, u)
142 :     | SOME hhh =>
143 :     let val z = mkv()
144 :     val nu = VAR z
145 :     in if wflag then (* CON *)
146 :     (ndc, nts, fn xe => LET([z], hhh([u]), xe), nu)
147 :     else (* DECON *)
148 :     let val x = case u of VAR q => q
149 :     | _ => bug "unexpected case in lpdc"
150 :     in (ndc, nts,
151 :     fn xe => LET([x], hhh([nu]), xe), nu)
152 :     end
153 :     end
154 :     end (* function lpdc *)
155 :    
156 :     (* lpsw : con * lexp -> con * lexp *)
157 :     and lpsw (DATAcon(dc, ts, v), e) =
158 :     let val (ndc, nts, hdr, u) = lpdc(dc, ts, VAR v, false)
159 :     in (case u
160 :     of VAR nv => (DATAcon(ndc, nts, nv), hdr(loop e))
161 :     | _ => bug "unexpected case in lpsw")
162 :     end
163 :     | lpsw (c, e) = (c, loop e)
164 :    
165 :    
166 :     (* lprim : primop -> (primop *
167 :     * (value list -> value list * (lexp -> lexp))
168 :     * (lvar -> lvar * (lexp -> lexp)))
169 :     *)
170 :     and lprim (dict, p, lt, []) =
171 :     ((dict, p, ltf lt, []), argbase, resbase)
172 :     | lprim px =
173 :     let val ((dict, np, lt, ts), issp, isdyn) = classPrim px
174 :     val nlt = ltf lt
175 :     val wts = map tcWrap ts
176 :     in if issp then (* primop has been specialized *)
177 :     ((dict, np, nlt, wts), argbase, resbase)
178 :     else (* still a polymorphic primop *)
179 :     (let val nt = LT.lt_pinst(nlt, wts)
180 :     val (_, nta, ntr) = LT.ltd_arrow nt
181 :     val ot = ltf(LT.lt_pinst(lt, ts))
182 :     val (_, ota, otr) = LT.ltd_arrow ot
183 :     val arghdr =
184 :     (case CO.wrapOp(wenv, nta, ota, d)
185 :     of NONE => argbase
186 :     | SOME hhh =>
187 :     (fn vs =>
188 :     let val nvs = map mkv vs
189 :     in (map VAR nvs,
190 :     fn le => LET(nvs, hhh(vs), le))
191 :     end))
192 :     val reshdr =
193 :     (case CO.unwrapOp(wenv, ntr, otr, d)
194 :     of NONE => resbase
195 :     | SOME hhh =>
196 :     (fn v =>
197 :     let val nv = mkv()
198 :     in (nv,
199 :     fn le => LET([v], hhh([VAR nv]), le))
200 :     end))
201 :     val npx' = if isdyn then (dict, np, nlt, wts)
202 :     else (dict, np, nt, [])
203 :     in (npx', arghdr, reshdr)
204 :     end)
205 :     end (* function lprim *)
206 :    
207 :     and loop le =
208 :     (case le
209 :     of RET _ => le
210 :     | LET (vs, e1, e2) => LET (vs, loop e1, loop e2)
211 :     | FIX (fdecs, e) => FIX(map lpfd fdecs, loop e)
212 :     | APP _ => le
213 : monnier 220 | TFN ((tfk, v, tvks, e1), e2) => (* put down all wrappers *)
214 : monnier 69 let val nwenv = CO.wpNew(wenv, d)
215 :     val ne1 = transform (nwenv, DI.next d) e1
216 : monnier 220 in TFN((tfk, v, tvks, CO.wpBuild(nwenv, ne1)), loop e2)
217 : monnier 69 end
218 :     | TAPP (v, ts) =>
219 :     let val olt = getlty v
220 :     val nts = map tcWrap ts
221 :     val nlts = LT.lt_inst(ltf olt, nts)
222 :     val olts = map ltf (LT.lt_inst(olt, ts))
223 :     val hdr = CO.unwrapOp (wenv, nlts, olts, d)
224 :     in case hdr
225 :     of NONE => TAPP(v, nts)
226 :     | SOME hhh =>
227 :     let val nvs = map mkv nlts
228 :     in LET(nvs, TAPP(v, nts), hhh(map VAR nvs))
229 : monnier 16 end
230 : monnier 69 end
231 :     | CON (dc, ts, u, v, e) =>
232 :     let val (ndc, nts, hdr, nu) = lpdc(dc, ts, u, true)
233 :     in hdr (CON(ndc, nts, nu, v, loop e))
234 :     end
235 :     | SWITCH (v, csig, cases, opp) =>
236 :     SWITCH(v, csig, map lpsw cases, option loop opp)
237 : monnier 16
238 : monnier 69 | RECORD(RK_VECTOR t, vs, v, e) =>
239 :     let val (otc, ntc) = (tcf t, tcWrap t)
240 :     val ot = LT.ltc_tyc otc
241 :     val nt = LT.ltc_tyc ntc
242 :     in (case CO.wrapOp(wenv, [nt], [ot], d)
243 :     of NONE => RECORD(RK_VECTOR ntc, vs, v, loop e)
244 :     | SOME hhh =>
245 :     let val f = mkv() and x = mkv()
246 :     fun mh xe =
247 :     FIX([(fkfun,f,[(x,ot)],hhh([VAR x]))], xe)
248 :    
249 :     fun pass([], nvs, h) =
250 :     h(RECORD(RK_VECTOR ntc,
251 :     rev nvs, v, loop e))
252 :     | pass(u::r, nvs, h) =
253 :     let val z = mkv()
254 :     fun h0 xe =
255 :     LET([z], APP(VAR f, [u]), xe)
256 :     in pass(r, (VAR z)::nvs, h o h0)
257 :     end
258 :     in pass(vs, [], mh)
259 :     end)
260 : monnier 16 end
261 : monnier 69 | RECORD (rk, vs, v, e) => RECORD(rk, vs, v, loop e)
262 :     | SELECT (u, i, v, e) => SELECT(u, i, v, loop e)
263 :    
264 :     | RAISE (u, lts) => RAISE(u, map ltf lts)
265 :     | HANDLE (e, v) => HANDLE (loop e, v)
266 :    
267 :     (* resolving the polymorphic equality in a special way *)
268 :     | BRANCH (p as (_, PO.POLYEQL, _, _), vs, e1, e2) =>
269 :     loop(Equal.equal_branch (p, vs, e1, e2))
270 :     | PRIMOP (p as (_, PO.POLYEQL, _, _), vs, v, e) =>
271 :     bug "unexpected case in wrapping"
272 : monnier 16
273 : monnier 69 (* resolving the polymorphic mkarray *)
274 :     | PRIMOP ((dict, po as PO.INLMKARRAY, lt, ts), vs, v, e) =>
275 :     let val (nlt, nts) = (ltf lt, map tcf ts)
276 :     in (case (dict, nts)
277 :     of (SOME {default=pv, table=[(_,sv)]}, [tc]) =>
278 :     if LT.tc_eqv(tc, LT.tcc_real) then
279 :     LET([v], APP(VAR sv, vs), loop e)
280 :     else
281 :     (if LT.tc_unknown tc then
282 :     PRIMOP((dict, po, nlt, nts), vs, v, loop e)
283 :     else
284 :     let val z = mkv()
285 :     in LET([z], loop(TAPP(VAR pv, ts)),
286 :     LET([v], APP(VAR z, vs), loop e))
287 :     end)
288 :     | _ => bug "unexpected case for inlmkarray")
289 : monnier 16 end
290 :    
291 : monnier 69 (* resolving the usual primops *)
292 :     | BRANCH (p, vs, e1, e2) =>
293 :     let val (np, hg, _) = lprim p
294 :     val (nvs, nh) = hg vs
295 :     in nh(BRANCH(np, nvs, loop e1, loop e2))
296 :     end
297 :     | PRIMOP (p, vs, v, e) =>
298 :     let val (np, hg1, hg2) = lprim p
299 :     val (nvs, nh1) = hg1 vs
300 :     val (nv, nh2) = hg2 v
301 :     in nh1(PRIMOP(np, nvs, nv, nh2(loop e)))
302 :     end)
303 :     in loop
304 :     end (* function transform *)
305 : monnier 16
306 : monnier 69 val (fk, f, vts, e) = fdec
307 :     val nvts = map (fn (v, t) => (v, ltf t)) vts
308 :     val wenv = CO.initWpEnv()
309 :     val ne = transform (wenv, DI.top) e
310 :     in (fk, f, nvts, CO.wpBuild(wenv, ne)) before (cleanup2(); cleanUp())
311 :     end (* function wrapping *)
312 : monnier 16
313 :     end (* toplevel local *)
314 :     end (* structure Wrapping *)
315 : monnier 93

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