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/branches/primop-branch-3/compiler/FLINT/reps/reify.sml
ViewVC logotype

Annotation of /sml/branches/primop-branch-3/compiler/FLINT/reps/reify.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 2389 - (view) (download)

1 : monnier 69 (* COPYRIGHT (c) 1998 YALE FLINT PROJECT *)
2 : monnier 16 (* reify.sml *)
3 :    
4 :     signature REIFY =
5 :     sig
6 : monnier 69 val reify : FLINT.prog -> FLINT.prog
7 :     end (* signature REIFY *)
8 : monnier 16
9 :     structure Reify : REIFY =
10 :     struct
11 :    
12 :     local structure LP = TypeOper
13 :     structure LT = LtyExtern
14 :     structure LV = LambdaVar
15 :     structure DA = Access
16 :     structure DI = DebIndex
17 :     structure PO = PrimOp
18 : monnier 69 structure FU = FlintUtil
19 :    
20 :     open FLINT
21 : monnier 16 in
22 :    
23 :     fun bug s = ErrorMsg.impossible ("Reify: " ^ s)
24 : monnier 220 val say = Control_Print.say
25 : monnier 16 val mkv = LambdaVar.mkLvar
26 :     val ident = fn le => le
27 : monnier 69 fun option f NONE = NONE
28 :     | option f (SOME x) = SOME (f x)
29 : monnier 16
30 : monnier 69 (** a special version of WRAP and UNWRAP for post-reify typechecking *)
31 :     val lt_arw = LT.ltc_tyc o LT.tcc_arrow
32 :     val lt_vfn = lt_arw(LT.ffc_fixed, [LT.tcc_void], [LT.tcc_void])
33 : monnier 16
34 : monnier 69 fun wty tc =
35 :     (NONE, PO.WRAP, lt_arw(LT.ffc_fixed, [tc], [LT.tcc_void]), [])
36 :     fun uwty tc =
37 :     (NONE, PO.UNWRAP, lt_arw(LT.ffc_fixed, [LT.tcc_void], [tc]), [])
38 : monnier 16
39 : monnier 69 fun WRAP(tc, vs, v, e) = PRIMOP(wty tc, vs, v, e)
40 :     fun UNWRAP(tc, vs, v, e) = PRIMOP(uwty tc, vs, v, e)
41 : monnier 16
42 : monnier 69 (** a major gross hack: use of fct_lty in WCAST primops **)
43 :     fun mkWCAST (u, oldt, newt) =
44 :     let val v = mkv()
45 :     in (fn e => PRIMOP((NONE, PO.WCAST, LT.ltc_fct([oldt],[newt]), []),
46 :     [u], v, e), v)
47 : monnier 16 end
48 :    
49 : monnier 69 fun mcastSingle (oldt, newt) =
50 :     if LT.lt_eqv(oldt, newt) then NONE
51 :     else SOME (fn u => mkWCAST(u, oldt, newt))
52 : monnier 16
53 : monnier 69 fun mcast (oldts, newts) =
54 :     let fun f (a::r, b::s, z, flag) =
55 :     (case mcastSingle(a,b)
56 :     of NONE => f(r, s, NONE::z, flag)
57 :     | x => f(r, s, x::z, false))
58 :     | f ([], [], z, flag) =
59 :     if flag then fn le => le
60 :     else (let val vs = map (fn _ => mkv()) oldts
61 :     val (hdr, nvs) =
62 :     let fun g(NONE::xx, v::yy, h, q) =
63 :     g(xx, yy, h, (VAR v)::q)
64 :     | g((SOME vh)::xx, v::yy, h, q) =
65 :     let val (h', k) = vh (VAR v)
66 :     in g(xx, yy, h o h', (VAR k)::q)
67 :     end
68 :     | g([], [], h, q) = (h, rev q)
69 :     | g _ = bug "unexpected case in mcast"
70 :     in g(rev z, vs, ident, [])
71 :     end
72 :     in fn e => LET(vs, e, hdr(RET nvs))
73 :     end)
74 :     | f _ = bug "unexpected case in mcast"
75 :     in f(oldts, newts, [], true)
76 : monnier 16 end
77 :    
78 :     (****************************************************************************
79 : monnier 69 * Reify does the following several things: *
80 : monnier 16 * *
81 :     * (1) Conreps in CON and DECON are given type-specific meanings. *
82 :     * (2) Type abstractions TFN are converted into function abstractions; *
83 :     * (3) Type applications TAPP are converted into function applications; *
84 : monnier 69 * (4) Type-dependent primops such as WRAP/UNWRAP are given *
85 :     * type-specific meanings; *
86 :     * (5) FLINT is now transformed into a monomorphically typed lambda *
87 :     * calculus. Type mismatches are fixed via the use of type cast *
88 : monnier 16 ****************************************************************************)
89 : monnier 69 (* reify : fundec -> fundec *)
90 :     fun reify fdec =
91 : monnier 216 let val {getLty=getlty, cleanUp, ...} = Recover.recover (fdec, false)
92 : monnier 69 val (tcf, ltf, clear) = LT.tnarrow_gen ()
93 : monnier 16
94 : monnier 69 fun dcf ((name,rep,lt),ts) = (name,rep,lt_vfn)
95 :     fun dargtyc ((name,rep,lt), ts) =
96 :     let val skt = LT.lt_pinst(lt, map (fn _ => LT.tcc_void) ts)
97 : gkuan 2389 val (tc, _) = LT.tcd_parrow (LT.ltd_tyc skt) handle LT.DeconExn => bug "reify in dargtyc"
98 : monnier 69 val nt = ltf (LT.lt_pinst(lt, ts))
99 : gkuan 2389 val (rt, _) = LT.tcd_parrow (LT.ltd_tyc nt) handle LT.DeconExn => bug "reify in dargtyc 2"
100 : monnier 69 in (tc, rt, (name,rep,lt_vfn))
101 :     end
102 : monnier 16
103 : monnier 69 (* transform: kenv * DI.depth -> lexp -> lexp *)
104 : monnier 197 fun transform (kenv) =
105 :     let (* lpfd: fundec -> fundec *)
106 : monnier 69 fun lpfd (fk, f, vts, e) =
107 :     let val nfk =
108 :     case fk
109 : monnier 184 of {isrec=SOME (lts,lk), cconv, known, inline} =>
110 :     {isrec=SOME(map ltf lts, lk), cconv=cconv,
111 :     known=known, inline=inline}
112 : monnier 69 | _ => fk
113 :     val nvts = map (fn (v,t) => (v, ltf t)) vts
114 :     in (nfk, f, nvts, loop e)
115 :     end
116 : monnier 16
117 : monnier 69 (* lpcon: con -> con * (lexp -> lexp) *)
118 :     and lpcon (DATAcon(dc as (_, DA.EXN _, nt), [], v)) =
119 :     let val ndc = dcf(dc, []) and z = mkv() and w = mkv()
120 :     (* WARNING: the 3rd field should (string list) *)
121 : gkuan 2389 val (ax,_) = LT.tcd_parrow (LT.ltd_tyc nt)
122 :     handle LT.DeconExn => bug "transform"
123 : monnier 69 val lt_exr =
124 :     LT.tcc_tuple [LT.tcc_void, tcf ax, LT.tcc_int]
125 :     in (DATAcon(ndc, [], z),
126 :     fn le => UNWRAP(lt_exr, [VAR z], w,
127 :     SELECT(VAR w, 1, v, le)))
128 :     end
129 :     | lpcon (DATAcon(dc as (name, DA.CONSTANT _, lt), ts, v)) =
130 :     let val ndc = dcf(dc, ts) and z = mkv()
131 :     in (DATAcon(ndc, [], z),
132 :     fn le => RECORD(FU.rk_tuple, [], v, le))
133 :     end
134 :     | lpcon (DATAcon(dc as (_, DA.UNTAGGED, _), ts, v)) =
135 :     let val (tc, rt, ndc) = dargtyc(dc, ts)
136 :     val hdr = LP.utgd(tc, kenv, rt)
137 :     val z = mkv()
138 :     in (DATAcon(ndc, [], z),
139 :     fn le => LET([v], hdr(VAR z), le))
140 :     end
141 :     | lpcon (DATAcon(dc as (_, DA.TAGGED i, _), ts, v)) =
142 :     let val (tc, rt, ndc) = dargtyc(dc, ts)
143 :     val hdr = LP.tgdd(i, tc, kenv, rt)
144 :     val z = mkv()
145 :     in (DATAcon(ndc, [], z),
146 :     fn le => LET([v], hdr(VAR z), le))
147 :     end
148 :     | lpcon (DATAcon _) = bug "unexpected case in lpcon"
149 :     | lpcon c = (c, ident)
150 :    
151 : monnier 220 (* lpev : lexp -> (value * (lexp -> lexp)) *)
152 :     and lpev (RET [v]) = (v, ident)
153 :     | lpev e = (* bug "lpev not implemented yet" *)
154 :     let val x= mkv()
155 :     in (VAR x, fn y => LET([x], e, y))
156 :     end
157 :    
158 : monnier 69 (* loop: lexp -> lexp *)
159 :     and loop le =
160 :     (case le
161 :     of RET _ => le
162 :     | LET(vs, e1, e2) => LET(vs, loop e1, loop e2)
163 :    
164 :     | FIX(fdecs, e) => FIX(map lpfd fdecs, loop e)
165 :     | APP _ => le
166 :    
167 : monnier 220 | TFN((tfk, v, tvks, e1), e2) =>
168 : monnier 69 let val (nkenv, hdr) = LP.tkAbs(kenv, tvks, v)
169 : monnier 197 val ne1 = transform (nkenv) e1
170 : monnier 69 in hdr(ne1, loop e2)
171 :     end
172 :     | TAPP(v, ts) =>
173 : monnier 220 let val (u, hdr) = lpev(LP.tsLexp(kenv, ts))
174 : monnier 16
175 : monnier 69 (* a temporary hack that fixes type mismatches *)
176 :     val lt = getlty v
177 :     val oldts = map ltf (#2 (LT.ltd_poly lt))
178 :     val newts = map ltf (LT.lt_inst(lt, ts))
179 :     val nhdr = mcast(oldts, newts)
180 : monnier 220 in nhdr (hdr (APP(v, [u])))
181 : monnier 69 end
182 :    
183 :     | RECORD(RK_VECTOR tc, vs, v, e) =>
184 :     RECORD(RK_VECTOR (tcf tc), vs, v, loop e)
185 :     | RECORD(rk, vs, v, e) => RECORD(rk, vs, v, loop e)
186 :     | SELECT(u, i, v, e) => SELECT(u, i, v, loop e)
187 :    
188 :     | CON ((_, DA.CONSTANT i, _), _, _, v, e) =>
189 :     WRAP(LT.tcc_int, [INT i], v, loop e)
190 : monnier 16
191 : monnier 69 | CON ((_, DA.EXN (DA.LVAR x), nt), [], u, v, e) =>
192 :     let val z = mkv()
193 : gkuan 2389 val (ax,_) = LT.tcd_parrow (LT.ltd_tyc nt)
194 :     handle LT.DeconExn => bug "transform loop"
195 : monnier 69 val lt_exr =
196 :     LT.tcc_tuple [LT.tcc_void, tcf ax, LT.tcc_int]
197 :     in RECORD(FU.rk_tuple, [VAR x, u, INT 0], z,
198 :     WRAP(lt_exr, [VAR z], v, loop e))
199 :     end
200 : monnier 16
201 : monnier 69 | CON (dc as (_, DA.UNTAGGED, _), ts, u, v, e) =>
202 :     let val (tc, rt, _) = dargtyc(dc, ts)
203 :     val hdr = LP.utgc(tc, kenv, rt)
204 :     in LET([v], hdr(u), loop e)
205 :     end
206 :     | CON (dc as (_, DA.TAGGED i, _), ts, u, v, e) =>
207 :     let val (tc, rt, _) = dargtyc(dc, ts)
208 :     val hdr = LP.tgdc(i, tc, kenv, rt)
209 :     in LET([v], hdr(u), loop e)
210 :     end
211 :     | CON (_, ts, u, v, e) => bug "unexpected case CON in loop"
212 : monnier 16
213 : monnier 69 | SWITCH (v, csig, cases, opp) =>
214 :     let fun g (c, x) =
215 :     let val (nc, hdr) = lpcon c
216 :     in (nc, hdr(loop x))
217 :     end
218 :     in SWITCH(v, csig, map g cases, option loop opp)
219 :     end
220 :    
221 :     | RAISE (u, ts) => RAISE(u, map ltf ts)
222 :     | HANDLE(e, v) => HANDLE(loop e, v)
223 :    
224 :     | BRANCH(xp as (NONE, po, lt, []), vs, e1, e2) =>
225 :     BRANCH((NONE, po, ltf lt, []), vs, loop e1, loop e2)
226 :     | BRANCH(_, vs, e1, e2) =>
227 :     bug "type-directed branch primops are not supported"
228 : monnier 16
229 : monnier 69 | PRIMOP(xp as (_, PO.WRAP, _, _), u, v, e) =>
230 :     let val tc = FU.getWrapTyc xp
231 :     val hdr = LP.mkwrp(tc, kenv, true, tcf tc)
232 :     in LET([v], hdr(RET u), loop e)
233 :     end
234 :     | PRIMOP(xp as (_, PO.UNWRAP, _, _), u, v, e) =>
235 :     let val tc = FU.getUnWrapTyc xp
236 :     val hdr = LP.mkuwp(tc, kenv, true, tcf tc)
237 :     in LET([v], hdr(RET u), loop e)
238 :     end
239 :     | PRIMOP(xp as (NONE, po, lt, []), vs, v, e) =>
240 :     PRIMOP((NONE, po, ltf lt, []), vs, v, loop e)
241 :     | PRIMOP((d, PO.SUBSCRIPT, lt, [tc]), u, v, e) =>
242 :     let val blt = ltf(LT.lt_pinst(lt, [tc]))
243 :     val rlt = ltf(LT.lt_pinst(lt, [LT.tcc_real]))
244 :     val hdr = LP.arrSub(tc, kenv, blt, rlt)
245 :     in LET([v], hdr(u), loop e)
246 :     end
247 :     | PRIMOP((d, po as (PO.UPDATE | PO.UNBOXEDUPDATE
248 :     | PO.BOXEDUPDATE), lt, [tc]), u, v, e) =>
249 :     let val blt = ltf(LT.lt_pinst(lt, [tc]))
250 :     val rlt = ltf(LT.lt_pinst(lt, [LT.tcc_real]))
251 :     val hdr = LP.arrUpd(tc, kenv, po, blt, rlt)
252 :     in LET([v], hdr(u), loop e)
253 :     end
254 :     | PRIMOP((SOME {default=pv, table=[(_,rv)]},
255 :     PO.INLMKARRAY, lt, [tc]), u, v, e) =>
256 :     let val hdr = LP.arrNew(tc, pv, rv, kenv)
257 :     in LET([v], hdr(u), loop e)
258 :     end
259 :     | PRIMOP((_,po,_,_), vs, v, e) =>
260 :     (say ("\n####" ^ (PrimOp.prPrimop po) ^ "####\n");
261 :     bug "unexpected PRIMOP in loop"))
262 :     in loop
263 :     end (* function transform *)
264 : monnier 16
265 : monnier 69 val (fk, f, vts, e) = fdec
266 :     in (fk, f, map (fn (v,t) => (v, ltf t)) vts,
267 : monnier 197 transform (LP.initKE) e) before (cleanUp(); clear())
268 : monnier 69 end (* function reify *)
269 : monnier 16
270 :     end (* toplevel local *)
271 :     end (* structure Reify *)

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