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 18 - (view) (download)
Original Path: sml/branches/FLINT/src/compiler/FLINT/reps/reifyNEW.sml

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

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