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

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