Annotation of /sml/trunk/src/compiler/FLINT/plambda/normalize.sml

Parent Directory | Revision Log

---

Revision 21 - (view) (download)

1 :	monnier	21	(* COPYRIGHT (c) 1996 Bell Laboratories *)
2 :			(* normalize.sml *)
3 :
4 :			(* Converting the Standard PLambda.lexp into the A-Normal Form *)
5 :
6 :			signature NORMLEXP =
7 :			sig
8 :			val normLexp : PLambda.lexp -> Lambda.lexp
9 :
10 :			end (* signature SPECIALIZE *)
11 :
12 :			structure NormLexp : NORMLEXP =
13 :			struct
14 :
15 :			local structure LT = PLambdaType
16 :			structure DI = DebIndex
17 :			structure PT = PrimTyc
18 :			structure L = Lambda
19 :			structure A = Access
20 :			open Access PLambda
21 :			in
22 :
23 :			val say = Control.Print.say
24 :			fun bug s = ErrorMsg.impossible ("Normalize: " ^ s)
25 :			val mkv = LambdaVar.mkLvar
26 :			val ident = fn le : L.lexp => le
27 :
28 :			fun DECON'(dc as (_, A.REF, lt), ts, x) =
29 :			L.APP (L.PRIM (PrimOp.DEREF, LT.lt_swap lt, ts), x)
30 :			| DECON'(dc as (_, A.SUSP(SOME(_, A.LVAR f)), lt), ts, x) =
31 :			let val v = mkv()
32 :			in L.LET(v, L.TAPP (L.VAR f, ts), L.APP (L.VAR v, x))
33 :			end
34 :			| DECON' z = L.DECON z
35 :
36 :			fun mksv le =
37 :			(case le
38 :			of VAR x => L.VAR x
39 :			| INT x => L.INT x
40 :			| INT32 x => L.INT32 x
41 :			| WORD x => L.WORD x
42 :			| WORD32 x => L.WORD32 x
43 :			| REAL x => L.REAL x
44 :			| STRING x => L.STRING x
45 :			| PRIM x => L.PRIM x
46 :			| _ => bug "unexpected lambda expressions in mksv")
47 :
48 :			fun lpdt {default=e1, table=es} =
49 :			let val (sv1, hdr1) = lpsv e1
50 :			val (vs, hdr2) =
51 :			foldr (fn ((t,xe), (r, h)) =>
52 :			let val (sv, nh) = lpsv xe
53 :			in (case sv
54 :			of L.VAR w => ((t,w)::r, h o nh)
55 :			| _ => bug "unexpected cases in lpdt1")
56 :			end) ([], ident) es
57 :			in (case sv1 of L.VAR v => ({default=v, table=vs}, hdr1 o hdr2)
58 :			| _ => bug "unexpected cases in lpdt2")
59 :			end
60 :
61 :
62 :			(** val lpsv : PLambda.lexp -> Lambda.value * (Lambda.lexp -> Lambda.lexp) *)
63 :			and lpsv le =
64 :			(case le
65 :			of (VAR _ | INT _ | WORD _ | INT32 _ | WORD32 _) => (mksv le, ident)
66 :			| (REAL _ | STRING _ | PRIM _) => (mksv le, ident)
67 :			| (GENOP(dc, p, lt, ts)) =>
68 :			let val (ndc, hdr) = lpdt dc
69 :			in (L.GENOP(ndc, p, lt, ts), hdr)
70 :			end
71 :			| _ =>
72 :			let val v = mkv()
73 :			val ne = loop le
74 :			in (L.VAR v, fn xe => L.LET(v, ne, xe))
75 :			end)
76 :
77 :			and lpcon (c, sv) =
78 :			(case c
79 :			of DATAcon (x, ts, v) =>
80 :			let val (nx, hdr) = lpdc x
81 :			val xh = fn z => L.LET(v, DECON'(x, ts, sv), z)
82 :			in (L.DATAcon nx, hdr, xh)
83 :			end
84 :			| INTcon x => (L.INTcon x, ident, ident)
85 :			| INT32con x => (L.INT32con x, ident, ident)
86 :			| WORDcon x => (L.WORDcon x, ident, ident)
87 :			| WORD32con x => (L.WORD32con x, ident, ident)
88 :			| REALcon x => (L.REALcon x, ident, ident)
89 :			| STRINGcon x => (L.STRINGcon x, ident, ident)
90 :			| VLENcon x => (L.VLENcon x, ident, ident))
91 :
92 :			and lpacc(PATH(acc, i)) =
93 :			let val (v, h) = lpacc acc
94 :			val w = mkv()
95 :			in (w, fn le => h(L.LET(w, L.SELECT(i, L.VAR v), le)))
96 :			end
97 :			| lpacc(LVAR v) = (v, ident)
98 :			| lpacc _ = bug "unexpected cases in lpacc"
99 :
100 :			and lpdc (s, EXN (acc as PATH _), t) =
101 :			let val (nav, hdr) = lpacc acc
102 :			in ((s, EXN (LVAR nav), t), hdr)
103 :			end
104 :			| lpdc dc = (dc, ident)
105 :
106 :			and lpes es =
107 :			let fun h (x, (vs, hdr)) =
108 :			let val (v, nh) = lpsv x
109 :			in (v::vs, nh o hdr)
110 :			end
111 :			val (vs, hdr) = List.foldr h ([], ident) es
112 :			in (vs, hdr)
113 :			end
114 :
115 :			and loop le =
116 :			(case le
117 :			of (VAR _ | INT _ | WORD _ | INT32 _ | WORD32 _) => L.SVAL (mksv le)
118 :			| (REAL _ | STRING _ | PRIM _) => L.SVAL (mksv le)
119 :			| GENOP _ => let val (sv, hdr) = lpsv le
120 :			in hdr(L.SVAL(sv))
121 :			end
122 :			| TFN (ks, e) => L.TFN(ks, loop e)
123 :			| TAPP (e, ts) =>
124 :			let val (sv, hdr) = lpsv e
125 :			in hdr(L.TAPP(sv, ts))
126 :			end
127 :			| PACK (lt, ts, nts, e) =>
128 :			let val (sv, hdr) = lpsv e
129 :			in hdr(L.PACK(lt, ts, nts, sv))
130 :			end
131 :			| CON (x, ts, e) =>
132 :			let val (sv, hdr) = lpsv e
133 :			val (nx, hdr2) = lpdc x
134 :			in hdr(hdr2(L.CON(nx, ts, sv)))
135 :			end
136 :			(*
137 :			| DECON (x, ts, e) =>
138 :			let val (sv, hdr) = lpsv e
139 :			val (nx, hdr2) = lpdc x
140 :			in hdr(hdr2(L.DECON(nx, ts, sv)))
141 :			end
142 :			*)
143 :			| SWITCH (e, reps, cases, opp) =>
144 :			let val (sv, hdr) = lpsv e
145 :			val (cases', nhdr) =
146 :			List.foldr (fn ((c,x), (cs, h)) =>
147 :			let val (nc, nh, xh) = lpcon (c, sv)
148 :			in ((nc, xh (loop x))::cs, h o nh)
149 :			end) ([], ident) cases
150 :			val opp' = (case opp of NONE => NONE | SOME x => SOME(loop x))
151 :			fun swi (sv, reps, [(_,xe)], NONE) = xe
152 :			| swi z = L.SWITCH z
153 :			in hdr(nhdr(swi(sv, reps, cases', opp')))
154 :			end
155 :			| FN(v, t, e) => L.FN(v, t, loop e)
156 :			| FIX(vs, ts, es, eb) => L.FIX(vs, ts, map loop es, loop eb)
157 :			| APP(e1, e2) =>
158 :			let val (sv1, hdr1) = lpsv e1
159 :			val (sv2, hdr2) = lpsv e2
160 :			in hdr1 (hdr2 (L.APP(sv1, sv2)))
161 :			end
162 :			| LET(v, e1, e2) => L.LET(v, loop e1, loop e2)
163 :			| RECORD es =>
164 :			let val (vs, hdr) = lpes es
165 :			in hdr(L.RECORD vs)
166 :			end
167 :			| SRECORD es =>
168 :			let val (vs, hdr) = lpes es
169 :			in hdr(L.SRECORD vs)
170 :			end
171 :			| VECTOR (es, t) =>
172 :			let val (vs, hdr) = lpes es
173 :			in hdr(L.VECTOR(vs, t))
174 :			end
175 :			| SELECT (i, e) =>
176 :			let val (sv, hdr) = lpsv e
177 :			in hdr(L.SELECT(i, sv))
178 :			end
179 :			| ETAG (e, t) =>
180 :			let val (sv, hdr) = lpsv e
181 :			in hdr(L.ETAG(sv, t))
182 :			end
183 :			| RAISE (e, t) =>
184 :			let val (sv, hdr) = lpsv e
185 :			in hdr(L.RAISE(sv, t))
186 :			end
187 :			| HANDLE (e1, e2) =>
188 :			let val (sv, hdr) = lpsv e2
189 :			in hdr(L.HANDLE(loop e1, sv))
190 :			end
191 :			| WRAP _ => bug "unexpected WRAP lexp"
192 :			| UNWRAP _ => bug "unexpected UNWRAP lexp")
193 :
194 :			fun normLexp (lexp as FN(_, _, _)) = loop lexp
195 :			| normLexp _ = bug "unexpected lambda expressions in wrapLexp"
196 :
197 :			end (* toplevel local *)
198 :			end (* structure NormLexp *)
199 :

---

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