Annotation of /sml/branches/SMLNJ/src/compiler/FLINT/trans/translate.sml

Parent Directory | Revision Log

---

Revision 113 - (view) (download)

1 :	monnier	16	(* COPYRIGHT (c) 1996 Bell Laboratories *)
2 :			(* translate.sml *)
3 :
4 :			signature TRANSLATE =
5 :			sig
6 :
7 :			(* Invariant: transDec always applies to a top-level absyn declaration *)
8 :	monnier	45	val transDec : Absyn.dec * Access.lvar list
9 :			* StaticEnv.staticEnv * CompBasic.compInfo
10 :			-> {flint: FLINT.prog,
11 :	monnier	100	imports: (PersStamps.persstamp
12 :			* CompBasic.importTree) list}
13 :	monnier	16
14 :			end (* signature TRANSLATE *)
15 :
16 :			structure Translate : TRANSLATE =
17 :			struct
18 :
19 :			local structure B = Bindings
20 :			structure BT = BasicTypes
21 :			structure DA = Access
22 :			structure DI = DebIndex
23 :			structure EM = ErrorMsg
24 :	monnier	45	structure CB = CompBasic
25 :	monnier	16	structure II = InlInfo
26 :			structure LT = PLambdaType
27 :			structure M = Modules
28 :			structure MC = MatchComp
29 :			structure PO = PrimOp
30 :			structure PP = PrettyPrint
31 :			structure S = Symbol
32 :	monnier	100	structure SP = SymPath
33 :	monnier	16	structure LN = LiteralToNum
34 :			structure TT = TransTypes
35 :			structure TP = Types
36 :			structure TU = TypesUtil
37 :			structure V = VarCon
38 :
39 :			structure Map = PersMap
40 :
41 :			open Absyn PLambda
42 :			in
43 :
44 :			(****************************************************************************
45 :			* CONSTANTS AND UTILITY FUNCTIONS *
46 :			****************************************************************************)
47 :
48 :			val debugging = ref true
49 :			fun bug msg = EM.impossible("Translate: " ^ msg)
50 :			val say = Control.Print.say
51 :			val ppDepth = Control.Print.printDepth
52 :
53 :			fun ppType ty =
54 :			ElabDebug.withInternals
55 :			(fn () => ElabDebug.debugPrint debugging
56 :			("type: ",PPType.ppType StaticEnv.empty, ty))
57 :
58 :			fun ident x = x
59 :			val unitLexp = RECORD []
60 :
61 :	monnier	100	fun getNameOp p = if SP.null p then NONE else SOME(SP.last p)
62 :
63 :	monnier	16	type pid = PersStamps.persstamp
64 :
65 :			(** old-style fold for cases where it is partially applied *)
66 :			fun fold f l init = foldr f init l
67 :
68 :			(*
69 :			* MAJOR CLEANUP REQUIRED ! The function mkv is currently directly taken
70 :			* from the LambdaVar module; I think it should be taken from the
71 :			* "compInfo". Similarly, should we replace all mkLvar in the backend
72 :			* with the mkv in "compInfo" ? (ZHONG)
73 :			*)
74 :	monnier	100	val mkv = LambdaVar.mkLvar
75 :			fun mkvN NONE = mkv()
76 :			| mkvN (SOME s) = LambdaVar.namedLvar s
77 :	monnier	16
78 :			(** sorting the record fields for record types and record expressions *)
79 :			fun elemgtr ((LABEL{number=x,...},_),(LABEL{number=y,...},_)) = (x>y)
80 :			fun sorted x = Sort.sorted elemgtr x
81 :			fun sortrec x = Sort.sort elemgtr x
82 :
83 :	monnier	100	(** check if an access is external *)
84 :			fun extern (DA.EXTERN _) = true
85 :			| extern (DA.PATH(a, _)) = extern a
86 :			| extern _ = false
87 :
88 :	monnier	45	(** an exception raised if coreEnv is not available *)
89 :			exception NoCore
90 :
91 :			(****************************************************************************
92 :			* MAIN FUNCTION *
93 :			* *
94 :	monnier	100	* val transDec : Absyn.dec * Access.lvar list *
95 :			* * StaticEnv.staticEnv * CompBasic.compInfo *
96 :			* -> {flint: FLINT.prog, *
97 :			* imports: (PersStamps.persstamp *
98 :			* * CompBasic.importTree) list} *
99 :	monnier	45	****************************************************************************)
100 :
101 :			fun transDec (rootdec, exportLvars, env,
102 :			compInfo as {coreEnv,errorMatch,error,...}: CB.compInfo) =
103 :			let
104 :
105 :			(** generate the set of ML-to-FLINT type translation functions *)
106 :			val {tpsKnd, tpsTyc, toTyc, toLty, strLty, fctLty} = TT.genTT()
107 :			fun toTcLt d = (toTyc d, toLty d)
108 :
109 :	monnier	16	(** translating the typ field in DATACON into lty; constant datacons
110 :			will take ltc_unit as the argument *)
111 :			fun toDconLty d ty =
112 :			(case ty
113 :			of TP.POLYty{sign, tyfun=TP.TYFUN{arity, body}} =>
114 :	monnier	45	if BT.isArrowType body then toLty d ty
115 :			else toLty d (TP.POLYty{sign=sign,
116 :	monnier	16	tyfun=TP.TYFUN{arity=arity,
117 :			body=BT.-->(BT.unitTy, body)}})
118 :	monnier	45	| _ => if BT.isArrowType ty then toLty d ty
119 :			else toLty d (BT.-->(BT.unitTy, ty)))
120 :	monnier	16
121 :			(** the special lookup functions for the Core environment *)
122 :			fun coreLookup(id, env) =
123 :			let val sp = SymPath.SPATH [S.strSymbol "Core", S.varSymbol id]
124 :			val err = fn _ => fn _ => fn _ => raise NoCore
125 :			in Lookup.lookVal(env, sp, err)
126 :			end
127 :
128 :			fun CON' ((_, DA.REF, lt), ts, e) = APP (PRIM (PO.MAKEREF, lt, ts), e)
129 :			| CON' ((_, DA.SUSP (SOME(DA.LVAR d, _)), lt), ts, e) =
130 :	monnier	106	let val v = mkv ()
131 :			val fe = FN (v, LT.ltc_tuple [], e)
132 :			in APP(TAPP (VAR d, ts), fe)
133 :			end
134 :	monnier	16	| CON' x = CON x
135 :
136 :			(*
137 :			* The following code implements the exception tracking and
138 :			* errormsg reporting.
139 :			*)
140 :
141 :			local val region = ref(0,0)
142 :			val markexn = PRIM(PO.MARKEXN,
143 :	monnier	69	LT.ltc_parrow(LT.ltc_tuple [LT.ltc_exn, LT.ltc_string],
144 :			LT.ltc_exn), [])
145 :	monnier	16	in
146 :
147 :			fun withRegion loc f x =
148 :			let val r = !region
149 :			in (region := loc; f x before region:=r)
150 :			handle e => (region := r; raise e)
151 :			end
152 :
153 :			fun mkRaise(x, lt) =
154 :			let val e = if !Control.trackExn
155 :			then APP(markexn, RECORD[x, STRING(errorMatch(!region))])
156 :			else x
157 :			in RAISE(e, lt)
158 :			end
159 :
160 :			fun complain s = error (!region) s
161 :			fun repErr x = complain EM.COMPLAIN x EM.nullErrorBody
162 :
163 :			end (* markexn-local *)
164 :
165 :	monnier	100	(***************************************************************************
166 :			* SHARING AND LIFTING OF STRUCTURE IMPORTS AND ACCESSES *
167 :			***************************************************************************)
168 :
169 :	monnier	16	exception HASHTABLE
170 :			type key = int
171 :
172 :	monnier	100	(** hashkey of accesspath + accesspath + resvar *)
173 :			type info = (key * int list * lvar)
174 :	monnier	16	val hashtable : info list Intmap.intmap = Intmap.new(32,HASHTABLE)
175 :			fun hashkey l = foldr (fn (x,y) => ((x * 10 + y) mod 1019)) 0 l
176 :
177 :	monnier	100	fun buildHdr v =
178 :	monnier	16	let val info = Intmap.map hashtable v
179 :	monnier	100	fun h((_, l, w), hdr) =
180 :	monnier	16	let val le = foldl (fn (k,e) => SELECT(k,e)) (VAR v) l
181 :	monnier	100	in fn e => hdr(LET(w, le, e))
182 :	monnier	16	end
183 :			in foldr h ident info
184 :			end handle _ => ident
185 :
186 :	monnier	100	fun bindvar (v, [], _) = v
187 :			| bindvar (v, l, nameOp) =
188 :			let val info = (Intmap.map hashtable v) handle _ => []
189 :			val key = hashkey l
190 :			fun h [] =
191 :			let val u = mkvN nameOp
192 :			in Intmap.add hashtable (v,(key,l,u)::info); u
193 :			end
194 :			| h((k',l',w)::r) =
195 :			if (k' = key) then (if (l'=l) then w else h r) else h r
196 :			in h info
197 :			end
198 :	monnier	16
199 :	monnier	100	datatype pidInfo = ANON of (int * pidInfo) list
200 :			| NAMED of lvar * lty * (int * pidInfo) list
201 :
202 :			fun mkPidInfo (t, l, nameOp) =
203 :			let val v = mkvN nameOp
204 :			fun h [] = NAMED(v, t, [])
205 :			| h (a::r) = ANON [(a, h r)]
206 :			in (h l, v)
207 :	monnier	16	end
208 :
209 :	monnier	100	fun mergePidInfo (pi, t, l, nameOp) =
210 :			let fun h (z as NAMED(v,_,_), []) = (z, v)
211 :			| h (ANON xl, []) =
212 :			let val v = mkvN nameOp
213 :			in (NAMED(v, t, xl), v)
214 :			end
215 :			| h (z, a::r) =
216 :			let val (xl, mknode) =
217 :			case z of ANON c => (c, ANON)
218 :			| NAMED (v,tt,c) => (c, fn x => NAMED(v,tt,x))
219 :	monnier	16
220 :	monnier	100	fun dump ((np, v), z, y) =
221 :			let val nz = (a, np)::z
222 :			in (mknode((rev y) @ nz), v)
223 :			end
224 :
225 :			fun look ([], y) = dump(mkPidInfo(t, r, nameOp), [], y)
226 :			| look (u as ((x as (i,pi))::z), y) =
227 :			if i < a then look(z, x::y)
228 :			else if i = a then dump(h(pi, r), z, y)
229 :			else dump(mkPidInfo(t, r, nameOp), u, y)
230 :
231 :			in look(xl, [])
232 :			end
233 :			in h(pi, l)
234 :			end (* end of mergePidInfo *)
235 :
236 :	monnier	16	(** a map that stores information about external references *)
237 :	monnier	100	val persmap = ref (Map.empty : pidInfo Map.map)
238 :	monnier	16
239 :	monnier	100	fun mkPid (pid, t, l, nameOp) =
240 :			(let val pinfo = Map.lookup (!persmap) pid
241 :			val (npinfo, var) = mergePidInfo (pinfo, t, l, nameOp)
242 :			in persmap := Map.add(Map.delete(pid, !persmap), pid, npinfo); var
243 :	monnier	16	end handle Map.MapF =>
244 :	monnier	100	let val (pinfo, var) = mkPidInfo (t, l, nameOp)
245 :			in persmap := Map.add(!persmap, pid, pinfo); var
246 :	monnier	16	end)
247 :
248 :			(** converting an access w. type into a lambda expression *)
249 :	monnier	100	fun mkAccT (p, t, nameOp) =
250 :			let fun h(DA.LVAR v, l) = bindvar(v, l, nameOp)
251 :			| h(DA.EXTERN pid, l) = mkPid(pid, t, l, nameOp)
252 :	monnier	16	| h(DA.PATH(a,i), l) = h(a, i::l)
253 :			| h _ = bug "unexpected access in mkAccT"
254 :			in VAR (h(p, []))
255 :			end (* new def for mkAccT *)
256 :
257 :			(** converting an access into a lambda expression *)
258 :	monnier	100	fun mkAcc (p, nameOp) =
259 :			let fun h(DA.LVAR v, l) = bindvar(v, l, nameOp)
260 :	monnier	16	| h(DA.PATH(a,i), l) = h(a, i::l)
261 :			| h _ = bug "unexpected access in mkAcc"
262 :			in VAR (h(p, []))
263 :			end (* new def for mkAcc *)
264 :
265 :			(*
266 :			* These two functions are major gross hacks. The NoCore exceptions would
267 :			* be raised when compiling boot/dummy.sml, boot/assembly.sig, and
268 :			* boot/core.sml; the assumption is that the result of coreExn and coreAcc
269 :			* would never be used when compiling these three files. A good way to
270 :			* clean up this is to put all the core constructors and primitives into
271 :			* the primitive environment. (ZHONG)
272 :			*)
273 :			fun coreExn id =
274 :			((case coreLookup(id, coreEnv)
275 :			of V.CON(TP.DATACON{name, rep as DA.EXN _, typ, ...}) =>
276 :			let val nt = toDconLty DI.top typ
277 :	monnier	100	val nrep = mkRep(rep, nt, name)
278 :	monnier	16	in CON'((name, nrep, nt), [], unitLexp)
279 :			end
280 :			| _ => bug "coreExn in translate")
281 :			handle NoCore => (say "WARNING: no Core access \n"; INT 0))
282 :
283 :			and coreAcc id =
284 :			((case coreLookup(id, coreEnv)
285 :	monnier	100	of V.VAL(V.VALvar{access, typ, path, ...}) =>
286 :			mkAccT(access, toLty DI.top (!typ), getNameOp path)
287 :	monnier	16	| _ => bug "coreAcc in translate")
288 :			handle NoCore => (say "WARNING: no Core access \n"; INT 0))
289 :
290 :
291 :			(** expands the flex record pattern and convert the EXN access pat *)
292 :			(** internalize the conrep's access, always exceptions *)
293 :	monnier	100	and mkRep (rep, lt, name) =
294 :			let fun g (DA.LVAR v, l, t) = bindvar(v, l, SOME name)
295 :			| g (DA.PATH(a, i), l, t) = g(a, i::l, t)
296 :			| g (DA.EXTERN p, l, t) = mkPid(p, t, l, SOME name)
297 :	monnier	16	| g _ = bug "unexpected access in mkRep"
298 :
299 :			in case rep
300 :			of (DA.EXN x) =>
301 :			let val (argt, _) = LT.ltd_parrow lt
302 :			in DA.EXN (DA.LVAR (g(x, [], LT.ltc_etag argt)))
303 :			end
304 :			| (DA.SUSP NONE) => (* a hack to support "delay-force" primitives *)
305 :			(case (coreAcc "delay", coreAcc "force")
306 :			of (VAR x, VAR y) => DA.SUSP(SOME (DA.LVAR x, DA.LVAR y))
307 :			| _ => bug "unexpected case on conrep SUSP 1")
308 :			| (DA.SUSP (SOME _)) => bug "unexpected case on conrep SUSP 2"
309 :			| _ => rep
310 :			end
311 :
312 :			(** converting a value of access+info into the lambda expression *)
313 :	monnier	100	fun mkAccInfo (acc, info, getLty, nameOp) =
314 :			if extern acc then mkAccT(acc, getLty(), nameOp) else mkAcc (acc, nameOp)
315 :	monnier	16
316 :			fun fillPat(pat, d) =
317 :			let fun fill (CONSTRAINTpat (p,t)) = fill p
318 :			| fill (LAYEREDpat (p,q)) = LAYEREDpat(fill p, fill q)
319 :			| fill (RECORDpat {fields, flex=false, typ}) =
320 :			RECORDpat{fields = map (fn (lab, p) => (lab, fill p)) fields,
321 :			typ = typ, flex = false}
322 :			| fill (pat as RECORDpat {fields, flex=true, typ}) =
323 :			let exception DontBother
324 :			val fields' = map (fn (l,p) => (l, fill p)) fields
325 :
326 :			fun find (t as TP.CONty(TP.RECORDtyc labels, _)) =
327 :			(typ := t; labels)
328 :			| find _ = (complain EM.COMPLAIN "unresolved flexible record"
329 :			(fn ppstrm =>
330 :			(PP.add_newline ppstrm;
331 :			PP.add_string ppstrm "pattern: ";
332 :			PPAbsyn.ppPat env ppstrm
333 :			(pat,!Control.Print.printDepth)));
334 :			raise DontBother)
335 :
336 :			fun merge (a as ((id,p)::r), lab::s) =
337 :			if S.eq(id,lab) then (id,p) :: merge(r,s)
338 :			else (lab,WILDpat) :: merge(a,s)
339 :			| merge ([], lab::s) = (lab,WILDpat) :: merge([], s)
340 :			| merge ([], []) = []
341 :			| merge _ = bug "merge in translate"
342 :
343 :			in RECORDpat{fields = merge(fields',
344 :			find(TU.headReduceType (!typ))),
345 :			flex = false, typ = typ}
346 :			handle DontBother => WILDpat
347 :			end
348 :			| fill (VECTORpat(pats,ty)) = VECTORpat(map fill pats, ty)
349 :			| fill (ORpat(p1, p2)) = ORpat(fill p1, fill p2)
350 :	monnier	106	| fill (CONpat(TP.DATACON{name, const, typ, rep, sign, lazyp}, ts)) =
351 :			CONpat(TP.DATACON{name=name, const=const, typ=typ, lazyp=lazyp,
352 :	monnier	100	sign=sign, rep=mkRep(rep, toDconLty d typ, name)}, ts)
353 :	monnier	106	| fill (APPpat(TP.DATACON{name, const, typ, rep, sign, lazyp}, ts, pat)) =
354 :			APPpat(TP.DATACON{name=name, const=const, typ=typ, sign=sign, lazyp=lazyp,
355 :	monnier	100	rep=mkRep(rep, toDconLty d typ, name)}, ts, fill pat)
356 :	monnier	16	| fill xp = xp
357 :
358 :			in fill pat
359 :			end (* function fillPat *)
360 :
361 :			(** The runtime polymorphic equality and string equality dictionary. *)
362 :			val eqDict =
363 :			let val strEqRef : lexp option ref = ref NONE
364 :			val polyEqRef : lexp option ref = ref NONE
365 :
366 :			fun getStrEq () =
367 :			(case (!strEqRef)
368 :			of SOME e => e
369 :			| NONE => (let val e = coreAcc "stringequal"
370 :			in strEqRef := (SOME e); e
371 :			end))
372 :
373 :			fun getPolyEq () =
374 :			(case (!polyEqRef)
375 :			of SOME e => e
376 :			| NONE => (let val e = coreAcc "polyequal"
377 :			in polyEqRef := (SOME e); e
378 :			end))
379 :			in {getStrEq=getStrEq, getPolyEq=getPolyEq}
380 :			end
381 :
382 :			val eqGen = PEqual.equal (eqDict, env)
383 :
384 :			(***************************************************************************
385 :			* *
386 :			* Translating the primops; this should be moved into a separate file *
387 :			* in the future. (ZHONG) *
388 :			* *
389 :			***************************************************************************)
390 :
391 :			val lt_tyc = LT.ltc_tyc
392 :			val lt_arw = LT.ltc_parrow
393 :			val lt_tup = LT.ltc_tuple
394 :			val lt_int = LT.ltc_int
395 :			val lt_int32 = LT.ltc_int32
396 :			val lt_bool = LT.ltc_bool
397 :
398 :			val lt_ipair = lt_tup [lt_int, lt_int]
399 :			val lt_icmp = lt_arw (lt_ipair, lt_bool)
400 :			val lt_ineg = lt_arw (lt_int, lt_int)
401 :			val lt_intop = lt_arw (lt_ipair, lt_int)
402 :
403 :			val boolsign = BT.boolsign
404 :			val (trueDcon', falseDcon') =
405 :			let val lt = LT.ltc_parrow(LT.ltc_unit, LT.ltc_bool)
406 :			fun h (TP.DATACON{name,rep,typ,...}) = (name, rep, lt)
407 :			in (h BT.trueDcon, h BT.falseDcon)
408 :			end
409 :
410 :			val trueLexp = CON(trueDcon', [], unitLexp)
411 :			val falseLexp = CON(falseDcon', [], unitLexp)
412 :
413 :			fun COND(a,b,c) =
414 :			SWITCH(a,boolsign, [(DATAcon(trueDcon', [], mkv()),b),
415 :			(DATAcon(falseDcon', [], mkv()),c)], NONE)
416 :
417 :			fun composeNOT (eq, t) =
418 :			let val v = mkv()
419 :			val argt = lt_tup [t, t]
420 :			in FN(v, argt, COND(APP(eq, VAR v), falseLexp, trueLexp))
421 :			end
422 :
423 :			fun intOp p = PRIM(p, lt_intop, [])
424 :			fun cmpOp p = PRIM(p, lt_icmp, [])
425 :			fun inegOp p = PRIM(p, lt_ineg, [])
426 :
427 :			fun ADD(b,c) = APP(intOp(PO.IADD), RECORD[b, c])
428 :			fun SUB(b,c) = APP(intOp(PO.ISUB), RECORD[b, c])
429 :			fun MUL(b,c) = APP(intOp(PO.IMUL), RECORD[b, c])
430 :			fun DIV(b,c) = APP(intOp(PO.IDIV), RECORD[b, c])
431 :			val LESSU = PO.CMP{oper=PO.LTU, kind=PO.UINT 31}
432 :
433 :			val lt_len = LT.ltc_poly([LT.tkc_mono], [lt_arw(LT.ltc_tv 0, lt_int)])
434 :			val lt_upd =
435 :			let val x = LT.ltc_ref (LT.ltc_tv 0)
436 :			in LT.ltc_poly([LT.tkc_mono],
437 :			[lt_arw(lt_tup [x, lt_int, LT.ltc_tv 0], LT.ltc_unit)])
438 :			end
439 :
440 :			fun lenOp(tc) = PRIM(PO.LENGTH, lt_len, [tc])
441 :
442 :			fun rshiftOp k = PO.ARITH{oper=PO.RSHIFT, overflow=false, kind=k}
443 :			fun rshiftlOp k = PO.ARITH{oper=PO.RSHIFTL, overflow=false, kind=k}
444 :			fun lshiftOp k = PO.ARITH{oper=PO.LSHIFT, overflow=false, kind=k}
445 :
446 :			fun lword0 (PO.UINT 31) = WORD 0w0
447 :			| lword0 (PO.UINT 32) = WORD32 0w0
448 :			| lword0 _ = bug "unexpected case in lword0"
449 :
450 :			fun baselt (PO.UINT 31) = lt_int
451 :			| baselt (PO.UINT 32) = lt_int32
452 :			| baselt _ = bug "unexpected case in baselt"
453 :
454 :			fun shiftTy k =
455 :			let val elem = baselt k
456 :			val tupt = lt_tup [elem, lt_int]
457 :			in lt_arw(tupt, elem)
458 :			end
459 :
460 :			fun inlineShift(shiftOp, kind, clear) =
461 :			let fun shiftLimit (PO.UINT lim) = WORD(Word.fromInt lim)
462 :			| shiftLimit _ = bug "unexpected case in shiftLimit"
463 :
464 :			val p = mkv() val vp = VAR p
465 :			val w = mkv() val vw = VAR w
466 :			val cnt = mkv() val vcnt = VAR cnt
467 :
468 :			val argt = lt_tup [baselt(kind), lt_int]
469 :			val cmpShiftAmt =
470 :			PRIM(PO.CMP{oper=PO.LEU, kind=PO.UINT 31}, lt_icmp, [])
471 :			in FN(p, argt,
472 :			LET(w, SELECT(0, vp),
473 :			LET(cnt, SELECT(1, vp),
474 :			COND(APP(cmpShiftAmt, RECORD [shiftLimit(kind), vcnt]),
475 :			clear vw,
476 :			APP(PRIM(shiftOp(kind), shiftTy(kind), []),
477 :			RECORD [vw, vcnt])))))
478 :			end
479 :
480 :
481 :			fun transPrim (prim, lt, ts) =
482 :			let fun g (PO.INLLSHIFT k) = inlineShift(lshiftOp, k, fn _ => lword0(k))
483 :			| g (PO.INLRSHIFTL k) = inlineShift(rshiftlOp, k, fn _ => lword0(k))
484 :			| g (PO.INLRSHIFT k) = (* preserve sign bit with arithmetic rshift *)
485 :			let fun clear w = APP(PRIM(rshiftOp k, shiftTy k, []),
486 :			RECORD [w, WORD 0w31])
487 :			in inlineShift(rshiftOp, k, clear)
488 :			end
489 :
490 :			| g (PO.INLDIV) =
491 :			let val a = mkv() and b = mkv() and z = mkv()
492 :			in FN(z, lt_ipair,
493 :			LET(a, SELECT(0, VAR z),
494 :			LET(b, SELECT(1, VAR z),
495 :			COND(APP(cmpOp(PO.IGE), RECORD[VAR b, INT 0]),
496 :			COND(APP(cmpOp(PO.IGE), RECORD[VAR a, INT 0]),
497 :			DIV(VAR a, VAR b),
498 :			SUB(DIV(ADD(VAR a, INT 1), VAR b), INT 1)),
499 :			COND(APP(cmpOp(PO.IGT), RECORD[VAR a, INT 0]),
500 :			SUB(DIV(SUB(VAR a, INT 1), VAR b), INT 1),
501 :			DIV(VAR a, VAR b))))))
502 :			end
503 :
504 :			| g (PO.INLMOD) =
505 :			let val a = mkv() and b = mkv() and z = mkv()
506 :			in FN(z, lt_ipair,
507 :			LET(a,SELECT(0, VAR z),
508 :			LET(b,SELECT(1,VAR z),
509 :			COND(APP(cmpOp(PO.IGE), RECORD[VAR b, INT 0]),
510 :			COND(APP(cmpOp(PO.IGE), RECORD[VAR a, INT 0]),
511 :			SUB(VAR a, MUL(DIV(VAR a, VAR b), VAR b)),
512 :			ADD(SUB(VAR a,MUL(DIV(ADD(VAR a,INT 1), VAR b),
513 :			VAR b)), VAR b)),
514 :			COND(APP(cmpOp(PO.IGT), RECORD[VAR a,INT 0]),
515 :			ADD(SUB(VAR a,MUL(DIV(SUB(VAR a,INT 1), VAR b),
516 :			VAR b)), VAR b),
517 :			COND(APP(cmpOp(PO.IEQL),RECORD[VAR a,
518 :			INT ~1073741824]),
519 :			COND(APP(cmpOp(PO.IEQL),
520 :			RECORD[VAR b,INT 0]),
521 :			INT 0,
522 :			SUB(VAR a, MUL(DIV(VAR a, VAR b),
523 :			VAR b))),
524 :			SUB(VAR a, MUL(DIV(VAR a, VAR b),
525 :			VAR b))))))))
526 :			end
527 :
528 :			| g (PO.INLREM) =
529 :			let val a = mkv() and b = mkv() and z = mkv()
530 :			in FN(z, lt_ipair,
531 :			LET(a, SELECT(0,VAR z),
532 :			LET(b, SELECT(1,VAR z),
533 :			SUB(VAR a, MUL(DIV(VAR a,VAR b),VAR b)))))
534 :			end
535 :
536 :			| g (PO.INLMIN) =
537 :			let val x = mkv() and y = mkv() and z = mkv()
538 :			in FN(z, lt_ipair,
539 :			LET(x, SELECT(0,VAR z),
540 :			LET(y, SELECT(1,VAR z),
541 :			COND(APP(cmpOp(PO.ILT), RECORD[VAR x,VAR y]),
542 :			VAR x, VAR y))))
543 :			end
544 :			| g (PO.INLMAX) =
545 :			let val x = mkv() and y = mkv() and z = mkv()
546 :			in FN(z, lt_ipair,
547 :			LET(x, SELECT(0,VAR z),
548 :			LET(y, SELECT(1,VAR z),
549 :			COND(APP(cmpOp(PO.IGT), RECORD[VAR x,VAR y]),
550 :			VAR x, VAR y))))
551 :			end
552 :			| g (PO.INLABS) =
553 :			let val x = mkv()
554 :			in FN(x, lt_int,
555 :			COND(APP(cmpOp(PO.IGT), RECORD[VAR x,INT 0]),
556 :			VAR x, APP(inegOp(PO.INEG), VAR x)))
557 :			end
558 :			| g (PO.INLNOT) =
559 :			let val x = mkv()
560 :			in FN(x, lt_bool, COND(VAR x, falseLexp, trueLexp))
561 :			end
562 :
563 :			| g (PO.INLCOMPOSE) =
564 :			let val (t1, t2, t3) =
565 :			case ts of [a,b,c] => (lt_tyc a, lt_tyc b, lt_tyc c)
566 :			| _ => bug "unexpected type for INLCOMPOSE"
567 :
568 :			val argt = lt_tup [lt_arw(t2, t3), lt_arw(t1, t2)]
569 :
570 :			val x = mkv() and z = mkv()
571 :			val f = mkv() and g = mkv()
572 :			in FN(z, argt,
573 :			LET(f, SELECT(0,VAR z),
574 :			LET(g,SELECT(1,VAR z),
575 :			FN(x, t1, APP(VAR f,APP(VAR g,VAR x))))))
576 :			end
577 :			| g (PO.INLBEFORE) =
578 :			let val (t1, t2) =
579 :			case ts of [a,b] => (lt_tyc a, lt_tyc b)
580 :			| _ => bug "unexpected type for INLBEFORE"
581 :			val argt = lt_tup [t1, t2]
582 :			val x = mkv()
583 :			in FN(x, argt, SELECT(0,VAR x))
584 :			end
585 :
586 :			| g (PO.INLSUBSCRIPTV) =
587 :			let val (tc1, t1) = case ts of [z] => (z, lt_tyc z)
588 :			| _ => bug "unexpected ty for INLSUBV"
589 :
590 :			val seqtc = LT.tcc_vector tc1
591 :			val argt = lt_tup [lt_tyc seqtc, lt_int]
592 :
593 :			val oper = PRIM(PO.SUBSCRIPT, lt, ts)
594 :			val p = mkv() and a = mkv() and i = mkv()
595 :			val vp = VAR p and va = VAR a and vi = VAR i
596 :			in FN(p, argt,
597 :			LET(a, SELECT(0,vp),
598 :			LET(i, SELECT(1,vp),
599 :			COND(APP(cmpOp(LESSU),
600 :			RECORD[vi, APP(lenOp seqtc, va)]),
601 :			APP(oper, RECORD[va, vi]),
602 :			mkRaise(coreExn "Subscript", t1)))))
603 :			end
604 :
605 :			| g (PO.INLSUBSCRIPT) =
606 :			let val (tc1, t1) = case ts of [z] => (z, lt_tyc z)
607 :			| _ => bug "unexpected ty for INLSUB"
608 :
609 :			val seqtc = LT.tcc_array tc1
610 :			val argt = lt_tup [lt_tyc seqtc, lt_int]
611 :
612 :			val oper = PRIM(PO.SUBSCRIPT, lt, ts)
613 :			val p = mkv() and a = mkv() and i = mkv()
614 :			val vp = VAR p and va = VAR a and vi = VAR i
615 :			in FN(p, argt,
616 :			LET(a, SELECT(0, vp),
617 :			LET(i, SELECT(1, vp),
618 :			COND(APP(cmpOp(LESSU),
619 :			RECORD[vi, APP(lenOp seqtc, va)]),
620 :			APP(oper, RECORD[va, vi]),
621 :			mkRaise(coreExn "Subscript", t1)))))
622 :			end
623 :
624 :			| g (PO.NUMSUBSCRIPT{kind,checked=true,immutable}) =
625 :			let val (tc1, t1, t2) =
626 :			case ts of [a,b] => (a, lt_tyc a, lt_tyc b)
627 :			| _ => bug "unexpected type for NUMSUB"
628 :
629 :			val argt = lt_tup [t1, lt_int]
630 :			val p = mkv() and a = mkv() and i = mkv()
631 :			val vp = VAR p and va = VAR a and vi = VAR i
632 :			val oper = PO.NUMSUBSCRIPT{kind=kind,checked=false,
633 :			immutable=immutable}
634 :			val oper' = PRIM(oper, lt, ts)
635 :			in FN(p, argt,
636 :			LET(a, SELECT(0, vp),
637 :			LET(i, SELECT(1, vp),
638 :			COND(APP(cmpOp(LESSU), RECORD[vi,
639 :			APP(lenOp tc1, va)]),
640 :			APP(oper', RECORD [va, vi]),
641 :			mkRaise(coreExn "Subscript", t2)))))
642 :			end
643 :
644 :			| g (PO.INLUPDATE) =
645 :			let val (tc1, t1) = case ts of [z] => (z, lt_tyc z)
646 :			| _ => bug "unexpected ty for INLSUB"
647 :
648 :			val seqtc = LT.tcc_array tc1
649 :			val argt = lt_tup [lt_tyc seqtc, lt_int, t1]
650 :
651 :			val oper = PRIM(PO.UPDATE, lt, ts)
652 :			val x = mkv() and a = mkv() and i = mkv() and v = mkv()
653 :			val vx = VAR x and va = VAR a and vi = VAR i and vv = VAR v
654 :
655 :			in FN(x, argt,
656 :			LET(a, SELECT(0, vx),
657 :			LET(i, SELECT(1, vx),
658 :			LET(v, SELECT(2, vx),
659 :			COND(APP(cmpOp(LESSU),
660 :			RECORD[vi,APP(lenOp seqtc, va)]),
661 :			APP(oper, RECORD[va,vi,vv]),
662 :	monnier	45	mkRaise(coreExn "Subscript", LT.ltc_unit))))))
663 :	monnier	16	end
664 :
665 :			| g (PO.NUMUPDATE{kind,checked=true}) =
666 :			let val (tc1, t1, t2) =
667 :			case ts of [a,b] => (a, lt_tyc a, lt_tyc b)
668 :			| _ => bug "unexpected type for NUMUPDATE"
669 :
670 :			val argt = lt_tup [t1, lt_int, t2]
671 :
672 :			val p=mkv() and a=mkv() and i=mkv() and v=mkv()
673 :			val vp=VAR p and va=VAR a and vi=VAR i and vv=VAR v
674 :
675 :			val oper = PO.NUMUPDATE{kind=kind,checked=false}
676 :			val oper' = PRIM(oper, lt, ts)
677 :			in FN(p, argt,
678 :			LET(a, SELECT(0, vp),
679 :			LET(i, SELECT(1, vp),
680 :			LET(v, SELECT(2, vp),
681 :			COND(APP(cmpOp(LESSU),
682 :			RECORD[vi,APP(lenOp tc1, va)]),
683 :			APP(oper', RECORD[va,vi,vv]),
684 :	monnier	45	mkRaise(coreExn "Subscript", LT.ltc_unit))))))
685 :	monnier	16	end
686 :
687 :			| g (PO.ASSIGN) =
688 :			let val (tc1, t1) = case ts of [z] => (z, lt_tyc z)
689 :			| _ => bug "unexpected ty for ASSIGN"
690 :
691 :			val seqtc = LT.tcc_ref tc1
692 :			val argt = lt_tup [lt_tyc seqtc, t1]
693 :
694 :			val oper = PRIM(PO.UPDATE, lt_upd, [tc1])
695 :
696 :			val x = mkv()
697 :			val varX = VAR x
698 :
699 :			in FN(x, argt,
700 :			APP(oper, RECORD[SELECT(0, varX), INT 0, SELECT(1, varX)]))
701 :			end
702 :
703 :			| g p = PRIM(p, lt, ts)
704 :
705 :			in g prim
706 :			end (* function transPrim *)
707 :
708 :			(***************************************************************************
709 :			* *
710 :			* Translating various bindings into lambda expressions: *
711 :			* *
712 :			* val mkVar : V.var * DI.depth -> L.lexp *
713 :			* val mkVE : V.var * T.ty list -> L.lexp *
714 :			* val mkCE : T.datacon * T.ty list * L.lexp option * DI.depth -> L.lexp *
715 :			* val mkStr : M.Structure * DI.depth -> L.lexp *
716 :			* val mkFct : M.Functor * DI.depth -> L.lexp *
717 :			* val mkBnd : DI.depth -> B.binding -> L.lexp *
718 :			* *
719 :			***************************************************************************)
720 :	monnier	100	fun mkVar (v as V.VALvar{access, info, typ, path}, d) =
721 :			mkAccInfo(access, info, fn () => toLty d (!typ), getNameOp path)
722 :	monnier	16	| mkVar _ = bug "unexpected vars in mkVar"
723 :
724 :			fun mkVE (v as V.VALvar {info=II.INL_PRIM(p, SOME typ), ...}, ts, d) =
725 :			(case (p, ts)
726 :	monnier	45	of (PO.POLYEQL, [t]) => eqGen(typ, t, toTcLt d)
727 :			| (PO.POLYNEQ, [t]) => composeNOT(eqGen(typ, t, toTcLt d), toLty d t)
728 :	monnier	16	| (PO.INLMKARRAY, [t]) =>
729 :			let val dict =
730 :			{default = coreAcc "mkNormArray",
731 :			table = [([LT.tcc_real], coreAcc "mkRealArray")]}
732 :	monnier	45	in GENOP (dict, p, toLty d typ, map (toTyc d) ts)
733 :	monnier	16	end
734 :	monnier	45	| _ => transPrim(p, (toLty d typ), map (toTyc d) ts))
735 :	monnier	16
736 :			| mkVE (v as V.VALvar {info=II.INL_PRIM(p, NONE), typ, ...}, ts, d) =
737 :	monnier	45	(case ts of [] => transPrim(p, (toLty d (!typ)), [])
738 :	monnier	16	| [x] =>
739 :			(* a temporary hack to resolve the boot/built-in.sml file *)
740 :	monnier	45	(let val lt = toLty d (!typ)
741 :			val nt = toLty d x
742 :	monnier	16	in if LT.lt_eqv(LT.ltc_top, lt)
743 :			then transPrim(p, nt, [])
744 :			else bug "unexpected primop in mkVE"
745 :			end)
746 :			| _ => bug "unexpected poly primops in mkVE")
747 :
748 :			| mkVE (v, [], d) = mkVar(v, d)
749 :	monnier	45	| mkVE (v, ts, d) = TAPP(mkVar(v, d), map (toTyc d) ts)
750 :	monnier	16
751 :			fun mkCE (TP.DATACON{const, rep, name, typ, ...}, ts, apOp, d) =
752 :			let val lt = toDconLty d typ
753 :	monnier	100	val rep' = mkRep(rep, lt, name)
754 :	monnier	16	val dc = (name, rep', lt)
755 :	monnier	45	val ts' = map (toTyc d) ts
756 :	monnier	16	in if const then CON'(dc, ts', unitLexp)
757 :			else (case apOp
758 :			of SOME le => CON'(dc, ts', le)
759 :			| NONE =>
760 :			let val (argT, _) = LT.ltd_parrow(LT.lt_pinst(lt, ts'))
761 :			val v = mkv()
762 :			in FN(v, argT, CON'(dc, ts', VAR v))
763 :			end)
764 :			end
765 :
766 :			fun mkStr (s as M.STR{access, info, ...}, d) =
767 :	monnier	100	mkAccInfo(access, info, fn () => strLty(s, d, compInfo), NONE)
768 :	monnier	16	| mkStr _ = bug "unexpected structures in mkStr"
769 :
770 :			fun mkFct (f as M.FCT{access, info, ...}, d) =
771 :	monnier	100	mkAccInfo(access, info, fn () => fctLty(f, d, compInfo), NONE)
772 :	monnier	16	| mkFct _ = bug "unexpected functors in mkFct"
773 :
774 :			fun mkBnd d =
775 :			let fun g (B.VALbind v) = mkVar(v, d)
776 :			| g (B.STRbind s) = mkStr(s, d)
777 :			| g (B.FCTbind f) = mkFct(f, d)
778 :	monnier	100	| g (B.CONbind (TP.DATACON{rep=(DA.EXN acc), name, typ, ...})) =
779 :	monnier	16	let val nt = toDconLty d typ
780 :			val (argt,_) = LT.ltd_parrow nt
781 :	monnier	100	in mkAccT (acc, LT.ltc_etag argt, SOME name)
782 :	monnier	16	end
783 :			| g _ = bug "unexpected bindings in mkBnd"
784 :			in g
785 :			end
786 :
787 :
788 :			(***************************************************************************
789 :			* *
790 :			* Translating core absyn declarations into lambda expressions: *
791 :			* *
792 :			* val mkVBs : Absyn.vb list * depth -> Lambda.lexp -> Lambda.lexp *
793 :			* val mkRVBs : Absyn.rvb list * depth -> Lambda.lexp -> Lambda.lexp *
794 :			* val mkEBs : Absyn.eb list * depth -> Lambda.lexp -> Lambda.lexp *
795 :			* *
796 :			***************************************************************************)
797 :			fun mkPE (exp, d, []) = mkExp(exp, d)
798 :			| mkPE (exp, d, boundtvs) =
799 :			let val savedtvs = map ! boundtvs
800 :
801 :			fun g (i, []) = ()
802 :			| g (i, (tv as ref (TP.OPEN _))::rest) =
803 :			(tv := TP.LBOUND{depth=d, num=i}; g(i+1,rest))
804 :			| g (i, (tv as ref (TP.LBOUND _))::res) =
805 :			bug ("unexpected tyvar LBOUND in mkPE")
806 :			| g _ = bug "unexpected tyvar INSTANTIATED in mkPE"
807 :
808 :			val _ = g(0, boundtvs) (* assign the LBOUND tyvars *)
809 :			val exp' = mkExp(exp, DI.next d)
810 :
811 :			fun h ([], []) = ()
812 :			| h (a::r, b::z) = (b := a; h(r, z))
813 :			| h _ = bug "unexpected cases in mkPE"
814 :
815 :			val _ = h(savedtvs, boundtvs) (* recover *)
816 :			val len = length(boundtvs)
817 :
818 :			in TFN(LT.tkc_arg(len), exp')
819 :			end
820 :
821 :			and mkVBs (vbs, d) =
822 :			let fun eqTvs ([], []) = true
823 :			| eqTvs (a::r, (TP.VARty b)::s) = if (a=b) then eqTvs(r, s) else false
824 :			| eqTvs _ = false
825 :
826 :			fun g (VB{pat=VARpat(V.VALvar{access=DA.LVAR v, ...}),
827 :			exp as VARexp (ref (w as (V.VALvar _)), instys),
828 :			boundtvs=tvs, ...}, b) =
829 :			if eqTvs(tvs, instys) then LET(v, mkVar(w, d), b)
830 :			else LET(v, mkPE(exp, d, tvs), b)
831 :
832 :			| g (VB{pat=VARpat(V.VALvar{access=DA.LVAR v, ...}),
833 :			exp, boundtvs=tvs, ...}, b) = LET(v, mkPE(exp, d, tvs), b)
834 :
835 :			| g (VB{pat=CONSTRAINTpat(VARpat(V.VALvar{access=DA.LVAR v, ...}),_),
836 :			exp, boundtvs=tvs, ...}, b) = LET(v, mkPE(exp, d, tvs), b)
837 :
838 :			| g (VB{pat, exp, boundtvs=tvs, ...}, b) =
839 :			let val ee = mkPE(exp, d, tvs)
840 :			val rules = [(fillPat(pat, d), b), (WILDpat, unitLexp)]
841 :			val rootv = mkv()
842 :			fun finish x = LET(rootv, ee, x)
843 :	monnier	45	in MC.bindCompile(env, rules, finish, rootv, toTcLt d, complain)
844 :	monnier	16	end
845 :			in fold g vbs
846 :			end
847 :
848 :			and mkRVBs (rvbs, d) =
849 :			let fun g (RVB{var=V.VALvar{access=DA.LVAR v, typ=ref ty, ...},
850 :			exp, boundtvs=tvs, ...}, (vlist, tlist, elist)) =
851 :			let val ee = mkExp(exp, d) (* was mkPE(exp, d, tvs) *)
852 :			(* we no longer track type bindings at RVB anymore ! *)
853 :	monnier	45	val vt = toLty d ty
854 :	monnier	16	in (v::vlist, vt::tlist, ee::elist)
855 :			end
856 :			| g _ = bug "unexpected valrec bindings in mkRVBs"
857 :
858 :			val (vlist, tlist, elist) = foldr g ([], [], []) rvbs
859 :
860 :			in fn b => FIX(vlist, tlist, elist, b)
861 :			end
862 :
863 :			and mkEBs (ebs, d) =
864 :			let fun g (EBgen {exn=TP.DATACON{rep=DA.EXN(DA.LVAR v), typ, ...},
865 :			ident, ...}, b) =
866 :			let val nt = toDconLty d typ
867 :			val (argt, _) = LT.ltd_parrow nt
868 :			in LET(v, ETAG(mkExp(ident, d), argt), b)
869 :			end
870 :	monnier	100	| g (EBdef {exn=TP.DATACON{rep=DA.EXN(DA.LVAR v), typ, name, ...},
871 :	monnier	16	edef=TP.DATACON{rep=DA.EXN(acc), ...}}, b) =
872 :			let val nt = toDconLty d typ
873 :			val (argt, _) = LT.ltd_parrow nt
874 :	monnier	100	in LET(v, mkAccT(acc, LT.ltc_etag argt, SOME name), b)
875 :	monnier	16	end
876 :			| g _ = bug "unexpected exn bindings in mkEBs"
877 :
878 :			in fold g ebs
879 :			end
880 :
881 :
882 :			(***************************************************************************
883 :			* *
884 :			* Translating module exprs and decls into lambda expressions: *
885 :			* *
886 :			* val mkStrexp : Absyn.strexp * depth -> Lambda.lexp *
887 :			* val mkFctexp : Absyn.fctexp * depth -> Lambda.lexp *
888 :			* val mkStrbs : Absyn.strb list * depth -> Lambda.lexp -> Lambda.lexp *
889 :			* val mkFctbs : Absyn.fctb list * depth -> Lambda.lexp -> Lambda.lexp *
890 :			* *
891 :			***************************************************************************)
892 :			and mkStrexp (se, d) =
893 :			let fun g (VARstr s) = mkStr(s, d)
894 :			| g (STRstr bs) = SRECORD (map (mkBnd d) bs)
895 :			| g (APPstr {oper, arg, argtycs}) =
896 :			let val e1 = mkFct(oper, d)
897 :	monnier	45	val tycs = map (tpsTyc d) argtycs
898 :	monnier	16	val e2 = mkStr(arg, d)
899 :			in APP(TAPP(e1, tycs), e2)
900 :			end
901 :			| g (LETstr (dec, b)) = mkDec (dec, d) (g b)
902 :			| g (MARKstr (b, reg)) = withRegion reg g b
903 :
904 :			in g se
905 :			end
906 :
907 :			and mkFctexp (fe, d) =
908 :			let fun g (VARfct f) = mkFct(f, d)
909 :			| g (FCTfct{param as M.STR{access=DA.LVAR v, ...}, argtycs, def}) =
910 :	monnier	45	let val knds = map tpsKnd argtycs
911 :	monnier	16	val nd = DI.next d
912 :			val body = mkStrexp (def, nd)
913 :			val hdr = buildHdr v
914 :			(* binding of all v's components *)
915 :	monnier	45	in TFN(knds, FN(v, strLty(param, nd, compInfo), hdr body))
916 :	monnier	16	end
917 :			| g (LETfct (dec, b)) = mkDec (dec, d) (g b)
918 :			| g (MARKfct (b, reg)) = withRegion reg g b
919 :			| g _ = bug "unexpected functor expressions in mkFctexp"
920 :
921 :			in g fe
922 :			end
923 :
924 :			and mkStrbs (sbs, d) =
925 :			let fun g (STRB{str=M.STR{access=DA.LVAR v, ...}, def, ...}, b) =
926 :			let val hdr = buildHdr v
927 :			(* binding of all v's components *)
928 :			in LET(v, mkStrexp(def, d), hdr b)
929 :			end
930 :
931 :			| g _ = bug "unexpected structure bindings in mkStrbs"
932 :
933 :			in fold g sbs
934 :			end
935 :
936 :			and mkFctbs (fbs, d) =
937 :			let fun g (FCTB{fct=M.FCT{access=DA.LVAR v, ...}, def, ...}, b) =
938 :			let val hdr = buildHdr v
939 :			in LET(v, mkFctexp(def, d), hdr b)
940 :			end
941 :
942 :			| g _ = bug "unexpected functor bindings in mkStrbs"
943 :
944 :			in fold g fbs
945 :			end
946 :
947 :
948 :			(***************************************************************************
949 :			* Translating absyn decls and exprs into lambda expression: *
950 :			* *
951 :			* val mkExp : A.exp * DI.depth -> L.lexp *
952 :			* val mkDec : A.dec * DI.depth -> L.lexp -> L.lexp *
953 :			* *
954 :			***************************************************************************)
955 :			and mkDec (dec, d) =
956 :			let fun g (VALdec vbs) = mkVBs(vbs, d)
957 :			| g (VALRECdec rvbs) = mkRVBs(rvbs, d)
958 :			| g (ABSTYPEdec{body,...}) = g body
959 :			| g (EXCEPTIONdec ebs) = mkEBs(ebs, d)
960 :			| g (STRdec sbs) = mkStrbs(sbs, d)
961 :			| g (ABSdec sbs) = mkStrbs(sbs, d)
962 :			| g (FCTdec fbs) = mkFctbs(fbs, d)
963 :			| g (LOCALdec(ld, vd)) = (g ld) o (g vd)
964 :			| g (SEQdec ds) = foldr (op o) ident (map g ds)
965 :			| g (MARKdec(x, reg)) =
966 :			let val f = withRegion reg g x
967 :			in fn y => withRegion reg f y
968 :			end
969 :	monnier	100	| g (OPENdec xs) =
970 :			let (* special hack to make the import tree simpler *)
971 :			fun mkos (_, s as M.STR{access=acc, ...}) =
972 :			if extern acc then
973 :			let val _ = mkAccT(acc, strLty(s, d, compInfo), NONE)
974 :			in ()
975 :			end
976 :			else ()
977 :			| mkos _ = ()
978 :			in app mkos xs; ident
979 :			end
980 :	monnier	16	| g _ = ident
981 :			in g dec
982 :			end
983 :
984 :			and mkExp (exp, d) =
985 :	monnier	45	let val tTyc = toTyc d
986 :			val tLty = toLty d
987 :	monnier	16
988 :			fun mkRules xs = map (fn (RULE(p, e)) => (fillPat(p, d), g e)) xs
989 :
990 :			and g (VARexp (ref v, ts)) = mkVE(v, ts, d)
991 :
992 :			| g (CONexp (dc, ts)) = mkCE(dc, ts, NONE, d)
993 :			| g (APPexp (CONexp(dc, ts), e2)) = mkCE(dc, ts, SOME(g e2), d)
994 :
995 :			| g (INTexp (s, t)) =
996 :			((if TU.equalType (t, BT.intTy) then INT (LN.int s)
997 :			else if TU.equalType (t, BT.int32Ty) then INT32 (LN.int32 s)
998 :			else bug "translate INTexp")
999 :			handle Overflow => (repErr "int constant too large"; INT 0))
1000 :
1001 :			| g (WORDexp(s, t)) =
1002 :			((if TU.equalType (t, BT.wordTy) then WORD (LN.word s)
1003 :			else if TU.equalType (t, BT.word8Ty)
1004 :			then WORD (LN.word8 s)
1005 :			else if TU.equalType (t, BT.word32Ty)
1006 :			then WORD32 (LN.word32 s)
1007 :			else (ppType t;
1008 :			bug "translate WORDexp"))
1009 :			handle Overflow => (repErr "word constant too large"; INT 0))
1010 :
1011 :			| g (REALexp s) = REAL s
1012 :			| g (STRINGexp s) = STRING s
1013 :			| g (CHARexp s) = INT (Char.ord(String.sub(s, 0)))
1014 :			(** NOTE: the above won't work for cross compiling to
1015 :			multi-byte characters **)
1016 :
1017 :	monnier	45	| g (RECORDexp []) = unitLexp
1018 :	monnier	16	| g (RECORDexp xs) =
1019 :			if sorted xs then RECORD (map (fn (_,e) => g e) xs)
1020 :			else let val vars = map (fn (l,e) => (l,(g e, mkv()))) xs
1021 :			fun bind ((_,(e,v)),x) = LET(v,e,x)
1022 :			val bexp = map (fn (_,(_,v)) => VAR v) (sortrec vars)
1023 :			in foldr bind (RECORD bexp) vars
1024 :			end
1025 :
1026 :			| g (SELECTexp (LABEL{number=i,...}, e)) = SELECT(i, g e)
1027 :
1028 :			| g (VECTORexp ([], ty)) =
1029 :			TAPP(coreAcc "vector0", [tTyc ty])
1030 :			| g (VECTORexp (xs, ty)) =
1031 :			let val tc = tTyc ty
1032 :			val vars = map (fn e => (g e, mkv())) xs
1033 :			fun bind ((e,v),x) = LET(v, e, x)
1034 :			val bexp = map (fn (_,v) => VAR v) vars
1035 :			in foldr bind (VECTOR (bexp, tc)) vars
1036 :			end
1037 :
1038 :			| g (PACKexp(e, ty, tycs)) = g e
1039 :			(*
1040 :			let val (nty, ks, tps) = TU.reformat(ty, tycs, d)
1041 :	monnier	45	val ts = map (tpsTyc d) tps
1042 :	monnier	16	(** use of LtyEnv.tcAbs is a temporary hack (ZHONG) **)
1043 :			val nts = ListPair.map LtyEnv.tcAbs (ts, ks)
1044 :			val nd = DI.next d
1045 :			in case (ks, tps)
1046 :			of ([], []) => g e
1047 :	monnier	45	| _ => PACK(LT.ltc_poly(ks, [toLty nd nty]),
1048 :			ts, nts , g e)
1049 :	monnier	16	end
1050 :			*)
1051 :			| g (SEQexp [e]) = g e
1052 :			| g (SEQexp (e::r)) = LET(mkv(), g e, g (SEQexp r))
1053 :
1054 :			| g (APPexp (e1, e2)) = APP(g e1, g e2)
1055 :			| g (MARKexp (e, reg)) = withRegion reg g e
1056 :			| g (CONSTRAINTexp (e,_)) = g e
1057 :
1058 :			| g (RAISEexp (e, ty)) = mkRaise(g e, tLty ty)
1059 :			| g (HANDLEexp (e, HANDLER(FNexp(l, ty)))) =
1060 :			let val rootv = mkv()
1061 :			fun f x = FN(rootv, tLty ty, x)
1062 :			val l' = mkRules l
1063 :	monnier	45	in HANDLE(g e, MC.handCompile(env, l', f,
1064 :			rootv, toTcLt d, complain))
1065 :	monnier	16	end
1066 :
1067 :			| g (FNexp (l, ty)) =
1068 :			let val rootv = mkv()
1069 :			fun f x = FN(rootv, tLty ty, x)
1070 :	monnier	45	in MC.matchCompile (env, mkRules l, f, rootv, toTcLt d, complain)
1071 :	monnier	16	end
1072 :
1073 :			| g (CASEexp (ee, l, isMatch)) =
1074 :			let val rootv = mkv()
1075 :			val ee' = g ee
1076 :			fun f x = LET(rootv, ee', x)
1077 :			val l' = mkRules l
1078 :			in if isMatch
1079 :	monnier	45	then MC.matchCompile (env, l', f, rootv, toTcLt d, complain)
1080 :			else MC.bindCompile (env, l', f, rootv, toTcLt d, complain)
1081 :	monnier	16	end
1082 :
1083 :			| g (LETexp (dc, e)) = mkDec (dc, d) (g e)
1084 :
1085 :			| g e =
1086 :			EM.impossibleWithBody "untranslateable expression"
1087 :			(fn ppstrm => (PP.add_string ppstrm " expression: ";
1088 :			PPAbsyn.ppExp (env,NONE) ppstrm (e, !ppDepth)))
1089 :
1090 :			in g exp
1091 :			end
1092 :
1093 :
1094 :	monnier	100	(* wrapPidInfo: lexp * (pid * pidInfo) list -> lexp * importTree *)
1095 :			fun wrapPidInfo (body, pidinfos) =
1096 :			let val imports =
1097 :			let fun p2itree (ANON xl) =
1098 :			CB.ITNODE (map (fn (i,z) => (i, p2itree z)) xl)
1099 :			| p2itree (NAMED _) = CB.ITNODE []
1100 :			in map (fn (p, pi) => (p, p2itree pi)) pidinfos
1101 :			end
1102 :			(*
1103 :			val _ = let val _ = say "\n ****************** \n"
1104 :			val _ = say "\n the current import tree is :\n"
1105 :			fun tree (CB.ITNODE []) = ["\n"]
1106 :			| tree (CB.ITNODE xl) =
1107 :			foldr (fn ((i, x), z) =>
1108 :			let val ts = tree x
1109 :			val u = (Int.toString i) ^ " "
1110 :			in (map (fn y => (u ^ y)) ts) @ z
1111 :			end) [] xl
1112 :			fun pp (p, n) =
1113 :			(say ("Pid " ^ (PersStamps.toHex p) ^ "\n");
1114 :			app say (tree n))
1115 :			in app pp imports; say "\n ****************** \n"
1116 :			end
1117 :			*)
1118 :			val plexp =
1119 :			let fun get ((_, ANON xl), z) = foldl get z xl
1120 :			| get ((_, u as NAMED (_,t,_)), (n,cs,ts)) =
1121 :			(n+1, (n,u)::cs, t::ts)
1122 :	monnier	16
1123 :	monnier	100	(* get the fringe information *)
1124 :			val getp = fn ((_, pi), z) => get((0, pi), z)
1125 :			val (finfos, lts) =
1126 :			let val (_, fx, lx) = foldl getp (0,[],[]) pidinfos
1127 :			in (rev fx, rev lx)
1128 :			end
1129 :	monnier	16
1130 :	monnier	100	(* do the selection of all import variables *)
1131 :			fun mksel (u, xl, be) =
1132 :			let fun g ((i, pi), be) =
1133 :			let val (v, xs) = case pi of ANON z => (mkv(), z)
1134 :			| NAMED(v,_,z) => (v, z)
1135 :			in LET(v, SELECT(i, u), mksel(VAR v, xs, be))
1136 :			end
1137 :			in foldr g be xl
1138 :			end
1139 :			val impvar = mkv()
1140 :			val implty = LT.ltc_str lts
1141 :			val nbody = mksel (VAR impvar, finfos, body)
1142 :			in FN(impvar, implty, nbody)
1143 :			end
1144 :			in (plexp, imports)
1145 :			end (* function wrapPidInfo *)
1146 :	monnier	16
1147 :	monnier	100	(** the list of things being exported from the current compilation unit *)
1148 :	monnier	16	val exportLexp = SRECORD (map VAR exportLvars)
1149 :
1150 :	monnier	100	(** translating the ML absyn into the PLambda expression *)
1151 :			val body = mkDec (rootdec, DI.top) exportLexp
1152 :
1153 :			(** wrapping up the body with the imported variables *)
1154 :			val (plexp, imports) = wrapPidInfo (body, Map.members (!persmap))
1155 :
1156 :			fun prGen (flag,printE) s e =
1157 :			if !flag then (say ("\n\n[After " ^ s ^ " ...]\n\n"); printE e) else ()
1158 :			val _ = prGen(Control.CG.printLambda, PPLexp.printLexp) "Translate" plexp
1159 :
1160 :			(** normalizing the plambda expression into FLINT *)
1161 :			val flint = FlintNM.norm plexp
1162 :
1163 :			in {flint = flint, imports = imports}
1164 :	monnier	16	end (* function transDec *)
1165 :
1166 :			end (* top-level local *)
1167 :			end (* structure Translate *)
1168 :
1169 :	monnier	93
1170 :			(*
1171 :	monnier	113	* $Log$
1172 :	monnier	93	*)

---

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