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/branches/primop-branch-2/src/compiler/FLINT/trans/translate.sml
ViewVC logotype

Annotation of /sml/branches/primop-branch-2/src/compiler/FLINT/trans/translate.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 903 - (view) (download)
Original Path: sml/trunk/src/compiler/FLINT/trans/translate.sml

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

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