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

Parent Directory | Revision Log

---

Revision 218 - (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	69	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 :			val (tc, _) = LT.tcd_parrow (LT.ltd_tyc skt)
98 :			val nt = ltf (LT.lt_pinst(lt, ts))
99 :			val (rt, _) = LT.tcd_parrow (LT.ltd_tyc nt)
100 :			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 :			val (ax,_) = LT.tcd_parrow (LT.ltd_tyc nt)
122 :			val lt_exr =
123 :			LT.tcc_tuple [LT.tcc_void, tcf ax, LT.tcc_int]
124 :			in (DATAcon(ndc, [], z),
125 :			fn le => UNWRAP(lt_exr, [VAR z], w,
126 :			SELECT(VAR w, 1, v, le)))
127 :			end
128 :			| lpcon (DATAcon(dc as (name, DA.CONSTANT _, lt), ts, v)) =
129 :			let val ndc = dcf(dc, ts) and z = mkv()
130 :			in (DATAcon(ndc, [], z),
131 :			fn le => RECORD(FU.rk_tuple, [], v, le))
132 :			end
133 :			| lpcon (DATAcon(dc as (_, DA.UNTAGGED, _), ts, v)) =
134 :			let val (tc, rt, ndc) = dargtyc(dc, ts)
135 :			val hdr = LP.utgd(tc, kenv, rt)
136 :			val z = mkv()
137 :			in (DATAcon(ndc, [], z),
138 :			fn le => LET([v], hdr(VAR z), le))
139 :			end
140 :			| lpcon (DATAcon(dc as (_, DA.TAGGED i, _), ts, v)) =
141 :			let val (tc, rt, ndc) = dargtyc(dc, ts)
142 :			val hdr = LP.tgdd(i, tc, kenv, rt)
143 :			val z = mkv()
144 :			in (DATAcon(ndc, [], z),
145 :			fn le => LET([v], hdr(VAR z), le))
146 :			end
147 :			| lpcon (DATAcon _) = bug "unexpected case in lpcon"
148 :			| lpcon c = (c, ident)
149 :
150 :			(* loop: lexp -> lexp *)
151 :			and loop le =
152 :			(case le
153 :			of RET _ => le
154 :			| LET(vs, e1, e2) => LET(vs, loop e1, loop e2)
155 :
156 :			| FIX(fdecs, e) => FIX(map lpfd fdecs, loop e)
157 :			| APP _ => le
158 :
159 :			| TFN((v, tvks, e1), e2) =>
160 :			let val (nkenv, hdr) = LP.tkAbs(kenv, tvks, v)
161 :	monnier	197	val ne1 = transform (nkenv) e1
162 :	monnier	69	in hdr(ne1, loop e2)
163 :			end
164 :			| TAPP(v, ts) =>
165 :	monnier	218	let val (us, hdr) = LP.tsLexp(kenv, ts)
166 :	monnier	16
167 :	monnier	69	(* a temporary hack that fixes type mismatches *)
168 :			val lt = getlty v
169 :			val oldts = map ltf (#2 (LT.ltd_poly lt))
170 :			val newts = map ltf (LT.lt_inst(lt, ts))
171 :			val nhdr = mcast(oldts, newts)
172 :	monnier	218	in nhdr (hdr (APP(v, us)))
173 :	monnier	69	end
174 :
175 :			| RECORD(RK_VECTOR tc, vs, v, e) =>
176 :			RECORD(RK_VECTOR (tcf tc), vs, v, loop e)
177 :			| RECORD(rk, vs, v, e) => RECORD(rk, vs, v, loop e)
178 :			| SELECT(u, i, v, e) => SELECT(u, i, v, loop e)
179 :
180 :			| CON ((_, DA.CONSTANT i, _), _, _, v, e) =>
181 :			WRAP(LT.tcc_int, [INT i], v, loop e)
182 :	monnier	16
183 :	monnier	69	| CON ((_, DA.EXN (DA.LVAR x), nt), [], u, v, e) =>
184 :			let val z = mkv()
185 :			val (ax,_) = LT.tcd_parrow (LT.ltd_tyc nt)
186 :			val lt_exr =
187 :			LT.tcc_tuple [LT.tcc_void, tcf ax, LT.tcc_int]
188 :			in RECORD(FU.rk_tuple, [VAR x, u, INT 0], z,
189 :			WRAP(lt_exr, [VAR z], v, loop e))
190 :			end
191 :	monnier	16
192 :	monnier	69	| CON (dc as (_, DA.UNTAGGED, _), ts, u, v, e) =>
193 :			let val (tc, rt, _) = dargtyc(dc, ts)
194 :			val hdr = LP.utgc(tc, kenv, rt)
195 :			in LET([v], hdr(u), loop e)
196 :			end
197 :			| CON (dc as (_, DA.TAGGED i, _), ts, u, v, e) =>
198 :			let val (tc, rt, _) = dargtyc(dc, ts)
199 :			val hdr = LP.tgdc(i, tc, kenv, rt)
200 :			in LET([v], hdr(u), loop e)
201 :			end
202 :			| CON (_, ts, u, v, e) => bug "unexpected case CON in loop"
203 :	monnier	16
204 :	monnier	69	| SWITCH (v, csig, cases, opp) =>
205 :			let fun g (c, x) =
206 :			let val (nc, hdr) = lpcon c
207 :			in (nc, hdr(loop x))
208 :			end
209 :			in SWITCH(v, csig, map g cases, option loop opp)
210 :			end
211 :
212 :			| RAISE (u, ts) => RAISE(u, map ltf ts)
213 :			| HANDLE(e, v) => HANDLE(loop e, v)
214 :
215 :			| BRANCH(xp as (NONE, po, lt, []), vs, e1, e2) =>
216 :			BRANCH((NONE, po, ltf lt, []), vs, loop e1, loop e2)
217 :			| BRANCH(_, vs, e1, e2) =>
218 :			bug "type-directed branch primops are not supported"
219 :	monnier	16
220 :	monnier	69	| PRIMOP(xp as (_, PO.WRAP, _, _), u, v, e) =>
221 :			let val tc = FU.getWrapTyc xp
222 :			val hdr = LP.mkwrp(tc, kenv, true, tcf tc)
223 :			in LET([v], hdr(RET u), loop e)
224 :			end
225 :			| PRIMOP(xp as (_, PO.UNWRAP, _, _), u, v, e) =>
226 :			let val tc = FU.getUnWrapTyc xp
227 :			val hdr = LP.mkuwp(tc, kenv, true, tcf tc)
228 :			in LET([v], hdr(RET u), loop e)
229 :			end
230 :			| PRIMOP(xp as (NONE, po, lt, []), vs, v, e) =>
231 :			PRIMOP((NONE, po, ltf lt, []), vs, v, loop e)
232 :			| PRIMOP((d, PO.SUBSCRIPT, lt, [tc]), u, v, e) =>
233 :			let val blt = ltf(LT.lt_pinst(lt, [tc]))
234 :			val rlt = ltf(LT.lt_pinst(lt, [LT.tcc_real]))
235 :			val hdr = LP.arrSub(tc, kenv, blt, rlt)
236 :			in LET([v], hdr(u), loop e)
237 :			end
238 :			| PRIMOP((d, po as (PO.UPDATE | PO.UNBOXEDUPDATE
239 :			| PO.BOXEDUPDATE), lt, [tc]), u, v, e) =>
240 :			let val blt = ltf(LT.lt_pinst(lt, [tc]))
241 :			val rlt = ltf(LT.lt_pinst(lt, [LT.tcc_real]))
242 :			val hdr = LP.arrUpd(tc, kenv, po, blt, rlt)
243 :			in LET([v], hdr(u), loop e)
244 :			end
245 :			| PRIMOP((SOME {default=pv, table=[(_,rv)]},
246 :			PO.INLMKARRAY, lt, [tc]), u, v, e) =>
247 :			let val hdr = LP.arrNew(tc, pv, rv, kenv)
248 :			in LET([v], hdr(u), loop e)
249 :			end
250 :			| PRIMOP((_,po,_,_), vs, v, e) =>
251 :			(say ("\n####" ^ (PrimOp.prPrimop po) ^ "####\n");
252 :			bug "unexpected PRIMOP in loop"))
253 :			in loop
254 :			end (* function transform *)
255 :	monnier	16
256 :	monnier	69	val (fk, f, vts, e) = fdec
257 :			in (fk, f, map (fn (v,t) => (v, ltf t)) vts,
258 :	monnier	197	transform (LP.initKE) e) before (cleanUp(); clear())
259 :	monnier	69	end (* function reify *)
260 :	monnier	16
261 :			end (* toplevel local *)
262 :			end (* structure Reify *)
263 :	monnier	93
264 :			(*
265 :	monnier	113	* $Log$
266 :	monnier	93	*)

---

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