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 2062 - (view) (download)

1 : monnier 16 (* COPYRIGHT (c) 1996 Bell Laboratories *)
2 :     (* translate.sml *)
3 :    
4 :     signature TRANSLATE =
5 :     sig
6 :    
7 :     (* Invariant: transDec always applies to a top-level absyn declaration *)
8 : blume 1078 val transDec : { rootdec: Absyn.dec,
9 :     exportLvars: Access.lvar list,
10 :     env: StaticEnv.staticEnv,
11 :     cproto_conv: string,
12 :     compInfo: Absyn.dec CompInfo.compInfo }
13 : monnier 45 -> {flint: FLINT.prog,
14 : monnier 100 imports: (PersStamps.persstamp
15 : blume 879 * ImportTree.importTree) list}
16 : monnier 16
17 :     end (* signature TRANSLATE *)
18 :    
19 :     structure Translate : TRANSLATE =
20 :     struct
21 :    
22 :     local structure B = Bindings
23 :     structure BT = BasicTypes
24 :     structure DA = Access
25 :     structure DI = DebIndex
26 :     structure EM = ErrorMsg
27 : macqueen 2033 structure LT = PLambdaType (* = LtyExtern *)
28 : monnier 16 structure M = Modules
29 :     structure MC = MatchComp
30 :     structure PO = PrimOp
31 : macqueen 2053 structure PP = PrettyPrintNew
32 : macqueen 2056 structure PU = PPUtilNew
33 : monnier 16 structure S = Symbol
34 : monnier 100 structure SP = SymPath
35 : monnier 16 structure LN = LiteralToNum
36 :     structure TT = TransTypes
37 :     structure TP = Types
38 :     structure TU = TypesUtil
39 :     structure V = VarCon
40 : mblume 1347 structure EU = ElabUtil
41 : monnier 16
42 : mblume 1347 structure IIMap = RedBlackMapFn (type ord_key = IntInf.int
43 :     val compare = IntInf.compare)
44 : monnier 16
45 :     open Absyn PLambda
46 :     in
47 :    
48 :     (****************************************************************************
49 :     * CONSTANTS AND UTILITY FUNCTIONS *
50 :     ****************************************************************************)
51 :    
52 : macqueen 2057 val debugging = ref false
53 : monnier 16 fun bug msg = EM.impossible("Translate: " ^ msg)
54 :     val say = Control.Print.say
55 : georgekuan 1987
56 :     fun debugmsg (msg : string) =
57 :     if !debugging then (say msg; say "\n") else ()
58 :    
59 : monnier 16 val ppDepth = Control.Print.printDepth
60 :    
61 : macqueen 2054 val with_pp = PP.with_default_pp
62 :    
63 : monnier 16 fun ppType ty =
64 :     ElabDebug.withInternals
65 :     (fn () => ElabDebug.debugPrint debugging
66 :     ("type: ",PPType.ppType StaticEnv.empty, ty))
67 :    
68 : macqueen 2053 fun ppLexp lexp =
69 :     PP.with_default_pp(fn s => PPLexp.ppLexp 20 s lexp)
70 :    
71 : monnier 16 fun ident x = x
72 :     val unitLexp = RECORD []
73 :    
74 : monnier 100 fun getNameOp p = if SP.null p then NONE else SOME(SP.last p)
75 :    
76 : monnier 16 type pid = PersStamps.persstamp
77 :    
78 :     (** old-style fold for cases where it is partially applied *)
79 :     fun fold f l init = foldr f init l
80 :    
81 :     (** sorting the record fields for record types and record expressions *)
82 :     fun elemgtr ((LABEL{number=x,...},_),(LABEL{number=y,...},_)) = (x>y)
83 : monnier 422 fun sorted x = ListMergeSort.sorted elemgtr x
84 :     fun sortrec x = ListMergeSort.sort elemgtr x
85 : monnier 16
86 : monnier 100 (** check if an access is external *)
87 :     fun extern (DA.EXTERN _) = true
88 :     | extern (DA.PATH(a, _)) = extern a
89 :     | extern _ = false
90 :    
91 : monnier 45 (** an exception raised if coreEnv is not available *)
92 :     exception NoCore
93 :    
94 :     (****************************************************************************
95 :     * MAIN FUNCTION *
96 :     * *
97 : monnier 100 * val transDec : Absyn.dec * Access.lvar list *
98 :     * * StaticEnv.staticEnv * CompBasic.compInfo *
99 :     * -> {flint: FLINT.prog, *
100 :     * imports: (PersStamps.persstamp *
101 : blume 879 * * ImportTree.importTree) list} *
102 : monnier 45 ****************************************************************************)
103 :    
104 : blume 902 fun transDec
105 : blume 1078 { rootdec, exportLvars, env, cproto_conv,
106 :     compInfo as {errorMatch,error,...}: Absyn.dec CompInfo.compInfo } =
107 : monnier 45 let
108 :    
109 : blume 903 (* We take mkLvar from compInfo. This should answer Zhong's question... *)
110 :     (*
111 :     (*
112 :     * MAJOR CLEANUP REQUIRED ! The function mkv is currently directly taken
113 :     * from the LambdaVar module; I think it should be taken from the
114 :     * "compInfo". Similarly, should we replace all mkLvar in the backend
115 :     * with the mkv in "compInfo" ? (ZHONG)
116 :     *)
117 :     val mkv = LambdaVar.mkLvar
118 :     fun mkvN NONE = mkv()
119 :     | mkvN (SOME s) = LambdaVar.namedLvar s
120 :     *)
121 :    
122 :     val mkvN = #mkLvar compInfo
123 :     fun mkv () = mkvN NONE
124 :    
125 : macqueen 2040 val kindCh = LtyKindChk.tcKindCheckGen ()
126 : macqueen 2033
127 : monnier 45 (** generate the set of ML-to-FLINT type translation functions *)
128 : blume 902 val {tpsKnd, tpsTyc, toTyc, toLty, strLty, fctLty, markLBOUND} =
129 :     TT.genTT()
130 : monnier 45 fun toTcLt d = (toTyc d, toLty d)
131 :    
132 : monnier 16 (** translating the typ field in DATACON into lty; constant datacons
133 :     will take ltc_unit as the argument *)
134 :     fun toDconLty d ty =
135 :     (case ty
136 :     of TP.POLYty{sign, tyfun=TP.TYFUN{arity, body}} =>
137 : monnier 45 if BT.isArrowType body then toLty d ty
138 :     else toLty d (TP.POLYty{sign=sign,
139 : monnier 16 tyfun=TP.TYFUN{arity=arity,
140 :     body=BT.-->(BT.unitTy, body)}})
141 : monnier 45 | _ => if BT.isArrowType ty then toLty d ty
142 :     else toLty d (BT.-->(BT.unitTy, ty)))
143 : monnier 16
144 :     (** the special lookup functions for the Core environment *)
145 :     fun coreLookup(id, env) =
146 : blume 592 let val sp = SymPath.SPATH [CoreSym.coreSym, S.varSymbol id]
147 : monnier 16 val err = fn _ => fn _ => fn _ => raise NoCore
148 :     in Lookup.lookVal(env, sp, err)
149 :     end
150 :    
151 :     fun CON' ((_, DA.REF, lt), ts, e) = APP (PRIM (PO.MAKEREF, lt, ts), e)
152 :     | CON' ((_, DA.SUSP (SOME(DA.LVAR d, _)), lt), ts, e) =
153 : monnier 109 let val v = mkv ()
154 :     val fe = FN (v, LT.ltc_tuple [], e)
155 :     in APP(TAPP (VAR d, ts), fe)
156 :     end
157 : monnier 16 | CON' x = CON x
158 :    
159 :     (*
160 :     * The following code implements the exception tracking and
161 :     * errormsg reporting.
162 :     *)
163 :    
164 :     local val region = ref(0,0)
165 :     val markexn = PRIM(PO.MARKEXN,
166 : monnier 69 LT.ltc_parrow(LT.ltc_tuple [LT.ltc_exn, LT.ltc_string],
167 :     LT.ltc_exn), [])
168 : monnier 16 in
169 :    
170 :     fun withRegion loc f x =
171 :     let val r = !region
172 :     in (region := loc; f x before region:=r)
173 :     handle e => (region := r; raise e)
174 :     end
175 :    
176 :     fun mkRaise(x, lt) =
177 :     let val e = if !Control.trackExn
178 :     then APP(markexn, RECORD[x, STRING(errorMatch(!region))])
179 :     else x
180 :     in RAISE(e, lt)
181 :     end
182 :    
183 :     fun complain s = error (!region) s
184 :     fun repErr x = complain EM.COMPLAIN x EM.nullErrorBody
185 : monnier 504 fun repPolyEq () =
186 :     if !Control.polyEqWarn then complain EM.WARN "calling polyEqual" EM.nullErrorBody
187 :     else ()
188 : monnier 16
189 : georgekuan 1995 fun repWarn msg = complain EM.WARN msg EM.nullErrorBody
190 :    
191 :     (** This may shadow previous definition of mkv ... this version reports the
192 :     site of introduction of the lvar *)
193 : georgekuan 2009 fun mkv () = mkvN NONE
194 : georgekuan 1995
195 : monnier 16 end (* markexn-local *)
196 :    
197 : monnier 100 (***************************************************************************
198 :     * SHARING AND LIFTING OF STRUCTURE IMPORTS AND ACCESSES *
199 :     ***************************************************************************)
200 :    
201 : monnier 16 exception HASHTABLE
202 :     type key = int
203 :    
204 : monnier 100 (** hashkey of accesspath + accesspath + resvar *)
205 :     type info = (key * int list * lvar)
206 : blume 733 val hashtable : info list IntHashTable.hash_table =
207 :     IntHashTable.mkTable(32,HASHTABLE)
208 : monnier 16 fun hashkey l = foldr (fn (x,y) => ((x * 10 + y) mod 1019)) 0 l
209 :    
210 : monnier 100 fun buildHdr v =
211 : blume 733 let val info = IntHashTable.lookup hashtable v
212 : monnier 100 fun h((_, l, w), hdr) =
213 : monnier 16 let val le = foldl (fn (k,e) => SELECT(k,e)) (VAR v) l
214 : monnier 100 in fn e => hdr(LET(w, le, e))
215 : monnier 16 end
216 :     in foldr h ident info
217 :     end handle _ => ident
218 :    
219 : monnier 100 fun bindvar (v, [], _) = v
220 :     | bindvar (v, l, nameOp) =
221 : blume 733 let val info = (IntHashTable.lookup hashtable v) handle _ => []
222 : monnier 100 val key = hashkey l
223 :     fun h [] =
224 :     let val u = mkvN nameOp
225 : blume 733 in IntHashTable.insert hashtable (v,(key,l,u)::info); u
226 : monnier 100 end
227 :     | h((k',l',w)::r) =
228 :     if (k' = key) then (if (l'=l) then w else h r) else h r
229 :     in h info
230 :     end
231 : monnier 16
232 : monnier 100 datatype pidInfo = ANON of (int * pidInfo) list
233 :     | NAMED of lvar * lty * (int * pidInfo) list
234 :    
235 :     fun mkPidInfo (t, l, nameOp) =
236 :     let val v = mkvN nameOp
237 :     fun h [] = NAMED(v, t, [])
238 :     | h (a::r) = ANON [(a, h r)]
239 :     in (h l, v)
240 : monnier 16 end
241 :    
242 : monnier 100 fun mergePidInfo (pi, t, l, nameOp) =
243 :     let fun h (z as NAMED(v,_,_), []) = (z, v)
244 :     | h (ANON xl, []) =
245 :     let val v = mkvN nameOp
246 :     in (NAMED(v, t, xl), v)
247 :     end
248 :     | h (z, a::r) =
249 :     let val (xl, mknode) =
250 :     case z of ANON c => (c, ANON)
251 :     | NAMED (v,tt,c) => (c, fn x => NAMED(v,tt,x))
252 : monnier 16
253 : monnier 100 fun dump ((np, v), z, y) =
254 :     let val nz = (a, np)::z
255 :     in (mknode((rev y) @ nz), v)
256 :     end
257 :    
258 :     fun look ([], y) = dump(mkPidInfo(t, r, nameOp), [], y)
259 :     | look (u as ((x as (i,pi))::z), y) =
260 :     if i < a then look(z, x::y)
261 :     else if i = a then dump(h(pi, r), z, y)
262 :     else dump(mkPidInfo(t, r, nameOp), u, y)
263 :    
264 :     in look(xl, [])
265 :     end
266 :     in h(pi, l)
267 :     end (* end of mergePidInfo *)
268 :    
269 : monnier 16 (** a map that stores information about external references *)
270 : mblume 1347 val persmap = ref (PersMap.empty : pidInfo PersMap.map)
271 : monnier 16
272 : monnier 100 fun mkPid (pid, t, l, nameOp) =
273 : mblume 1347 case PersMap.find (!persmap, pid)
274 : monnier 422 of NONE =>
275 :     let val (pinfo, var) = mkPidInfo (t, l, nameOp)
276 : mblume 1347 in persmap := PersMap.insert(!persmap, pid, pinfo);
277 : monnier 422 var
278 :     end
279 :     | SOME pinfo =>
280 :     let val (npinfo, var) = mergePidInfo (pinfo, t, l, nameOp)
281 :     fun rmv (key, map) =
282 : mblume 1347 let val (newMap, _) = PersMap.remove(map, key)
283 : monnier 422 in newMap
284 :     end handle e => map
285 : mblume 1347 in persmap := PersMap.insert(rmv(pid, !persmap), pid, npinfo);
286 : monnier 422 var
287 :     end
288 : monnier 16
289 : mblume 1347 val iimap = ref (IIMap.empty : lvar IIMap.map)
290 :    
291 :     fun getII n =
292 :     case IIMap.find (!iimap, n) of
293 :     SOME v => v
294 :     | NONE => let val v = mkv ()
295 :     in
296 :     iimap := IIMap.insert (!iimap, n, v);
297 :     v
298 :     end
299 :    
300 : monnier 16 (** converting an access w. type into a lambda expression *)
301 : monnier 100 fun mkAccT (p, t, nameOp) =
302 :     let fun h(DA.LVAR v, l) = bindvar(v, l, nameOp)
303 :     | h(DA.EXTERN pid, l) = mkPid(pid, t, l, nameOp)
304 : monnier 16 | h(DA.PATH(a,i), l) = h(a, i::l)
305 :     | h _ = bug "unexpected access in mkAccT"
306 :     in VAR (h(p, []))
307 :     end (* new def for mkAccT *)
308 :    
309 :     (** converting an access into a lambda expression *)
310 : monnier 100 fun mkAcc (p, nameOp) =
311 :     let fun h(DA.LVAR v, l) = bindvar(v, l, nameOp)
312 : monnier 16 | h(DA.PATH(a,i), l) = h(a, i::l)
313 :     | h _ = bug "unexpected access in mkAcc"
314 :     in VAR (h(p, []))
315 :     end (* new def for mkAcc *)
316 :    
317 :     (*
318 :     * These two functions are major gross hacks. The NoCore exceptions would
319 :     * be raised when compiling boot/dummy.sml, boot/assembly.sig, and
320 :     * boot/core.sml; the assumption is that the result of coreExn and coreAcc
321 :     * would never be used when compiling these three files. A good way to
322 :     * clean up this is to put all the core constructors and primitives into
323 :     * the primitive environment. (ZHONG)
324 :     *)
325 : blume 904 exception NoCore
326 :    
327 : monnier 16 fun coreExn id =
328 : blume 904 (case CoreAccess.getCon' (fn () => raise NoCore) (env, id) of
329 :     TP.DATACON { name, rep as DA.EXN _, typ, ... } =>
330 :     let val nt = toDconLty DI.top typ
331 :     val nrep = mkRep(rep, nt, name)
332 : georgekuan 1987 val _ = debugmsg ">>coreExn in translate.sml: "
333 :     (* val _ = PPLexp.printLexp (CON'((name, nrep, nt), [], unitLexp))
334 :     val _ = print "\n" *)
335 : blume 904 in CON'((name, nrep, nt), [], unitLexp)
336 :     end
337 :     | _ => bug "coreExn in translate")
338 :     handle NoCore => (say "WARNING: no Core access\n"; INT 0)
339 : monnier 16
340 :     and coreAcc id =
341 : blume 904 (case CoreAccess.getVar' (fn () => raise NoCore) (env, id) of
342 :     V.VALvar { access, typ, path, ... } =>
343 :     mkAccT(access, toLty DI.top (!typ), getNameOp path)
344 :     | _ => bug "coreAcc in translate")
345 :     handle NoCore => (say "WARNING: no Core access\n"; INT 0)
346 : monnier 16
347 :     (** expands the flex record pattern and convert the EXN access pat *)
348 :     (** internalize the conrep's access, always exceptions *)
349 : monnier 100 and mkRep (rep, lt, name) =
350 :     let fun g (DA.LVAR v, l, t) = bindvar(v, l, SOME name)
351 :     | g (DA.PATH(a, i), l, t) = g(a, i::l, t)
352 :     | g (DA.EXTERN p, l, t) = mkPid(p, t, l, SOME name)
353 : monnier 16 | g _ = bug "unexpected access in mkRep"
354 :    
355 :     in case rep
356 :     of (DA.EXN x) =>
357 :     let val (argt, _) = LT.ltd_parrow lt
358 :     in DA.EXN (DA.LVAR (g(x, [], LT.ltc_etag argt)))
359 :     end
360 :     | (DA.SUSP NONE) => (* a hack to support "delay-force" primitives *)
361 :     (case (coreAcc "delay", coreAcc "force")
362 :     of (VAR x, VAR y) => DA.SUSP(SOME (DA.LVAR x, DA.LVAR y))
363 :     | _ => bug "unexpected case on conrep SUSP 1")
364 :     | (DA.SUSP (SOME _)) => bug "unexpected case on conrep SUSP 2"
365 :     | _ => rep
366 :     end
367 :    
368 : macqueen 1967 (** converting a value of access+prim into the lambda expression
369 :     ** [KM???} But it is ignoring the prim argument!!!
370 :     **)
371 :     fun mkAccInfo (acc, prim, getLty, nameOp) =
372 : monnier 100 if extern acc then mkAccT(acc, getLty(), nameOp) else mkAcc (acc, nameOp)
373 : monnier 16
374 :     fun fillPat(pat, d) =
375 :     let fun fill (CONSTRAINTpat (p,t)) = fill p
376 :     | fill (LAYEREDpat (p,q)) = LAYEREDpat(fill p, fill q)
377 :     | fill (RECORDpat {fields, flex=false, typ}) =
378 :     RECORDpat{fields = map (fn (lab, p) => (lab, fill p)) fields,
379 :     typ = typ, flex = false}
380 :     | fill (pat as RECORDpat {fields, flex=true, typ}) =
381 :     let exception DontBother
382 :     val fields' = map (fn (l,p) => (l, fill p)) fields
383 :    
384 :     fun find (t as TP.CONty(TP.RECORDtyc labels, _)) =
385 :     (typ := t; labels)
386 :     | find _ = (complain EM.COMPLAIN "unresolved flexible record"
387 :     (fn ppstrm =>
388 : macqueen 1344 (PP.newline ppstrm;
389 :     PP.string ppstrm "pattern: ";
390 : monnier 16 PPAbsyn.ppPat env ppstrm
391 :     (pat,!Control.Print.printDepth)));
392 :     raise DontBother)
393 :    
394 :     fun merge (a as ((id,p)::r), lab::s) =
395 :     if S.eq(id,lab) then (id,p) :: merge(r,s)
396 :     else (lab,WILDpat) :: merge(a,s)
397 :     | merge ([], lab::s) = (lab,WILDpat) :: merge([], s)
398 :     | merge ([], []) = []
399 :     | merge _ = bug "merge in translate"
400 :    
401 :     in RECORDpat{fields = merge(fields',
402 :     find(TU.headReduceType (!typ))),
403 :     flex = false, typ = typ}
404 :     handle DontBother => WILDpat
405 :     end
406 :     | fill (VECTORpat(pats,ty)) = VECTORpat(map fill pats, ty)
407 :     | fill (ORpat(p1, p2)) = ORpat(fill p1, fill p2)
408 : macqueen 2040 | fill (CONpat(TP.DATACON{name,const,typ,rep,sign,lazyp}, ts)) =
409 : monnier 109 CONpat(TP.DATACON{name=name, const=const, typ=typ, lazyp=lazyp,
410 : macqueen 2040 sign=sign,rep=mkRep(rep,toDconLty d typ,name)},
411 :     ts)
412 :     | fill (APPpat(TP.DATACON{name,const,typ,rep,sign,lazyp}, ts, pat)) =
413 :     APPpat(TP.DATACON{name=name, const=const, typ=typ,
414 :     sign=sign, lazyp=lazyp,
415 :     rep=mkRep(rep, toDconLty d typ, name)},
416 :     ts, fill pat)
417 : monnier 16 | fill xp = xp
418 :    
419 :     in fill pat
420 :     end (* function fillPat *)
421 :    
422 :     (** The runtime polymorphic equality and string equality dictionary. *)
423 :     val eqDict =
424 :     let val strEqRef : lexp option ref = ref NONE
425 :     val polyEqRef : lexp option ref = ref NONE
426 : mblume 1347 val intInfEqRef : lexp option ref = ref NONE
427 : monnier 16
428 :     fun getStrEq () =
429 :     (case (!strEqRef)
430 :     of SOME e => e
431 :     | NONE => (let val e = coreAcc "stringequal"
432 :     in strEqRef := (SOME e); e
433 :     end))
434 :    
435 : mblume 1347 fun getIntInfEq () = (* same as polyeq, but silent *)
436 :     case !intInfEqRef of
437 :     SOME e => e
438 :     | NONE => let val e =
439 :     TAPP (coreAcc "polyequal",
440 :     [toTyc DI.top BT.intinfTy])
441 :     in
442 :     intInfEqRef := SOME e; e
443 :     end
444 :    
445 : monnier 16 fun getPolyEq () =
446 : monnier 504 (repPolyEq();
447 :     case (!polyEqRef)
448 : monnier 16 of SOME e => e
449 :     | NONE => (let val e = coreAcc "polyequal"
450 :     in polyEqRef := (SOME e); e
451 :     end))
452 : mblume 1347 in {getStrEq=getStrEq, getIntInfEq=getIntInfEq, getPolyEq=getPolyEq}
453 : monnier 16 end
454 :    
455 : monnier 504 val eqGen = PEqual.equal (eqDict, env)
456 : monnier 16
457 :     (***************************************************************************
458 :     * *
459 :     * Translating the primops; this should be moved into a separate file *
460 :     * in the future. (ZHONG) *
461 :     * *
462 :     ***************************************************************************)
463 :    
464 :     val lt_tyc = LT.ltc_tyc
465 :     val lt_arw = LT.ltc_parrow
466 :     val lt_tup = LT.ltc_tuple
467 :     val lt_int = LT.ltc_int
468 :     val lt_int32 = LT.ltc_int32
469 :     val lt_bool = LT.ltc_bool
470 : mblume 1332 val lt_unit = LT.ltc_unit
471 : monnier 16
472 :     val lt_ipair = lt_tup [lt_int, lt_int]
473 : mblume 1683 val lt_i32pair = lt_tup [lt_int32, lt_int32]
474 : monnier 16 val lt_icmp = lt_arw (lt_ipair, lt_bool)
475 :     val lt_ineg = lt_arw (lt_int, lt_int)
476 :     val lt_intop = lt_arw (lt_ipair, lt_int)
477 : mblume 1332 val lt_u_u = lt_arw (lt_unit, lt_unit)
478 : monnier 16
479 :     val boolsign = BT.boolsign
480 :     val (trueDcon', falseDcon') =
481 :     let val lt = LT.ltc_parrow(LT.ltc_unit, LT.ltc_bool)
482 :     fun h (TP.DATACON{name,rep,typ,...}) = (name, rep, lt)
483 :     in (h BT.trueDcon, h BT.falseDcon)
484 :     end
485 :    
486 :     val trueLexp = CON(trueDcon', [], unitLexp)
487 :     val falseLexp = CON(falseDcon', [], unitLexp)
488 :    
489 :     fun COND(a,b,c) =
490 :     SWITCH(a,boolsign, [(DATAcon(trueDcon', [], mkv()),b),
491 :     (DATAcon(falseDcon', [], mkv()),c)], NONE)
492 :    
493 :     fun composeNOT (eq, t) =
494 :     let val v = mkv()
495 :     val argt = lt_tup [t, t]
496 :     in FN(v, argt, COND(APP(eq, VAR v), falseLexp, trueLexp))
497 :     end
498 :    
499 :     fun cmpOp p = PRIM(p, lt_icmp, [])
500 :     fun inegOp p = PRIM(p, lt_ineg, [])
501 :    
502 :     val LESSU = PO.CMP{oper=PO.LTU, kind=PO.UINT 31}
503 :    
504 :     val lt_len = LT.ltc_poly([LT.tkc_mono], [lt_arw(LT.ltc_tv 0, lt_int)])
505 :     val lt_upd =
506 :     let val x = LT.ltc_ref (LT.ltc_tv 0)
507 :     in LT.ltc_poly([LT.tkc_mono],
508 :     [lt_arw(lt_tup [x, lt_int, LT.ltc_tv 0], LT.ltc_unit)])
509 :     end
510 :    
511 :     fun lenOp(tc) = PRIM(PO.LENGTH, lt_len, [tc])
512 :    
513 :     fun rshiftOp k = PO.ARITH{oper=PO.RSHIFT, overflow=false, kind=k}
514 :     fun rshiftlOp k = PO.ARITH{oper=PO.RSHIFTL, overflow=false, kind=k}
515 :     fun lshiftOp k = PO.ARITH{oper=PO.LSHIFT, overflow=false, kind=k}
516 :    
517 :     fun lword0 (PO.UINT 31) = WORD 0w0
518 :     | lword0 (PO.UINT 32) = WORD32 0w0
519 :     | lword0 _ = bug "unexpected case in lword0"
520 :    
521 :     fun baselt (PO.UINT 31) = lt_int
522 :     | baselt (PO.UINT 32) = lt_int32
523 :     | baselt _ = bug "unexpected case in baselt"
524 :    
525 :     fun shiftTy k =
526 :     let val elem = baselt k
527 :     val tupt = lt_tup [elem, lt_int]
528 :     in lt_arw(tupt, elem)
529 :     end
530 :    
531 :     fun inlineShift(shiftOp, kind, clear) =
532 : mblume 1683 let fun shiftLimit (PO.UINT lim | PO.INT lim) = WORD(Word.fromInt lim)
533 : monnier 16 | shiftLimit _ = bug "unexpected case in shiftLimit"
534 :    
535 :     val p = mkv() val vp = VAR p
536 :     val w = mkv() val vw = VAR w
537 :     val cnt = mkv() val vcnt = VAR cnt
538 :    
539 :     val argt = lt_tup [baselt(kind), lt_int]
540 :     val cmpShiftAmt =
541 :     PRIM(PO.CMP{oper=PO.LEU, kind=PO.UINT 31}, lt_icmp, [])
542 :     in FN(p, argt,
543 :     LET(w, SELECT(0, vp),
544 :     LET(cnt, SELECT(1, vp),
545 :     COND(APP(cmpShiftAmt, RECORD [shiftLimit(kind), vcnt]),
546 :     clear vw,
547 :     APP(PRIM(shiftOp(kind), shiftTy(kind), []),
548 :     RECORD [vw, vcnt])))))
549 :     end
550 :    
551 : blume 1183 fun inlops nk = let
552 :     val (lt_arg, zero, overflow) =
553 :     case nk of
554 :     PO.INT 31 => (LT.ltc_int, INT 0, true)
555 :     | PO.UINT 31 => (LT.ltc_int, WORD 0w0, false)
556 :     | PO.INT 32 => (LT.ltc_int32, INT32 0, true)
557 :     | PO.UINT 32 => (LT.ltc_int32, WORD32 0w0, false)
558 :     | PO.FLOAT 64 => (LT.ltc_real, REAL "0.0", false)
559 :     | _ => bug "inlops: bad numkind"
560 :     val lt_argpair = lt_tup [lt_arg, lt_arg]
561 :     val lt_cmp = lt_arw (lt_argpair, lt_bool)
562 :     val lt_neg = lt_arw (lt_arg, lt_arg)
563 :     val less = PRIM (PO.CMP { oper = PO.<, kind = nk }, lt_cmp, [])
564 :     val greater = PRIM (PO.CMP { oper = PO.>, kind = nk }, lt_cmp, [])
565 :     val negate =
566 :     PRIM (PO.ARITH { oper = PO.~, overflow = overflow, kind = nk },
567 :     lt_neg, [])
568 :     in
569 :     { lt_arg = lt_arg, lt_argpair = lt_argpair, lt_cmp = lt_cmp,
570 :     less = less, greater = greater,
571 :     zero = zero, negate = negate }
572 :     end
573 : monnier 16
574 : blume 1183 fun inlminmax (nk, ismax) = let
575 :     val { lt_argpair, less, greater, lt_cmp, ... } = inlops nk
576 :     val x = mkv () and y = mkv () and z = mkv ()
577 :     val cmpop = if ismax then greater else less
578 :     val elsebranch =
579 :     case nk of
580 :     PO.FLOAT _ => let
581 :     (* testing for NaN *)
582 :     val fequal =
583 :     PRIM (PO.CMP { oper = PO.EQL, kind = nk }, lt_cmp, [])
584 :     in
585 : blume 1249 COND (APP (fequal, RECORD [VAR y, VAR y]), VAR y, VAR x)
586 : blume 1183 end
587 :     | _ => VAR y
588 :     in
589 :     FN (z, lt_argpair,
590 :     LET (x, SELECT (0, VAR z),
591 :     LET (y, SELECT (1, VAR z),
592 :     COND (APP (cmpop, RECORD [VAR x, VAR y]),
593 :     VAR x, elsebranch))))
594 :     end
595 :    
596 :     fun inlabs nk = let
597 :     val { lt_arg, greater, zero, negate, ... } = inlops nk
598 :     val x = mkv ()
599 :     in
600 :     FN (x, lt_arg,
601 :     COND (APP (greater, RECORD [VAR x, zero]),
602 :     VAR x, APP (negate, VAR x)))
603 :     end
604 :    
605 : georgekuan 2061 (** inl_infPrec : string * string * PrimOp.primop * Lty.lty * bool -> PLambda.lexp
606 :    
607 :     Precision converting translation using a conversion
608 :     primitive named in the second argument.
609 :    
610 :     Examples:
611 :     inl_infPrec ("EXTEND_INF", "finToInf", p, lt, false)
612 :     inl_infPrec ("COPY", "finToInf", p, lt, false)
613 :    
614 :     system/smlnj/init/core-intinf.sml:51: val finToInf : int32 * bool -> intinf
615 :     *)
616 : georgekuan 2062 fun inlToInfPrec (opname, coerceFnName, primop, primoplt) =
617 :     let
618 :     val (orig_arg_lt, res_lt) =
619 :     case LT.ltd_arrow primoplt of
620 :     (_, [a], [r]) => (a, r)
621 :     | _ => bug ("unexpected type of " ^ opname)
622 :     val extra_arg_lt =
623 :     if coerceFnName = "finToInf" then
624 :     LT.ltc_arrow(LT.ffc_var(true,false), [LT.ltc_int32 ,LT.ltc_bool], [res_lt])
625 :     else
626 :     LT.ltc_parrow(LT.ltc_int32, res_lt)
627 :     val new_arg_lt = LT.ltc_tuple [orig_arg_lt, extra_arg_lt]
628 :     val new_lt = LT.ltc_parrow (new_arg_lt, res_lt )
629 :     val x = mkv ()
630 :     in
631 :     FN (x, orig_arg_lt,
632 :     APP (PRIM (primop, new_lt, []),
633 :     RECORD [VAR x, coreAcc coerceFnName]))
634 :     end
635 :    
636 :     fun inlFromInfPrec (opname, coerceFnName, primop, primoplt) =
637 :     let
638 :     val (orig_arg_lt, res_lt) =
639 :     case LT.ltd_arrow primoplt of
640 :     (_, [a], [r]) => (a, r)
641 :     | _ => bug ("unexpected type of " ^ opname)
642 :     val extra_arg_lt =
643 :     LT.ltc_parrow (orig_arg_lt, LT.ltc_int32)
644 :     val new_arg_lt = LT.ltc_tuple [orig_arg_lt, extra_arg_lt]
645 :     val new_lt = LT.ltc_parrow (new_arg_lt, res_lt )
646 :     val x = mkv ()
647 :     in
648 :     FN (x, orig_arg_lt,
649 :     APP (PRIM (primop, new_lt, []),
650 :     RECORD [VAR x, coreAcc coerceFnName]))
651 :     end
652 :    
653 :    
654 : mblume 1347 fun inl_infPrec (what, corename, p, lt, is_from_inf) = let
655 :     val (orig_arg_lt, res_lt) =
656 :     case LT.ltd_arrow lt of
657 :     (_, [a], [r]) => (a, r)
658 :     | _ => bug ("unexpected type of " ^ what)
659 :     val extra_arg_lt =
660 :     LT.ltc_parrow (if is_from_inf then (orig_arg_lt, LT.ltc_int32)
661 : georgekuan 2062 else (LT.ltc_int32, res_lt (* orig_arg_lt *) ))
662 : mblume 1347 val new_arg_lt = LT.ltc_tuple [orig_arg_lt, extra_arg_lt]
663 : georgekuan 2061 val new_lt = LT.ltc_parrow (new_arg_lt, res_lt )
664 : mblume 1347 val x = mkv ()
665 : georgekuan 2061 (** Begin DEBUG edits *)
666 :     val y = mkv ()
667 : georgekuan 2062 val coreOcc = (if corename = "finToInf" then
668 : georgekuan 2061 FN(y, LT.ltc_int32 (** Where should this type come from *),
669 :     APP(coreAcc corename, RECORD [VAR y,
670 :     falseLexp
671 :     (** Apply to CoreBasicType falseDcon ... *) ]))
672 : georgekuan 2062 else coreAcc corename)
673 : georgekuan 2061 (** End DEBUG edits *)
674 :     val e =
675 : mblume 1347 FN (x, orig_arg_lt,
676 :     APP (PRIM (p, new_lt, []),
677 :     RECORD [VAR x, coreAcc corename]))
678 : georgekuan 2061 val _ = print ("### inl_infPrec ### corename " ^ corename ^ "\n")
679 :     val _ = with_pp (fn ppstrm => PPLexp.ppLexp 20 ppstrm e)
680 :     val _ = print "### end inl_infPrec ###\n"
681 :     in
682 :     e
683 : mblume 1347 end
684 :    
685 : georgekuan 2061 (** transPrim : PrimOp.primop * Lty.lty * Lty.tyc list
686 :    
687 :     Translate Absyn primop to PLambda form using given
688 :     intrinsic PLambda type and type parameters
689 :     *)
690 : monnier 16 fun transPrim (prim, lt, ts) =
691 :     let fun g (PO.INLLSHIFT k) = inlineShift(lshiftOp, k, fn _ => lword0(k))
692 :     | g (PO.INLRSHIFTL k) = inlineShift(rshiftlOp, k, fn _ => lword0(k))
693 :     | g (PO.INLRSHIFT k) = (* preserve sign bit with arithmetic rshift *)
694 :     let fun clear w = APP(PRIM(rshiftOp k, shiftTy k, []),
695 :     RECORD [w, WORD 0w31])
696 :     in inlineShift(rshiftOp, k, clear)
697 :     end
698 :    
699 : blume 1183 | g (PO.INLMIN nk) = inlminmax (nk, false)
700 :     | g (PO.INLMAX nk) = inlminmax (nk, true)
701 :     | g (PO.INLABS nk) = inlabs nk
702 : monnier 16
703 :     | g (PO.INLNOT) =
704 :     let val x = mkv()
705 :     in FN(x, lt_bool, COND(VAR x, falseLexp, trueLexp))
706 :     end
707 :    
708 :     | g (PO.INLCOMPOSE) =
709 :     let val (t1, t2, t3) =
710 :     case ts of [a,b,c] => (lt_tyc a, lt_tyc b, lt_tyc c)
711 :     | _ => bug "unexpected type for INLCOMPOSE"
712 :    
713 :     val argt = lt_tup [lt_arw(t2, t3), lt_arw(t1, t2)]
714 :    
715 :     val x = mkv() and z = mkv()
716 :     val f = mkv() and g = mkv()
717 :     in FN(z, argt,
718 :     LET(f, SELECT(0,VAR z),
719 :     LET(g,SELECT(1,VAR z),
720 :     FN(x, t1, APP(VAR f,APP(VAR g,VAR x))))))
721 :     end
722 :     | g (PO.INLBEFORE) =
723 :     let val (t1, t2) =
724 :     case ts of [a,b] => (lt_tyc a, lt_tyc b)
725 :     | _ => bug "unexpected type for INLBEFORE"
726 :     val argt = lt_tup [t1, t2]
727 :     val x = mkv()
728 :     in FN(x, argt, SELECT(0,VAR x))
729 :     end
730 : blume 1183 | g (PO.INLIGNORE) =
731 :     let val argt =
732 :     case ts of [a] => lt_tyc a
733 :     | _ => bug "unexpected type for INLIGNORE"
734 :     in FN (mkv (), argt, unitLexp)
735 :     end
736 : monnier 16
737 : mblume 1347 | g (PO.INLIDENTITY) =
738 :     let val argt =
739 :     case ts of [a] => lt_tyc a
740 :     | _ => bug "unexpected type for INLIDENTITY"
741 :     val v = mkv ()
742 :     in
743 :     FN (v, argt, VAR v)
744 :     end
745 :    
746 : mblume 1683 | g (PO.CVT64) = let val v = mkv () in FN (v, lt_i32pair, VAR v) end
747 :    
748 : monnier 16 | g (PO.INLSUBSCRIPTV) =
749 :     let val (tc1, t1) = case ts of [z] => (z, lt_tyc z)
750 :     | _ => bug "unexpected ty for INLSUBV"
751 :    
752 :     val seqtc = LT.tcc_vector tc1
753 :     val argt = lt_tup [lt_tyc seqtc, lt_int]
754 :    
755 :     val oper = PRIM(PO.SUBSCRIPT, lt, ts)
756 :     val p = mkv() and a = mkv() and i = mkv()
757 :     val vp = VAR p and va = VAR a and vi = VAR i
758 :     in FN(p, argt,
759 :     LET(a, SELECT(0,vp),
760 :     LET(i, SELECT(1,vp),
761 :     COND(APP(cmpOp(LESSU),
762 :     RECORD[vi, APP(lenOp seqtc, va)]),
763 :     APP(oper, RECORD[va, vi]),
764 :     mkRaise(coreExn "Subscript", t1)))))
765 :     end
766 :    
767 :     | g (PO.INLSUBSCRIPT) =
768 :     let val (tc1, t1) = case ts of [z] => (z, lt_tyc z)
769 :     | _ => bug "unexpected ty for INLSUB"
770 :    
771 :     val seqtc = LT.tcc_array tc1
772 :     val argt = lt_tup [lt_tyc seqtc, lt_int]
773 :    
774 :     val oper = PRIM(PO.SUBSCRIPT, lt, ts)
775 :     val p = mkv() and a = mkv() and i = mkv()
776 :     val vp = VAR p and va = VAR a and vi = VAR i
777 :     in FN(p, argt,
778 :     LET(a, SELECT(0, vp),
779 :     LET(i, SELECT(1, vp),
780 :     COND(APP(cmpOp(LESSU),
781 :     RECORD[vi, APP(lenOp seqtc, va)]),
782 :     APP(oper, RECORD[va, vi]),
783 :     mkRaise(coreExn "Subscript", t1)))))
784 :     end
785 :    
786 :     | g (PO.NUMSUBSCRIPT{kind,checked=true,immutable}) =
787 :     let val (tc1, t1, t2) =
788 :     case ts of [a,b] => (a, lt_tyc a, lt_tyc b)
789 :     | _ => bug "unexpected type for NUMSUB"
790 :    
791 :     val argt = lt_tup [t1, lt_int]
792 :     val p = mkv() and a = mkv() and i = mkv()
793 :     val vp = VAR p and va = VAR a and vi = VAR i
794 :     val oper = PO.NUMSUBSCRIPT{kind=kind,checked=false,
795 :     immutable=immutable}
796 :     val oper' = PRIM(oper, lt, ts)
797 :     in FN(p, argt,
798 :     LET(a, SELECT(0, vp),
799 :     LET(i, SELECT(1, vp),
800 :     COND(APP(cmpOp(LESSU), RECORD[vi,
801 :     APP(lenOp tc1, va)]),
802 :     APP(oper', RECORD [va, vi]),
803 :     mkRaise(coreExn "Subscript", t2)))))
804 :     end
805 :    
806 :     | g (PO.INLUPDATE) =
807 :     let val (tc1, t1) = case ts of [z] => (z, lt_tyc z)
808 :     | _ => bug "unexpected ty for INLSUB"
809 :    
810 :     val seqtc = LT.tcc_array tc1
811 :     val argt = lt_tup [lt_tyc seqtc, lt_int, t1]
812 :    
813 :     val oper = PRIM(PO.UPDATE, lt, ts)
814 :     val x = mkv() and a = mkv() and i = mkv() and v = mkv()
815 :     val vx = VAR x and va = VAR a and vi = VAR i and vv = VAR v
816 :    
817 :     in FN(x, argt,
818 :     LET(a, SELECT(0, vx),
819 :     LET(i, SELECT(1, vx),
820 :     LET(v, SELECT(2, vx),
821 :     COND(APP(cmpOp(LESSU),
822 :     RECORD[vi,APP(lenOp seqtc, va)]),
823 :     APP(oper, RECORD[va,vi,vv]),
824 : monnier 45 mkRaise(coreExn "Subscript", LT.ltc_unit))))))
825 : monnier 16 end
826 :    
827 :     | g (PO.NUMUPDATE{kind,checked=true}) =
828 :     let val (tc1, t1, t2) =
829 :     case ts of [a,b] => (a, lt_tyc a, lt_tyc b)
830 :     | _ => bug "unexpected type for NUMUPDATE"
831 :    
832 :     val argt = lt_tup [t1, lt_int, t2]
833 :    
834 :     val p=mkv() and a=mkv() and i=mkv() and v=mkv()
835 :     val vp=VAR p and va=VAR a and vi=VAR i and vv=VAR v
836 :    
837 :     val oper = PO.NUMUPDATE{kind=kind,checked=false}
838 :     val oper' = PRIM(oper, lt, ts)
839 :     in FN(p, argt,
840 :     LET(a, SELECT(0, vp),
841 :     LET(i, SELECT(1, vp),
842 :     LET(v, SELECT(2, vp),
843 :     COND(APP(cmpOp(LESSU),
844 :     RECORD[vi,APP(lenOp tc1, va)]),
845 :     APP(oper', RECORD[va,vi,vv]),
846 : monnier 45 mkRaise(coreExn "Subscript", LT.ltc_unit))))))
847 : monnier 16 end
848 :    
849 : monnier 251 (**** ASSIGN(r, x) <> UPDATE(r, 0, x) under new array reps (JHR;1998-10-30)
850 : monnier 16 | g (PO.ASSIGN) =
851 :     let val (tc1, t1) = case ts of [z] => (z, lt_tyc z)
852 :     | _ => bug "unexpected ty for ASSIGN"
853 :    
854 :     val seqtc = LT.tcc_ref tc1
855 :     val argt = lt_tup [lt_tyc seqtc, t1]
856 :    
857 :     val oper = PRIM(PO.UPDATE, lt_upd, [tc1])
858 :    
859 :     val x = mkv()
860 :     val varX = VAR x
861 :    
862 :     in FN(x, argt,
863 :     APP(oper, RECORD[SELECT(0, varX), INT 0, SELECT(1, varX)]))
864 :     end
865 : monnier 251 ****)
866 : monnier 16
867 : mblume 1347 (* Precision-conversion operations involving IntInf.
868 :     * These need to be translated specially by providing
869 :     * a second argument -- the routine from _Core that
870 :     * does the actual conversion to or from IntInf. *)
871 :    
872 :     | g (p as PO.TEST_INF prec) =
873 : georgekuan 2062 inlFromInfPrec ("TEST_INF", "testInf", p, lt)
874 : mblume 1347 | g (p as PO.TRUNC_INF prec) =
875 : georgekuan 2062 inlFromInfPrec ("TRUNC_INF", "truncInf", p, lt)
876 : mblume 1347 | g (p as PO.EXTEND_INF prec) =
877 : georgekuan 2062 (* inl_infPrec ("EXTEND_INF", "finToInf", p, lt, false) *)
878 :     inlToInfPrec("EXTEND_INF", "finToInf", p, lt)
879 : mblume 1347 | g (p as PO.COPY_INF prec) =
880 : georgekuan 2062 inlToInfPrec ("COPY", "copyInf", p, lt)
881 : mblume 1347 (* default handling for all other primops *)
882 : monnier 16 | g p = PRIM(p, lt, ts)
883 :    
884 :     in g prim
885 :     end (* function transPrim *)
886 :    
887 : mblume 1347 fun genintinfswitch (sv, cases, default) = let
888 :     val v = mkv ()
889 :    
890 :     (* build a chain of equality tests for checking large pattern values *)
891 :     fun build [] = default
892 :     | build ((n, e) :: r) =
893 :     COND (APP (#getIntInfEq eqDict (), RECORD [VAR v, VAR (getII n)]),
894 :     e, build r)
895 :    
896 :     (* split pattern values into small values and large values;
897 :     * small values can be handled directly using SWITCH *)
898 :     fun split ([], s, l) = (rev s, rev l)
899 :     | split ((n, e) :: r, sm, lg) =
900 :     (case LN.lowVal n of
901 :     SOME l => split (r, (INTcon l, e) :: sm, lg)
902 :     | NONE => split (r, sm, (n, e) :: lg))
903 :    
904 :     fun gen () =
905 :     case split (cases, [], []) of
906 :     ([], largeints) => build largeints
907 :     | (smallints, largeints) => let
908 :     val iv = mkv ()
909 :     in
910 :     LET (iv, APP (coreAcc "infLowValue", VAR v),
911 :     SWITCH (VAR iv,
912 :     DA.CNIL, smallints, SOME (build largeints)))
913 :     end
914 :     in
915 :     LET (v, sv, gen ())
916 :     end
917 :    
918 :    
919 : monnier 16 (***************************************************************************
920 :     * *
921 :     * Translating various bindings into lambda expressions: *
922 :     * *
923 :     * val mkVar : V.var * DI.depth -> L.lexp *
924 :     * val mkVE : V.var * T.ty list -> L.lexp *
925 :     * val mkCE : T.datacon * T.ty list * L.lexp option * DI.depth -> L.lexp *
926 :     * val mkStr : M.Structure * DI.depth -> L.lexp *
927 :     * val mkFct : M.Functor * DI.depth -> L.lexp *
928 :     * val mkBnd : DI.depth -> B.binding -> L.lexp *
929 :     * *
930 :     ***************************************************************************)
931 : macqueen 1967 (* [KM???] mkVar is calling mkAccInfo, which just drops the prim!!! *)
932 : macqueen 1961 fun mkVar (v as V.VALvar{access, prim, typ, path}, d) =
933 :     mkAccInfo(access, prim, fn () => toLty d (!typ), getNameOp path)
934 : monnier 16 | mkVar _ = bug "unexpected vars in mkVar"
935 :    
936 : macqueen 1970 (* mkVE : V.var * type list * depth -> lexp
937 :     * This translates a variable, which might be bound to a primop.
938 :     * In the case of a primop variable, this function reconstructs the
939 :     * type parameters of instantiation of the intrinsic primop type relative
940 :     * to the variable occurrence type *)
941 : georgekuan 1979 fun mkVE (e as V.VALvar { typ, prim = PrimOpId.Prim p, ... }, ts, d) =
942 : macqueen 1970 let val occty = (* compute the occurrence type of the variable *)
943 :     case ts
944 :     of [] => !typ
945 : macqueen 2040 (* ASSERT: !typ is not a POLYty *)
946 : macqueen 1970 | _ => TU.applyPoly(!typ, ts)
947 :     val (primop,intrinsicType) =
948 : macqueen 1976 case (PrimOpMap.primopMap p, PrimOpTypeMap.primopTypeMap p)
949 :     of (SOME p, SOME t) => (p,t)
950 :     | _ => bug "mkVE: unrecognized primop name"
951 : georgekuan 1987 val _ = debugmsg ">>mkVE: before matchInstTypes"
952 : macqueen 1970 val intrinsicParams =
953 :     (* compute intrinsic instantiation params of intrinsicType *)
954 : macqueen 2040 case (TU.matchInstTypes(occty, intrinsicType)
955 :     : (TP.tyvar list * TP.tyvar list) option )
956 : georgekuan 1981 of SOME(_, tvs) =>
957 : macqueen 2040 (if !debugging then
958 :     complain EM.WARN
959 :     "mkVE ->matchInstTypes -> pruneTyvar"
960 :     (fn ppstrm =>
961 :     (PP.string ppstrm
962 :     ("tvs length: " ^ Int.toString (length tvs));
963 :     PP.newline ppstrm;
964 :     PPVal.ppDebugVar
965 :     (fn x => "") ppstrm env e;
966 :     if (length tvs) = 1
967 :     then PPType.ppType env ppstrm (TP.VARty (hd tvs))
968 :     else ()))
969 :     else ();
970 :     map TU.pruneTyvar tvs)
971 :     | NONE =>
972 :     (complain EM.COMPLAIN
973 :     "mkVE:primop intrinsic type doesn't match occurrence type"
974 :     (fn ppstrm =>
975 :     (PP.string ppstrm "VALvar: ";
976 :     PPVal.ppVar ppstrm e;
977 :     PP.newline ppstrm;
978 :     PP.string ppstrm "occtypes: ";
979 :     PPType.ppType env ppstrm occty;
980 :     PP.newline ppstrm;
981 :     PP.string ppstrm "intrinsicType: ";
982 :     PPType.ppType env ppstrm intrinsicType;
983 :     PP.newline ppstrm;
984 :     PP.string ppstrm "instpoly occ: ";
985 :     PPType.ppType env ppstrm
986 :     (#1 (TU.instantiatePoly occty));
987 :     PP.newline ppstrm;
988 :     PP.string ppstrm "instpoly intrinsicType: ";
989 :     PPType.ppType env ppstrm
990 :     (#1 (TU.instantiatePoly intrinsicType))));
991 :     bug "mkVE -- NONE")
992 : georgekuan 1987 val _ = debugmsg "<<mkVE: after matchInstTypes"
993 : macqueen 1970 in case (primop, intrinsicParams)
994 :     of (PO.POLYEQL, [t]) => eqGen(intrinsicType, t, toTcLt d)
995 :     | (PO.POLYNEQ, [t]) =>
996 :     composeNOT(eqGen(intrinsicType, t, toTcLt d), toLty d t)
997 :     | (PO.INLMKARRAY, [t]) =>
998 :     let val dict =
999 :     {default = coreAcc "mkNormArray",
1000 :     table = [([LT.tcc_real], coreAcc "mkRealArray")]}
1001 :     in GENOP (dict, primop, toLty d intrinsicType,
1002 :     map (toTyc d) intrinsicParams)
1003 :     end
1004 :     | (PO.RAW_CCALL NONE, [a, b, c]) =>
1005 :     let val i = SOME (CProto.decode cproto_conv
1006 :     { fun_ty = a, encoding = b })
1007 :     handle CProto.BadEncoding => NONE
1008 :     in PRIM (PO.RAW_CCALL i, toLty d intrinsicType,
1009 :     map (toTyc d) intrinsicParams)
1010 :     end
1011 : georgekuan 2061 | _ => (** where do these intrinsicType originate?
1012 :     A: PrimOpTypeMap *)
1013 :     transPrim(primop, (toLty d intrinsicType),
1014 : macqueen 1970 map (toTyc d) intrinsicParams)
1015 :     end
1016 : macqueen 2054 | mkVE (v as V.VALvar{typ, prim = PrimOpId.NonPrim, path, ...}, ts, d) =
1017 : macqueen 1970 (* non primop variable *)
1018 : macqueen 2054 (if !debugging
1019 :     then (print "### mkVE nonprimop\n";
1020 :     print (SymPath.toString path); print "\n";
1021 :     ppType (!typ); print "\n";
1022 :     print "|ts| = "; print (Int.toString(length ts)); print "\n";
1023 :     app ppType ts; print "\n")
1024 :     else ();
1025 :     case ts
1026 : macqueen 1970 of [] => mkVar (v, d)
1027 :     | _ => TAPP(mkVar(v, d), map (toTyc d) ts))
1028 :     (* dbm: when does this second case occur? *)
1029 :     | mkVE _ = bug "non VALvar passed to mkVE"
1030 : monnier 16
1031 : macqueen 1970
1032 : monnier 16 fun mkCE (TP.DATACON{const, rep, name, typ, ...}, ts, apOp, d) =
1033 :     let val lt = toDconLty d typ
1034 : monnier 100 val rep' = mkRep(rep, lt, name)
1035 : monnier 16 val dc = (name, rep', lt)
1036 : macqueen 1970 val ts' = map (toTyc d o TP.VARty) ts
1037 : monnier 16 in if const then CON'(dc, ts', unitLexp)
1038 :     else (case apOp
1039 :     of SOME le => CON'(dc, ts', le)
1040 :     | NONE =>
1041 :     let val (argT, _) = LT.ltd_parrow(LT.lt_pinst(lt, ts'))
1042 :     val v = mkv()
1043 :     in FN(v, argT, CON'(dc, ts', VAR v))
1044 :     end)
1045 :     end
1046 :    
1047 : georgekuan 1971 fun mkStr (s as M.STR { access, prim, ... }, d) =
1048 :     mkAccInfo(access, prim, fn () => strLty(s, d, compInfo), NONE)
1049 : monnier 16 | mkStr _ = bug "unexpected structures in mkStr"
1050 :    
1051 : georgekuan 1971 fun mkFct (f as M.FCT { access, prim, ... }, d) =
1052 :     mkAccInfo(access, prim, fn () => fctLty(f, d, compInfo), NONE)
1053 : monnier 16 | mkFct _ = bug "unexpected functors in mkFct"
1054 :    
1055 :     fun mkBnd d =
1056 :     let fun g (B.VALbind v) = mkVar(v, d)
1057 :     | g (B.STRbind s) = mkStr(s, d)
1058 :     | g (B.FCTbind f) = mkFct(f, d)
1059 : monnier 100 | g (B.CONbind (TP.DATACON{rep=(DA.EXN acc), name, typ, ...})) =
1060 : blume 587 let val nt = toDconLty d typ
1061 :     val (argt,_) = LT.ltd_parrow nt
1062 :     in mkAccT (acc, LT.ltc_etag argt, SOME name)
1063 :     end
1064 : monnier 16 | g _ = bug "unexpected bindings in mkBnd"
1065 :     in g
1066 :     end
1067 :    
1068 :    
1069 :     (***************************************************************************
1070 :     * *
1071 :     * Translating core absyn declarations into lambda expressions: *
1072 :     * *
1073 : macqueen 1970 * val mkVBs : Absyn.vb list * depth -> PLambda.lexp -> PLambda.lexp *
1074 :     * val mkRVBs : Absyn.rvb list * depth -> PLambda.lexp -> PLambda.lexp *
1075 :     * val mkEBs : Absyn.eb list * depth -> PLambda.lexp -> PLambda.lexp *
1076 : monnier 16 * *
1077 :     ***************************************************************************)
1078 : macqueen 1970
1079 :     (* mkPE : Absyn.exp * depth * Types.tyvar list -> PLambda.lexp
1080 :     * translate an expression with potential type parameters *)
1081 : monnier 16 fun mkPE (exp, d, []) = mkExp(exp, d)
1082 :     | mkPE (exp, d, boundtvs) =
1083 :     let val savedtvs = map ! boundtvs
1084 : macqueen 1970 (* save original contents of boundtvs for later restoration
1085 :     * by the restore function below *)
1086 : monnier 16
1087 : macqueen 1970 fun setbtvs (i, []) = ()
1088 :     | setbtvs (i, (tv as ref (TP.OPEN _))::rest) =
1089 :     let val m = markLBOUND (d, i)
1090 : macqueen 2054 in tv := TP.TV_MARK (d,i);
1091 : macqueen 1970 setbtvs (i+1, rest)
1092 :     end
1093 :     | setbtvs (i, (tv as ref (TP.TV_MARK _))::res) =
1094 :     bug ("unexpected tyvar TV_MARK in mkPE")
1095 :     | setbtvs _ = bug "unexpected tyvar INSTANTIATED in mkPE"
1096 : monnier 16
1097 : macqueen 1970 val _ = setbtvs(0, boundtvs)
1098 :     (* assign TV_MARKs to the boundtvs to mark them as type
1099 :     * parameter variables during translation of exp *)
1100 :    
1101 : monnier 16 val exp' = mkExp(exp, DI.next d)
1102 : macqueen 1970 (* increase the depth to indicate that the expression is
1103 : macqueen 2033 * going to be wrapped by a type abstraction (TFN); see body *)
1104 : monnier 16
1105 : macqueen 1970 (* restore tyvar states to that before the translation *)
1106 : macqueen 1967 fun restore ([], []) = ()
1107 :     | restore (a::r, b::z) = (b := a; restore(r, z))
1108 :     | restore _ = bug "unexpected cases in mkPE"
1109 : monnier 16
1110 : macqueen 1948 (* [dbm, 6/22/06] Why do we need to restore the original
1111 : macqueen 1967 contents of the uninstantiated meta type variables?
1112 :     Only seems to be necessary if a given tyvar gets generalized
1113 : macqueen 1970 in two different valbinds. We assume that this does not
1114 :     happen (Single Generalization Conjecture) *)
1115 : macqueen 1948
1116 : macqueen 1967 val _ = restore(savedtvs, boundtvs)
1117 : monnier 16 val len = length(boundtvs)
1118 :    
1119 :     in TFN(LT.tkc_arg(len), exp')
1120 :     end
1121 :    
1122 :     and mkVBs (vbs, d) =
1123 : macqueen 1970 let fun mkVB (VB{pat=VARpat(V.VALvar{access=DA.LVAR v, ...}),
1124 : macqueen 2056 exp as VARexp (ref (w as (V.VALvar{typ,prim,...})), ptvs),
1125 : macqueen 1970 boundtvs=btvs, ...}, b: lexp) =
1126 : macqueen 1967 (* [dbm: 7/10/06] Originally, the mkVar and mkPE translations
1127 : macqueen 2056 * were chosen based on whether btvs and ptvs were the same
1128 : macqueen 1967 * list of tyvars, which would be the case for all non-primop
1129 :     * variables, but also in the primop case whenever the rhs
1130 :     * variable environment type (!typ) was the same (equalTypeP)
1131 :     * to the intrinsic type of the primop (e.g. when they are
1132 :     * both monotypes). So in most cases, the mkVar translation
1133 :     * will be used, and this drops the primop information!!!
1134 :     * This seems definitely wrong. *)
1135 :     (case prim
1136 :     of PrimOpId.Prim name =>
1137 : macqueen 1976 (case PrimOpTypeMap.primopTypeMap name
1138 :     of SOME(primopty) =>
1139 : macqueen 1970 if TU.equalTypeP(!typ,primopty)
1140 :     then LET(v, mkVar(w, d), b)
1141 :     else LET(v, mkPE(exp, d, btvs), b)
1142 :     | NONE => bug "mkVBs: unknown primop name")
1143 : macqueen 2056 | _ => LET(v, mkPE(exp, d, btvs), b))
1144 :     (*
1145 : georgekuan 1968 | _ => LET(v, mkVar(w, d), b))
1146 : macqueen 2056 *)
1147 : macqueen 1967 (* when generalized variables = instantiation params *)
1148 : monnier 16
1149 : macqueen 1970 | mkVB (VB{pat=VARpat(V.VALvar{access=DA.LVAR v, ...}),
1150 :     exp, boundtvs=btvs, ...}, b) =
1151 :     LET(v, mkPE(exp, d, btvs), b)
1152 : monnier 16
1153 : macqueen 1970 | mkVB (VB{pat=CONSTRAINTpat(VARpat(V.VALvar{access=DA.LVAR v, ...}),_),
1154 :     exp, boundtvs=tvs, ...}, b) =
1155 :     LET(v, mkPE(exp, d, tvs), b)
1156 : monnier 16
1157 : macqueen 1970 | mkVB (VB{pat, exp, boundtvs=tvs, ...}, b) =
1158 :     let val ee = mkPE(exp, d, tvs)
1159 :     val rules = [(fillPat(pat, d), b), (WILDpat, unitLexp)]
1160 :     val rootv = mkv()
1161 :     fun finish x = LET(rootv, ee, x)
1162 :     in MC.bindCompile(env, rules, finish, rootv, toTcLt d, complain,
1163 :     genintinfswitch)
1164 :     end
1165 : monnier 16
1166 : macqueen 1970 in fold mkVB vbs
1167 :     end (* mkVBs *)
1168 :    
1169 : monnier 16 and mkRVBs (rvbs, d) =
1170 : macqueen 1970 let fun mkRVB (RVB{var=V.VALvar{access=DA.LVAR v, typ=ref ty, ...},
1171 :     exp, boundtvs=btvs, ...}, (vlist, tlist, elist)) =
1172 :     let val ee = mkExp(exp, d) (* was mkPE(exp, d, btvs) *)
1173 :     (* [ZHONG?] we no longer track type bindings at RVB anymore ! *)
1174 :     val vt = toLty d ty
1175 :     in (v::vlist, vt::tlist, ee::elist)
1176 :     end
1177 :     | mkRVB _ = bug "unexpected valrec bindings in mkRVBs"
1178 : monnier 16
1179 : macqueen 1970 val (vlist, tlist, elist) = foldr mkRVB ([], [], []) rvbs
1180 : monnier 16
1181 :     in fn b => FIX(vlist, tlist, elist, b)
1182 :     end
1183 :    
1184 :     and mkEBs (ebs, d) =
1185 :     let fun g (EBgen {exn=TP.DATACON{rep=DA.EXN(DA.LVAR v), typ, ...},
1186 :     ident, ...}, b) =
1187 :     let val nt = toDconLty d typ
1188 :     val (argt, _) = LT.ltd_parrow nt
1189 :     in LET(v, ETAG(mkExp(ident, d), argt), b)
1190 :     end
1191 : monnier 100 | g (EBdef {exn=TP.DATACON{rep=DA.EXN(DA.LVAR v), typ, name, ...},
1192 : monnier 16 edef=TP.DATACON{rep=DA.EXN(acc), ...}}, b) =
1193 :     let val nt = toDconLty d typ
1194 :     val (argt, _) = LT.ltd_parrow nt
1195 : monnier 100 in LET(v, mkAccT(acc, LT.ltc_etag argt, SOME name), b)
1196 : monnier 16 end
1197 :     | g _ = bug "unexpected exn bindings in mkEBs"
1198 :    
1199 :     in fold g ebs
1200 :     end
1201 :    
1202 :    
1203 :     (***************************************************************************
1204 :     * *
1205 :     * Translating module exprs and decls into lambda expressions: *
1206 :     * *
1207 : macqueen 1970 * val mkStrexp : Absyn.strexp * depth -> PLambda.lexp *
1208 :     * val mkFctexp : Absyn.fctexp * depth -> PLambda.lexp *
1209 :     * val mkStrbs : Absyn.strb list * depth -> PLambda.lexp -> PLambda.lexp *
1210 :     * val mkFctbs : Absyn.fctb list * depth -> PLambda.lexp -> PLambda.lexp *
1211 : monnier 16 * *
1212 :     ***************************************************************************)
1213 :     and mkStrexp (se, d) =
1214 :     let fun g (VARstr s) = mkStr(s, d)
1215 :     | g (STRstr bs) = SRECORD (map (mkBnd d) bs)
1216 :     | g (APPstr {oper, arg, argtycs}) =
1217 :     let val e1 = mkFct(oper, d)
1218 : monnier 45 val tycs = map (tpsTyc d) argtycs
1219 : monnier 16 val e2 = mkStr(arg, d)
1220 :     in APP(TAPP(e1, tycs), e2)
1221 :     end
1222 :     | g (LETstr (dec, b)) = mkDec (dec, d) (g b)
1223 :     | g (MARKstr (b, reg)) = withRegion reg g b
1224 :    
1225 :     in g se
1226 :     end
1227 :    
1228 :     and mkFctexp (fe, d) =
1229 :     let fun g (VARfct f) = mkFct(f, d)
1230 : blume 587 | g (FCTfct {param as M.STR { access, ... }, argtycs, def }) =
1231 :     (case access of
1232 :     DA.LVAR v =>
1233 :     let val knds = map tpsKnd argtycs
1234 : macqueen 2033 val nd = DI.next d (* reflecting type abstraction *)
1235 : blume 587 val body = mkStrexp (def, nd)
1236 :     val hdr = buildHdr v
1237 :     (* binding of all v's components *)
1238 :     in
1239 :     TFN(knds, FN(v, strLty(param, nd, compInfo), hdr body))
1240 :     end
1241 :     | _ => bug "mkFctexp: unexpected access")
1242 : monnier 16 | g (LETfct (dec, b)) = mkDec (dec, d) (g b)
1243 :     | g (MARKfct (b, reg)) = withRegion reg g b
1244 :     | g _ = bug "unexpected functor expressions in mkFctexp"
1245 :    
1246 :     in g fe
1247 :     end
1248 :    
1249 :     and mkStrbs (sbs, d) =
1250 : blume 587 let fun g (STRB{str=M.STR { access, ... }, def, ... }, b) =
1251 :     (case access of
1252 :     DA.LVAR v =>
1253 : monnier 16 let val hdr = buildHdr v
1254 : blume 587 (* binding of all v's components *)
1255 :     in
1256 :     LET(v, mkStrexp(def, d), hdr b)
1257 : monnier 16 end
1258 : blume 587 | _ => bug "mkStrbs: unexpected access")
1259 : monnier 16 | g _ = bug "unexpected structure bindings in mkStrbs"
1260 : blume 587 in fold g sbs
1261 : monnier 16 end
1262 :    
1263 :     and mkFctbs (fbs, d) =
1264 : blume 587 let fun g (FCTB{fct=M.FCT { access, ... }, def, ... }, b) =
1265 :     (case access of
1266 :     DA.LVAR v =>
1267 : monnier 16 let val hdr = buildHdr v
1268 : blume 587 in
1269 :     LET(v, mkFctexp(def, d), hdr b)
1270 : monnier 16 end
1271 : blume 587 | _ => bug "mkFctbs: unexpected access")
1272 : monnier 16 | g _ = bug "unexpected functor bindings in mkStrbs"
1273 : blume 587 in fold g fbs
1274 : monnier 16 end
1275 :    
1276 :    
1277 :     (***************************************************************************
1278 :     * Translating absyn decls and exprs into lambda expression: *
1279 :     * *
1280 : macqueen 1970 * val mkExp : A.exp * DI.depth -> PLambda.lexp *
1281 :     * val mkDec : A.dec * DI.depth -> PLambda.lexp -> PLambda.lexp *
1282 : monnier 16 * *
1283 :     ***************************************************************************)
1284 :     and mkDec (dec, d) =
1285 : georgekuan 1987 let fun g (VALdec vbs) = mkVBs(vbs, d)
1286 :     | g (VALRECdec rvbs) = mkRVBs(rvbs, d)
1287 : monnier 16 | g (ABSTYPEdec{body,...}) = g body
1288 : georgekuan 1987 | g (EXCEPTIONdec ebs) = mkEBs(ebs, d)
1289 :     | g (STRdec sbs) = mkStrbs(sbs, d)
1290 :     | g (ABSdec sbs) = mkStrbs(sbs, d)
1291 :     | g (FCTdec fbs) = mkFctbs(fbs, d)
1292 : monnier 16 | g (LOCALdec(ld, vd)) = (g ld) o (g vd)
1293 :     | g (SEQdec ds) = foldr (op o) ident (map g ds)
1294 :     | g (MARKdec(x, reg)) =
1295 :     let val f = withRegion reg g x
1296 :     in fn y => withRegion reg f y
1297 :     end
1298 : monnier 100 | g (OPENdec xs) =
1299 :     let (* special hack to make the import tree simpler *)
1300 : blume 587 fun mkos (_, s as M.STR { access = acc, ... }) =
1301 :     if extern acc then
1302 : monnier 100 let val _ = mkAccT(acc, strLty(s, d, compInfo), NONE)
1303 : blume 587 in ()
1304 : monnier 100 end
1305 : blume 587 else ()
1306 : monnier 100 | mkos _ = ()
1307 :     in app mkos xs; ident
1308 :     end
1309 : monnier 16 | g _ = ident
1310 :     in g dec
1311 :     end
1312 :    
1313 :     and mkExp (exp, d) =
1314 : monnier 45 let val tTyc = toTyc d
1315 :     val tLty = toLty d
1316 : monnier 16
1317 :     fun mkRules xs = map (fn (RULE(p, e)) => (fillPat(p, d), g e)) xs
1318 :    
1319 : macqueen 1967 and g (VARexp (ref v, ts)) =
1320 : georgekuan 1987 (debugmsg ">>mkExp VARexp"; mkVE(v, map TP.VARty ts, d))
1321 : monnier 16
1322 : georgekuan 1987 | g (CONexp (dc, ts)) =
1323 :     (let val _ = debugmsg ">>mkExp CONexp: "
1324 :     val c = mkCE(dc, ts, NONE, d)
1325 : macqueen 2053 val _ = if !debugging then ppLexp c else ()
1326 : georgekuan 1987 in c end)
1327 :     | g (APPexp (CONexp(dc, ts), e2)) =
1328 :     (let val _ = debugmsg ">>mkExp APPexp: "
1329 :     val c = mkCE(dc, ts, SOME(g e2), d)
1330 : macqueen 2053 val _ = if !debugging then ppLexp c else ()
1331 : georgekuan 1987 in c end)
1332 : monnier 16 | g (INTexp (s, t)) =
1333 : georgekuan 1987 (debugmsg ">>mkExp INTexp";
1334 : monnier 16 ((if TU.equalType (t, BT.intTy) then INT (LN.int s)
1335 :     else if TU.equalType (t, BT.int32Ty) then INT32 (LN.int32 s)
1336 : mblume 1347 else if TU.equalType (t, BT.intinfTy) then VAR (getII s)
1337 : mblume 1682 else if TU.equalType (t, BT.int64Ty) then
1338 :     let val (hi, lo) = LN.int64 s
1339 :     in RECORD [WORD32 hi, WORD32 lo]
1340 :     end
1341 : mblume 1347 else bug "translate INTexp")
1342 : georgekuan 1980 handle Overflow => (repErr "int constant too large"; INT 0)))
1343 : monnier 16
1344 :     | g (WORDexp(s, t)) =
1345 : georgekuan 1987 (debugmsg ">>WORDexp";
1346 : monnier 16 ((if TU.equalType (t, BT.wordTy) then WORD (LN.word s)
1347 : mblume 1682 else if TU.equalType (t, BT.word8Ty) then WORD (LN.word8 s)
1348 :     else if TU.equalType (t, BT.word32Ty) then WORD32 (LN.word32 s)
1349 :     else if TU.equalType (t, BT.word64Ty) then
1350 :     let val (hi, lo) = LN.word64 s
1351 :     in RECORD [WORD32 hi, WORD32 lo]
1352 :     end
1353 :     else (ppType t; bug "translate WORDexp"))
1354 : georgekuan 1980 handle Overflow => (repErr "word constant too large"; INT 0)))
1355 : monnier 16
1356 :     | g (REALexp s) = REAL s
1357 :     | g (STRINGexp s) = STRING s
1358 :     | g (CHARexp s) = INT (Char.ord(String.sub(s, 0)))
1359 :     (** NOTE: the above won't work for cross compiling to
1360 :     multi-byte characters **)
1361 :    
1362 : monnier 45 | g (RECORDexp []) = unitLexp
1363 : monnier 16 | g (RECORDexp xs) =
1364 :     if sorted xs then RECORD (map (fn (_,e) => g e) xs)
1365 :     else let val vars = map (fn (l,e) => (l,(g e, mkv()))) xs
1366 :     fun bind ((_,(e,v)),x) = LET(v,e,x)
1367 :     val bexp = map (fn (_,(_,v)) => VAR v) (sortrec vars)
1368 :     in foldr bind (RECORD bexp) vars
1369 :     end
1370 :    
1371 :     | g (SELECTexp (LABEL{number=i,...}, e)) = SELECT(i, g e)
1372 :    
1373 :     | g (VECTORexp ([], ty)) =
1374 :     TAPP(coreAcc "vector0", [tTyc ty])
1375 :     | g (VECTORexp (xs, ty)) =
1376 :     let val tc = tTyc ty
1377 :     val vars = map (fn e => (g e, mkv())) xs
1378 :     fun bind ((e,v),x) = LET(v, e, x)
1379 :     val bexp = map (fn (_,v) => VAR v) vars
1380 :     in foldr bind (VECTOR (bexp, tc)) vars
1381 :     end
1382 :    
1383 :     | g (PACKexp(e, ty, tycs)) = g e
1384 : macqueen 1967 (* [dbm, 7/10/06]: Does PACKexp do anything now? What was it doing before
1385 :     * this was commented out? This appears to be the only place reformat was called
1386 :     * Is it also the only place the FLINT PACK constructor is used? [KM???] *)
1387 : macqueen 1970 (* (commented out by whom, when why?)
1388 : monnier 16 let val (nty, ks, tps) = TU.reformat(ty, tycs, d)
1389 : monnier 45 val ts = map (tpsTyc d) tps
1390 : monnier 16 (** use of LtyEnv.tcAbs is a temporary hack (ZHONG) **)
1391 :     val nts = ListPair.map LtyEnv.tcAbs (ts, ks)
1392 :     val nd = DI.next d
1393 :     in case (ks, tps)
1394 :     of ([], []) => g e
1395 : monnier 45 | _ => PACK(LT.ltc_poly(ks, [toLty nd nty]),
1396 :     ts, nts , g e)
1397 : monnier 16 end
1398 :     *)
1399 :     | g (SEQexp [e]) = g e
1400 :     | g (SEQexp (e::r)) = LET(mkv(), g e, g (SEQexp r))
1401 :    
1402 :     | g (APPexp (e1, e2)) = APP(g e1, g e2)
1403 :     | g (MARKexp (e, reg)) = withRegion reg g e
1404 :     | g (CONSTRAINTexp (e,_)) = g e
1405 :    
1406 :     | g (RAISEexp (e, ty)) = mkRaise(g e, tLty ty)
1407 : mblume 1641 | g (HANDLEexp (e, (l, ty))) =
1408 : monnier 16 let val rootv = mkv()
1409 :     fun f x = FN(rootv, tLty ty, x)
1410 :     val l' = mkRules l
1411 : monnier 45 in HANDLE(g e, MC.handCompile(env, l', f,
1412 : mblume 1347 rootv, toTcLt d, complain,
1413 :     genintinfswitch))
1414 : monnier 16 end
1415 :    
1416 :     | g (FNexp (l, ty)) =
1417 :     let val rootv = mkv()
1418 :     fun f x = FN(rootv, tLty ty, x)
1419 : mblume 1347 in MC.matchCompile (env, mkRules l, f, rootv, toTcLt d,
1420 :     complain, genintinfswitch)
1421 : monnier 16 end
1422 :    
1423 :     | g (CASEexp (ee, l, isMatch)) =
1424 :     let val rootv = mkv()
1425 :     val ee' = g ee
1426 :     fun f x = LET(rootv, ee', x)
1427 :     val l' = mkRules l
1428 :     in if isMatch
1429 : mblume 1347 then MC.matchCompile (env, l', f, rootv, toTcLt d,
1430 :     complain, genintinfswitch)
1431 :     else MC.bindCompile (env, l', f, rootv, toTcLt d,
1432 :     complain, genintinfswitch)
1433 : monnier 16 end
1434 :    
1435 : mblume 1332 | g (IFexp { test, thenCase, elseCase }) =
1436 :     COND (g test, g thenCase, g elseCase)
1437 :    
1438 :     | g (ANDALSOexp (e1, e2)) =
1439 :     COND (g e1, g e2, falseLexp)
1440 :    
1441 :     | g (ORELSEexp (e1, e2)) =
1442 :     COND (g e1, trueLexp, g e2)
1443 :    
1444 :     | g (WHILEexp { test, expr }) =
1445 :     let val fv = mkv ()
1446 :     val body =
1447 :     FN (mkv (), lt_unit,
1448 :     COND (g test,
1449 :     LET (mkv (), g expr, APP (VAR fv, unitLexp)),
1450 :     unitLexp))
1451 :     in
1452 :     FIX ([fv], [lt_u_u], [body], APP (VAR fv, unitLexp))
1453 :     end
1454 :    
1455 : monnier 16 | g (LETexp (dc, e)) = mkDec (dc, d) (g e)
1456 :    
1457 :     | g e =
1458 :     EM.impossibleWithBody "untranslateable expression"
1459 : macqueen 1344 (fn ppstrm => (PP.string ppstrm " expression: ";
1460 : monnier 16 PPAbsyn.ppExp (env,NONE) ppstrm (e, !ppDepth)))
1461 :    
1462 :     in g exp
1463 :     end
1464 :    
1465 : mblume 1347 and transIntInf d s =
1466 :     (* This is a temporary solution. Since IntInf literals
1467 :     * are created using a core function call, there is
1468 :     * no indication within the program that we are really
1469 :     * dealing with a constant value that -- in principle --
1470 :     * could be subject to such things as constant folding. *)
1471 : georgekuan 1971 let val consexp = CONexp (BT.consDcon, [ref (TP.INSTANTIATED BT.wordTy)])
1472 :     fun build [] = CONexp (BT.nilDcon, [ref (TP.INSTANTIATED BT.wordTy)])
1473 : mblume 1347 | build (d :: ds) = let
1474 :     val i = Word.toIntX d
1475 :     in
1476 :     APPexp (consexp,
1477 :     EU.TUPLEexp [WORDexp (IntInf.fromInt i, BT.wordTy),
1478 :     build ds])
1479 :     end
1480 :     fun small w =
1481 :     APP (coreAcc (if LN.isNegative s then "makeSmallNegInf"
1482 :     else "makeSmallPosInf"),
1483 :     mkExp (WORDexp (IntInf.fromInt (Word.toIntX w), BT.wordTy),
1484 :     d))
1485 :     in
1486 :     case LN.repDigits s of
1487 :     [] => small 0w0
1488 :     | [w] => small w
1489 :     | ws => APP (coreAcc (if LN.isNegative s then "makeNegInf"
1490 :     else "makePosInf"),
1491 :     mkExp (build ws, d))
1492 :     end
1493 : monnier 16
1494 : mblume 1347 (* Wrap bindings for IntInf.int literals around body. *)
1495 :     fun wrapII body = let
1496 :     fun one (n, v, b) = LET (v, transIntInf DI.top n, b)
1497 :     in
1498 :     IIMap.foldli one body (!iimap)
1499 :     end
1500 :    
1501 : monnier 100 (* wrapPidInfo: lexp * (pid * pidInfo) list -> lexp * importTree *)
1502 :     fun wrapPidInfo (body, pidinfos) =
1503 :     let val imports =
1504 :     let fun p2itree (ANON xl) =
1505 : blume 879 ImportTree.ITNODE (map (fn (i,z) => (i, p2itree z)) xl)
1506 :     | p2itree (NAMED _) = ImportTree.ITNODE []
1507 : monnier 100 in map (fn (p, pi) => (p, p2itree pi)) pidinfos
1508 :     end
1509 :     (*
1510 :     val _ = let val _ = say "\n ****************** \n"
1511 :     val _ = say "\n the current import tree is :\n"
1512 : blume 879 fun tree (ImportTree.ITNODE []) = ["\n"]
1513 :     | tree (ImportTree.ITNODE xl) =
1514 : monnier 100 foldr (fn ((i, x), z) =>
1515 :     let val ts = tree x
1516 :     val u = (Int.toString i) ^ " "
1517 :     in (map (fn y => (u ^ y)) ts) @ z
1518 :     end) [] xl
1519 :     fun pp (p, n) =
1520 :     (say ("Pid " ^ (PersStamps.toHex p) ^ "\n");
1521 :     app say (tree n))
1522 :     in app pp imports; say "\n ****************** \n"
1523 :     end
1524 :     *)
1525 :     val plexp =
1526 :     let fun get ((_, ANON xl), z) = foldl get z xl
1527 :     | get ((_, u as NAMED (_,t,_)), (n,cs,ts)) =
1528 :     (n+1, (n,u)::cs, t::ts)
1529 : monnier 16
1530 : monnier 100 (* get the fringe information *)
1531 :     val getp = fn ((_, pi), z) => get((0, pi), z)
1532 :     val (finfos, lts) =
1533 :     let val (_, fx, lx) = foldl getp (0,[],[]) pidinfos
1534 :     in (rev fx, rev lx)
1535 :     end
1536 : monnier 16
1537 : monnier 100 (* do the selection of all import variables *)
1538 :     fun mksel (u, xl, be) =
1539 :     let fun g ((i, pi), be) =
1540 :     let val (v, xs) = case pi of ANON z => (mkv(), z)
1541 :     | NAMED(v,_,z) => (v, z)
1542 :     in LET(v, SELECT(i, u), mksel(VAR v, xs, be))
1543 :     end
1544 :     in foldr g be xl
1545 :     end
1546 :     val impvar = mkv()
1547 :     val implty = LT.ltc_str lts
1548 :     val nbody = mksel (VAR impvar, finfos, body)
1549 :     in FN(impvar, implty, nbody)
1550 :     end
1551 :     in (plexp, imports)
1552 :     end (* function wrapPidInfo *)
1553 : monnier 16
1554 : monnier 100 (** the list of things being exported from the current compilation unit *)
1555 : monnier 16 val exportLexp = SRECORD (map VAR exportLvars)
1556 :    
1557 : georgekuan 1987 val _ = debugmsg ">>mkDec"
1558 : monnier 100 (** translating the ML absyn into the PLambda expression *)
1559 :     val body = mkDec (rootdec, DI.top) exportLexp
1560 : georgekuan 1987 val _ = debugmsg "<<mkDec"
1561 : mblume 1347 (** add bindings for intinf constants *)
1562 :     val body = wrapII body
1563 :    
1564 : monnier 100 (** wrapping up the body with the imported variables *)
1565 : mblume 1347 val (plexp, imports) = wrapPidInfo (body, PersMap.listItemsi (!persmap))
1566 : monnier 100
1567 : macqueen 2038 (** type check body (including kind check) **)
1568 : macqueen 2040 val _ = complain EM.WARN ">>translate typecheck" EM.nullErrorBody
1569 : macqueen 2039 val _ = print "**** Translate: typechecking plexp ****\n"
1570 : georgekuan 2047 (* val _ = PPLexp.printLexp plexp *)
1571 : macqueen 2054 val ltyerrors = ChkPlexp.checkLtyTop(plexp,0)
1572 :     val _ = if ltyerrors
1573 :     then (print "**** Translate: checkLty failed ****\n";
1574 : macqueen 2056 with_pp(fn str =>
1575 :     (PU.pps str "absyn:"; PP.newline str;
1576 :     ElabDebug.withInternals
1577 :     (fn () => PPAbsyn.ppDec (env,NONE) str (rootdec,1000)); PP.newline str;
1578 :     PU.pps str "lexp:"; PP.newline str;
1579 :     PPLexp.ppLexp 25 str plexp));
1580 : georgekuan 2058 complain EM.WARN "checkLty" EM.nullErrorBody;
1581 :     bug "PLambda type check error!")
1582 : macqueen 2054 else print "**** Translate: finished typechecking plexp ****\n"
1583 : macqueen 2038
1584 : georgekuan 2061
1585 : monnier 100 fun prGen (flag,printE) s e =
1586 :     if !flag then (say ("\n\n[After " ^ s ^ " ...]\n\n"); printE e) else ()
1587 : macqueen 2053 val _ = prGen(Control.FLINT.print, ppLexp) "Translate" plexp
1588 : monnier 100
1589 :     (** normalizing the plambda expression into FLINT *)
1590 : georgekuan 1987 val flint = let val _ = debugmsg ">>norm"
1591 : georgekuan 1992 val _ = if !debugging
1592 :     then complain EM.WARN ">>flintnm" EM.nullErrorBody
1593 :     else ()
1594 : georgekuan 1974 val n = FlintNM.norm plexp
1595 : georgekuan 1987 val _ = debugmsg "<<postnorm"
1596 : georgekuan 1974 in n end
1597 : monnier 100
1598 :     in {flint = flint, imports = imports}
1599 : monnier 16 end (* function transDec *)
1600 :    
1601 :     end (* top-level local *)
1602 :     end (* structure Translate *)

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