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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 46 - (view) (download)

1 : monnier 16 (* COPYRIGHT (c) 1996 Yale FLINT Project *)
2 :     (* reify.sml *)
3 :    
4 : monnier 45 signature REIFY_NEW =
5 : monnier 16 sig
6 :     val reify : FLINT.prog -> FLINT.prog
7 :     end (* signature REIFY *)
8 :    
9 : monnier 45 structure ReifyNEW : REIFY_NEW =
10 : monnier 16 struct
11 :    
12 : monnier 45 local structure LP = TypeOperNEW
13 : monnier 16 structure LT = LtyExtern
14 :     structure LV = LambdaVar
15 :     structure DA = Access
16 :     structure DI = DebIndex
17 :     structure PO = PrimOp
18 :     structure FU = FlintUtil
19 :     val WRAP = FU.WRAP
20 :     val UNWRAP = FU.UNWRAP
21 :     open FLINT
22 :     in
23 :    
24 :     fun bug s = ErrorMsg.impossible ("Reify: " ^ s)
25 :     val say = Control.Print.say
26 :     val mkv = LambdaVar.mkLvar
27 :     val ident = fn le => le
28 :     fun option f NONE = NONE
29 :     | option f (SOME x) = SOME (f x)
30 :    
31 : monnier 45 fun dargtyc (lt, ts) =
32 :     let val skt = LT.lt_pinst(lt, map (fn _ => LT.tcc_void) ts)
33 :     val (tc, _) = LT.tcd_parrow (LT.ltd_tyc skt)
34 :     val nt = LT.lt_pinst(lt, ts)
35 :     val (rt, _) = LT.tcd_parrow (LT.ltd_tyc nt)
36 :     in (tc, rt)
37 :     end
38 :    
39 : monnier 16 (****************************************************************************
40 :     * Reify does the following several things: *
41 :     * *
42 :     * (1) Conreps in CON and DECON are given type-specific meanings. *
43 :     * (2) Type abstractions TFN are converted into function abstractions; *
44 :     * (3) Type applications TAPP are converted into function applications; *
45 :     * (4) Type-dependent primops such as WRAP/UNWRAP are given *
46 :     * type-specific meanings; *
47 :     * *
48 :     ****************************************************************************)
49 :     (* reify : fundec -> fundec *)
50 :     fun reify fdec =
51 :     let (* transform: kenv * DI.depth -> lexp -> lexp *)
52 :     fun transform (kenv, d) =
53 :     let (* lpfd: fundec -> fundec *)
54 :     fun lpfd (fk, f, vts, e) = (fk, f, vts, loop e)
55 :    
56 :     (* lpcon: con -> con * (lexp -> lexp) *)
57 :     and lpcon (DATAcon(dc as (_, DA.EXN _, nt), [], v)) =
58 :     let val z = mkv() and w = mkv()
59 :     val (ax, _) = LT.tcd_parrow(LT.ltd_tyc nt)
60 :     (* WARNING: the 3rd field should (string list) *)
61 :     val nx = LT.tcc_tuple [LT.tcc_etag ax, ax, LT.tcc_int]
62 :     in (DATAcon(dc, [], z),
63 : monnier 45 fn le => UNWRAP(nx, [VAR z], w,
64 :     SELECT(VAR w, 1, v, le)))
65 : monnier 16 end
66 : monnier 45 | lpcon (DATAcon(dc as (_, DA.UNTAGGED, lt), ts, v)) =
67 :     let val (tc, rt) = dargtyc(lt, ts)
68 :     val hdr = LP.utgd(kenv, tc, rt)
69 : monnier 16 val z = mkv()
70 :     in (DATAcon(dc, ts, z),
71 : monnier 45 fn le => LET([v], hdr(VAR z), le))
72 : monnier 16 end
73 : monnier 45 | lpcon (DATAcon(dc as (_, DA.TAGGED i, lt), ts, v)) =
74 :     let val (tc, rt) = dargtyc(lt, ts)
75 :     val hdr = LP.tgdd(kenv, i, tc, rt)
76 : monnier 16 val z = mkv()
77 :     in (DATAcon(dc, ts, z),
78 : monnier 45 fn le => LET([v], hdr(VAR z), le))
79 : monnier 16 end
80 : monnier 45 | lpcon (DATAcon(dc as (name, DA.CONSTANT _, lt), ts, v)) =
81 :     let val z = mkv()
82 :     in (DATAcon(dc, ts, z),
83 :     fn le => RECORD(FU.rk_tuple, [], v, le))
84 :     end
85 : monnier 16 | lpcon (DATAcon((name,_,lt), ts, v)) =
86 :     bug "unexpected case in lpcon"
87 :     | lpcon c = (c, ident)
88 :    
89 :     (* lpev : lexp -> (value * (lexp -> lexp)) *)
90 :     and lpev (RET [v]) = (v, ident)
91 : monnier 45 | lpev e = (* bug "lpev not implemented yet" *)
92 :     let val x= mkv()
93 :     in (VAR x, fn y => LET([x], e, y))
94 :     end
95 : monnier 16
96 :     (* loop: lexp -> lexp *)
97 :     and loop le =
98 :     (case le
99 :     of RET _ => le
100 :     | LET(vs, e1, e2) => LET(vs, loop e1, loop e2)
101 :    
102 :     | FIX(fdecs, e) => FIX(map lpfd fdecs, loop e)
103 :     | APP _ => le
104 :    
105 : monnier 45 | TFN((v, tvks, e1), e2) =>
106 :     let val (nkenv, hdr) = LP.tkAbs(kenv, tvks, v)
107 : monnier 16 val ne1 = transform (nkenv, DI.next d) e1
108 : monnier 45 in hdr(ne1, loop e2)
109 : monnier 16 (*** FIX([(fk, v, vts, hdr ne1)], loop e2) ***)
110 :     end
111 :     | TAPP(v, ts) =>
112 :     let val (u, hdr) = lpev(LP.tsLexp(kenv, ts))
113 :     in hdr (APP(v, [u]))
114 :     end
115 :    
116 :     | RECORD(rk, vs, v, e) => RECORD(rk, vs, v, loop e)
117 :     | SELECT(u, i, v, e) => SELECT(u, i, v, loop e)
118 :    
119 : monnier 45 | CON ((_, DA.CONSTANT i, _), _, _, v, e) =>
120 :     WRAP(LT.tcc_int, [INT i], v, loop e)
121 : monnier 16
122 :     | CON ((_, DA.EXN (DA.LVAR x), nt), [], u, v, e) =>
123 :     let val (ax, _) = LT.tcd_parrow(LT.ltd_tyc nt)
124 :     (***WARNING: the 3rd field should be string list *)
125 :     val nx = LT.tcc_tuple [LT.tcc_etag ax, ax, LT.tcc_int]
126 : monnier 45 val z = mkv()
127 :     in RECORD(FU.rk_tuple, [VAR x, u, INT 0], z,
128 :     WRAP(nx, [VAR z], v, loop e))
129 : monnier 16 end
130 :    
131 :     | CON ((_, DA.UNTAGGED, lt), ts, u, v, e) =>
132 : monnier 45 let val (tc, rt) = dargtyc(lt, ts)
133 :     val hdr = LP.utgc(kenv, tc, rt)
134 :     in LET([v], hdr(u), loop e)
135 : monnier 16 end
136 :     | CON ((_, DA.TAGGED i, lt), ts, u, v, e) =>
137 : monnier 45 let val (tc, rt) = dargtyc(lt, ts)
138 :     val hdr = LP.tgdc(kenv, i, tc, rt)
139 :     in LET([v], hdr(u), loop e)
140 : monnier 16 end
141 :     | CON (_, ts, u, v, e) => bug "unexpected case CON in loop"
142 :    
143 :     | SWITCH (v, csig, cases, opp) =>
144 :     let fun g (c, x) =
145 :     let val (nc, hdr) = lpcon c
146 :     in (nc, hdr(loop x))
147 :     end
148 :     in SWITCH(v, csig, map g cases, option loop opp)
149 :     end
150 :    
151 :     | RAISE _ => le
152 :     | HANDLE(e, v) => HANDLE(loop e, v)
153 :    
154 :     | BRANCH(xp as (_, _, _, []), vs, e1, e2) =>
155 :     BRANCH(xp, vs, loop e1, loop e2)
156 :     | BRANCH((_, _, _, ts), vs, e1, e2) =>
157 :     bug "type-directed branch primops are not supported"
158 :     | PRIMOP(xp as (_, _, _, []), vs, v, e) =>
159 :     PRIMOP(xp, vs, v, loop e)
160 :     | PRIMOP((d, PO.WRAP, lt, [tc]), u, v, e) =>
161 :     let val hdr = LP.mkwrp(kenv, true, tc)
162 : monnier 45 in LET([v], hdr(RET u), loop e)
163 : monnier 16 end
164 :     | PRIMOP((d, PO.UNWRAP, lt, [tc]), u, v, e) =>
165 :     let val hdr = LP.mkuwp(kenv, true, tc)
166 : monnier 45 in LET([v], hdr(RET u), loop e)
167 : monnier 16 end
168 :     | PRIMOP((d, PO.SUBSCRIPT, lt, [tc]), u, v, e) =>
169 :     let val hdr = LP.arrSub(kenv, lt, tc)
170 : monnier 45 in LET([v], hdr(u), loop e)
171 : monnier 16 end
172 : monnier 45 | PRIMOP((d, po as (PO.UPDATE | PO.UNBOXEDUPDATE
173 :     | PO.BOXEDUPDATE), lt, [tc]), u, v, e) =>
174 :     let val hdr = LP.arrUpd(kenv, po, lt, tc)
175 :     in LET([v], hdr(u), loop e)
176 : monnier 16 end
177 :     | PRIMOP((SOME {default=pv, table=[(_,rv)]},
178 :     PO.INLMKARRAY, lt, [tc]), u, v, e) =>
179 :     let val hdr = LP.arrNew(kenv, lt, tc, pv, rv)
180 : monnier 45 in LET([v], hdr(u), loop e)
181 : monnier 16 end
182 : monnier 45 | PRIMOP((_,po,_,_), vs, v, e) =>
183 :     (say ("\n####" ^ (PrimOp.prPrimop po) ^ "####\n");
184 :     bug "unexpected PRIMOP in loop"))
185 : monnier 16 in loop
186 :     end (* function transform *)
187 :    
188 :     val (fk, f, vts, e) = fdec
189 :     in (fk, f, vts, transform (LP.initKE, DI.top) e)
190 :     end (* function reify *)
191 :    
192 :     end (* toplevel local *)
193 :     end (* structure Reify *)

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