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

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

Parent Directory Parent Directory | Revision Log 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