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

Annotation of /sml/trunk/src/compiler/FLINT/flint/flint2lambda.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 21 - (view) (download)

1 : monnier 21 signature FLINT2LAMBDA =
2 :     sig
3 :     type lvar = LambdaVar.lvar
4 :     type lty = LtyDef.lty
5 :    
6 :     val transVal : FLINT.value -> Lambda.value
7 :     val transLexp : FLINT.lexp -> Lambda.lexp
8 :     val transFundec : FLINT.fundec -> Lambda.lexp
9 :     end
10 :    
11 :     structure Flint2Lambda :> FLINT2LAMBDA =
12 :     struct
13 :     structure F = FLINT
14 :     structure L = Lambda
15 :    
16 :     structure A = Access
17 :     structure LV = LambdaVar
18 :     structure PO = PrimOp
19 :     structure S = Symbol
20 :     structure LT = LtyExtern
21 :    
22 :     type lvar = LambdaVar.lvar
23 :     type lty = LtyDef.lty
24 :    
25 :     fun bug msg = ErrorMsg.impossible("flint2lambda: "^msg)
26 :    
27 :     (* tuple up a list of ltys into a single lty *)
28 :     fun ltTuple [lty] = lty
29 :     | ltTuple ltys = LT.ltc_tuple ltys
30 :    
31 :     fun transVal fval =
32 :     case fval of
33 :     F.VAR lvar => L.VAR lvar
34 :     | F.INT i => L.INT i
35 :     | F.INT32 i => L.INT32 i
36 :     | F.WORD w => L.WORD w
37 :     | F.WORD32 w => L.WORD32 w
38 :     | F.REAL s => L.REAL s
39 :     | F.STRING s => L.STRING s
40 :    
41 :     fun id (value : L.value) (x : L.lexp) = x
42 :    
43 :     fun transCon fcon =
44 :     case fcon of
45 :     F.INTcon i => L.INTcon i
46 :     | F.INT32con i => L.INT32con i
47 :     | F.WORDcon w => L.WORDcon w
48 :     | F.WORD32con w => L.WORD32con w
49 :     | F.REALcon s => L.REALcon s
50 :     | F.STRINGcon s => L.STRINGcon s
51 :     | F.VLENcon i => L.VLENcon i
52 :     | F.DATAcon (dcon,_,_) => L.DATAcon dcon
53 :    
54 :     fun selectLoop record body =
55 :     let
56 :     fun loop (_, []) = transLexp body
57 :     | loop (i, lvar::lvars) =
58 :     L.LET (lvar,
59 :     L.SELECT (i, L.VAR record),
60 :     loop (i+1, lvars))
61 :     in
62 :     loop
63 :     end
64 :    
65 :     and transFundec (fkind, lvar, (* lty, *) formals, lexpBody) =
66 :     (case formals of
67 :     [(lvarArg, ltyArg)] => (* single arg function *)
68 :     L.FN (lvarArg, ltyArg, transLexp lexpBody)
69 :     | _ =>
70 :     let
71 :     val (lvarArgs, ltyArgs) = ListPair.unzip formals
72 :     val lvarArg = LV.mkLvar()
73 :     val ltyArg = ltTuple ltyArgs
74 :     in
75 :     L.FN (lvarArg, ltyArg,
76 :     selectLoop lvarArg lexpBody (0, lvarArgs))
77 :     end)
78 :    
79 :     (**
80 :     ** Warning: I think we need to wrap the result as well !!! (ZHONG)
81 :     **)
82 :     and transFundecRec (fk as {isrec=NONE, raw, isfct}, _, _, _) =
83 :     bug "unexpected case in transFundecRec"
84 :     | transFundecRec (fk as {isrec=SOME zs, raw, isfct},
85 :     lvar, formals, lexpBody) =
86 :     (case formals of
87 :     [(lvarArg, ltyArg)] => (* single arg function *)
88 :     (lvar, LT.ltc_arrow(raw, [ltyArg], zs),
89 :     L.FN (lvarArg, ltyArg, transLexp lexpBody))
90 :     | _ =>
91 :     let
92 :     val (lvarArgs, ltyArgs) = ListPair.unzip formals
93 :     val lvarArg = LV.mkLvar()
94 :     val ltyArg = ltTuple ltyArgs
95 :     in
96 :     (lvar, LT.ltc_arrow(raw, [ltyArg], zs),
97 :     L.FN (lvarArg, ltyArg,
98 :     selectLoop lvarArg lexpBody (0, lvarArgs)))
99 :     end)
100 :    
101 :     and transLexp lexp =
102 :     case lexp of
103 :     F.RET [aValue] =>
104 :     L.SVAL (transVal aValue)
105 :    
106 :     | F.RET valueList =>
107 :     L.RECORD (map transVal valueList)
108 :    
109 :     | F.APP (funValue, [singleArg]) =>
110 :     L.APP (transVal funValue,
111 :     transVal singleArg)
112 :    
113 :     | F.APP (funValue, argList) =>
114 :     let val v = LV.mkLvar()
115 :     in
116 :     L.LET (v,
117 :     L.RECORD (map transVal argList),
118 :     L.APP (transVal funValue, L.VAR v))
119 :     end
120 :    
121 :     | F.TAPP (tfunValue, tycList) =>
122 :     L.TAPP (transVal tfunValue,
123 :     tycList)
124 :    
125 :     (* LET can be tricky. If we're binding a singleton, it can be
126 :     * translated directly. If it's multiple vars and the binding
127 :     * expression is RET [v1,v2,v3] then we can do an iterated LET.
128 :     * Otherwise, the binding function could be a function call or
129 :     * something with multiple values. In this case, we will have
130 :     * to do a series of record selections.
131 :     *)
132 :     | F.LET ([lvar], lexpBinding, lexpBody) =>
133 :     let
134 :     val lexpBinding' = transLexp lexpBinding
135 :     in
136 :     (* case lexpBinding' of *)
137 :     (* L.LET (lvar', lexp', lexpBody') => *)
138 :     (* L.LET (lvar', lexp', *)
139 :     (* L.LET (lvar, lexpBody', *)
140 :     (* transLexp lexpBody)) *)
141 :     (* | _ => *)
142 :     L.LET (lvar, lexpBinding',
143 :     transLexp lexpBody)
144 :     end
145 :    
146 :     | F.LET (lvarList, lexpBinding, lexpBody) =>
147 :     let
148 :     val lvarRecord = LV.mkLvar();
149 :     val lexpBinding' = transLexp lexpBinding
150 :     in
151 :     (* case lexpBinding' of *)
152 :     (* L.LET (lvar', lexp', lexpBody') => *)
153 :     (* L.LET (lvar', lexp', *)
154 :     (* L.LET (lvarRecord, lexpBody', *)
155 :     (* selectLoop lvarRecord lexpBody *)
156 :     (* (0, lvarList))) *)
157 :     (* | _ => *)
158 :     L.LET (lvarRecord, lexpBinding',
159 :     selectLoop lvarRecord lexpBody (0, lvarList))
160 :     end
161 :    
162 :     | F.FIX ([x as (fk as {isrec=NONE,...},v,_,_)], lexpBody) =>
163 :     L.LET(v, transFundec x, transLexp lexpBody)
164 :    
165 :     | F.FIX (fundecs, lexpBody) =>
166 :     let
167 :     fun loop [] = ([], [], [])
168 :     | loop (fundec::fundecs) =
169 :     let
170 :     val (lvar, lty, lexp) = transFundecRec fundec
171 :     val (lvars, ltys, lexps) = loop fundecs
172 :     in
173 :     (lvar::lvars, lty::ltys, lexp::lexps)
174 :     end
175 :    
176 :     val (lvars, ltys, lexps) = loop fundecs
177 :     in
178 :     L.FIX (lvars, ltys, lexps, transLexp lexpBody)
179 :     end
180 :    
181 :     | F.TFN ((lvar, tformals, lexp), lexpBody) =>
182 :     let
183 :     val kinds = map #2 tformals
184 :     in
185 :     L.LET (lvar,
186 :     L.TFN (kinds, transLexp lexp),
187 :     transLexp lexpBody)
188 :     end
189 :    
190 :     | F.SWITCH (value, consig, conLexpList, lexpOpt) =>
191 :     let
192 :     val value' = transVal value
193 :    
194 :     (* straight out of normalize.sml *)
195 :     fun DECON'(dc as (_, A.REF, lt), ts, x) =
196 :     L.APP (L.PRIM (PrimOp.DEREF, LT.lt_swap lt, ts), x)
197 :     | DECON'(dc as (_, A.SUSP(SOME(_, A.LVAR f)), lt), ts, x) =
198 :     let val v = LV.mkLvar()
199 :     in L.LET(v, L.TAPP (L.VAR f, ts), L.APP (L.VAR v, x))
200 :     end
201 :     | DECON' z = L.DECON z
202 :    
203 :     fun tr (F.DATAcon (dcon, tycs, []), lexp) =
204 :     (L.DATAcon dcon, transLexp lexp)
205 :     | tr (F.DATAcon (dcon, tycs, [lvar]), lexp) =
206 :     (L.DATAcon dcon,
207 :     L.LET(lvar, DECON'(dcon, tycs, value'),
208 :     transLexp lexp))
209 :     | tr (F.DATAcon (dcon, tycs, lvars), lexp) =
210 :     let val v = LV.mkLvar()
211 :     in
212 :     (L.DATAcon dcon,
213 :     L.LET (v, DECON'(dcon, tycs, value'),
214 :     selectLoop v lexp (0, lvars)))
215 :     end
216 :     | tr (con, lexp) =
217 :     (transCon con, transLexp lexp)
218 :    
219 :     fun mapopt f NONE = NONE
220 :     | mapopt f (SOME x) = SOME (f x)
221 :     in
222 :     L.SWITCH (value',
223 :     consig,
224 :     map tr conLexpList,
225 :     mapopt transLexp lexpOpt)
226 :     end
227 :    
228 :     | F.CON (dcon, tycs, [], lvar, lexp) =>
229 :     L.LET (lvar, L.CON (dcon, tycs, L.INT 0),
230 :     transLexp lexp)
231 :     | F.CON (dcon, tycs, [value], lvar, lexp) =>
232 :     L.LET (lvar, L.CON (dcon, tycs, transVal value),
233 :     transLexp lexp)
234 :     | F.CON (dcon, tycs, values, lvar, lexp) =>
235 :     let val v = LV.mkLvar()
236 :     in
237 :     L.LET (v, L.RECORD (map transVal values),
238 :     L.LET (lvar, L.CON (dcon, tycs, L.VAR v),
239 :     transLexp lexp))
240 :     end
241 :    
242 :     | F.RECORD (F.RK_RECORD, values, lvar, lexp) =>
243 :     L.LET (lvar, L.RECORD (map transVal values), transLexp lexp)
244 :     | F.RECORD (F.RK_STRUCT, values, lvar, lexp) =>
245 :     L.LET (lvar, L.SRECORD (map transVal values), transLexp lexp)
246 :     | F.RECORD (F.RK_VECTOR tyc, values, lvar, lexp) =>
247 :     L.LET (lvar, L.VECTOR (map transVal values, tyc), transLexp lexp)
248 :    
249 :     | F.SELECT (value, i, lvar, lexp) =>
250 :     L.LET (lvar,
251 :     L.SELECT (i, transVal value),
252 :     transLexp lexp)
253 :    
254 :     | F.RAISE (value, ltys) =>
255 :     L.RAISE (transVal value, ltTuple ltys)
256 :    
257 :     | F.HANDLE (lexp, value) =>
258 :     L.HANDLE (transLexp lexp,
259 :     transVal value)
260 :    
261 :     | F.ETAG (tyc, value, lvar, lexp) =>
262 :     L.LET (lvar,
263 :     L.ETAG (transVal value,
264 :     LT.ltc_tyc tyc),
265 :     transLexp lexp)
266 :    
267 :     | F.PRIMOP (primop, [value], lvar, lexp) =>
268 :     L.LET (lvar, L.APP (L.PRIM primop, transVal value),
269 :     transLexp lexp)
270 :     | F.PRIMOP (primop, values, lvar, lexp) =>
271 :     let val v = LV.mkLvar()
272 :     in
273 :     L.LET (v, L.RECORD (map transVal values),
274 :     L.LET (lvar, L.APP (L.PRIM primop, L.VAR v),
275 :     transLexp lexp))
276 :     end
277 :    
278 :     | F.GENOP (dict, (po,lty,tycs), [value], lvar, lexp) =>
279 :     L.LET (lvar, L.APP (L.GENOP (dict,po,lty,tycs), transVal value),
280 :     transLexp lexp)
281 :     | F.GENOP (dict, (po,lty,tycs), values, lvar, lexp) =>
282 :     let val v = LV.mkLvar()
283 :     in
284 :     L.LET (v, L.RECORD (map transVal values),
285 :     L.LET (lvar, L.APP (L.GENOP (dict,po,lty,tycs), L.VAR v),
286 :     transLexp lexp))
287 :     end
288 :    
289 :     (*
290 :     | F.PACK (lty, tycs1, tycs2, v, lvar, lexp) =>
291 :     L.LET (lvar,
292 :     L.PACK (lty, tycs1, tycs2, transVal v),
293 :     transLexp lexp)
294 :     *)
295 :     | F.WRAP (tyc, v, lvar, lexp) =>
296 :     L.LET (lvar,
297 :     L.WRAP (tyc, true, transVal v),
298 :     transLexp lexp)
299 :    
300 :     | F.UNWRAP (tyc, v, lvar, lexp) =>
301 :     L.LET (lvar,
302 :     L.UNWRAP (tyc, true, transVal v),
303 :     transLexp lexp)
304 :    
305 :     end

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