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

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

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