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-3/compiler/FLINT/trans/transtypes.sml
ViewVC logotype

Annotation of /sml/branches/primop-branch-3/compiler/FLINT/trans/transtypes.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 2740 - (view) (download)

1 : monnier 245 (* COPYRIGHT (c) 1998 YALE FLINT PROJECT *)
2 :     (* transtypes.sml *)
3 :    
4 :     signature TRANSTYPES =
5 :     sig
6 :     val genTT : unit -> {tpsKnd : Types.tycpath -> PLambdaType.tkind,
7 :     tpsTyc : DebIndex.depth -> Types.tycpath
8 :     -> PLambdaType.tyc,
9 :     toTyc : DebIndex.depth -> Types.ty -> PLambdaType.tyc,
10 :     toLty : DebIndex.depth -> Types.ty -> PLambdaType.lty,
11 :     strLty : Modules.Structure * DebIndex.depth
12 :     * ElabUtil.compInfo -> PLambdaType.lty,
13 :     fctLty : Modules.Functor * DebIndex.depth
14 : dbm 2451 * ElabUtil.compInfo -> PLambdaType.lty}
15 : monnier 245 end (* signature TRANSTYPES *)
16 :    
17 :     structure TransTypes : TRANSTYPES =
18 :     struct
19 :     local structure BT = BasicTypes
20 :     structure DA = Access
21 :     structure DI = DebIndex
22 :     structure EE = EntityEnv
23 :     structure EM = ErrorMsg
24 :     structure EPC = EntPathContext
25 :     structure EV = EvalEntity
26 :     structure INS = Instantiate
27 :     structure IP = InvPath
28 :     structure LT = PLambdaType
29 :     structure PT = PrimTyc
30 :     structure MU = ModuleUtil
31 :     structure SE = StaticEnv
32 :     structure TU = TypesUtil
33 : blume 2222 structure PP = PrettyPrintNew
34 : monnier 245 open Types Modules ElabDebug
35 :     in
36 :    
37 :     fun bug msg = ErrorMsg.impossible ("TransTypes: " ^ msg)
38 :     val say = Control.Print.say
39 : dbm 2456 val debugging = FLINT_Control.tmdebugging
40 : monnier 245 fun debugmsg (msg: string) =
41 :     if !debugging then (say msg; say "\n") else ()
42 :     val debugPrint = (fn x => debugPrint debugging x)
43 :     val defaultError =
44 :     EM.errorNoFile(EM.defaultConsumer(),ref false) SourceMap.nullRegion
45 :    
46 :     val env = StaticEnv.empty
47 : blume 2222
48 : monnier 245 fun ppType x =
49 :     ((PP.with_pp (EM.defaultConsumer())
50 : macqueen 1344 (fn ppstrm => (PP.string ppstrm "find: ";
51 : monnier 245 PPType.resetPPType();
52 :     PPType.ppType env ppstrm x)))
53 :     handle _ => say "fail to print anything")
54 :    
55 :     fun ppTycon x =
56 : blume 2222 ((PP.with_pp (EM.defaultConsumer())
57 :     (fn ppstrm => (PP.string ppstrm "find: ";
58 :     PPType.resetPPType();
59 :     PPType.ppTycon env ppstrm x)))
60 :     handle _ => say "fail to print anything")
61 : monnier 245
62 : blume 2222
63 :     fun ppLtyc ltyc =
64 :     PP.with_default_pp (fn ppstrm => PPLty.ppTyc 20 ppstrm ltyc)
65 :    
66 :    
67 : monnier 245 (****************************************************************************
68 :     * TRANSLATING ML TYPES INTO FLINT TYPES *
69 :     ****************************************************************************)
70 :     local val recTyContext = ref [~1]
71 :     in
72 :     fun enterRecTy (a) = (recTyContext := (a::(!recTyContext)))
73 :     fun exitRecTy () = (recTyContext := tl (!recTyContext))
74 :     fun recTyc (i) =
75 :     let val x = hd(!recTyContext)
76 :     val base = DI.innermost
77 :     in if x = 0 then LT.tcc_var(base, i)
78 :     else if x > 0 then LT.tcc_var(DI.di_inner base, i)
79 :     else bug "unexpected RECtyc"
80 :     end
81 :     fun freeTyc (i) =
82 :     let val x = hd(!recTyContext)
83 :     val base = DI.di_inner (DI.innermost)
84 :     in if x = 0 then LT.tcc_var(base, i)
85 :     else if x > 0 then LT.tcc_var(DI.di_inner base, i)
86 :     else bug "unexpected RECtyc"
87 :     end
88 :     end (* end of recTyc and freeTyc hack *)
89 :    
90 : gkuan 2740 fun tpsKnd (TP_VAR{kind,...}) =
91 :     let fun kindToTKind PK_MONO = LT.tkc_int 0
92 :     | kindToTKind (PK_SEQ x) = LT.tkc_seq(map kindToTKind x)
93 :     | kindToTKind (PK_FUN (paramks,bodyknd)) =
94 :     LT.tkc_fun(map kindToTKind paramks, kindToTKind bodyknd)
95 :     in kindToTKind kind
96 :     end
97 : monnier 245 | tpsKnd _ = bug "unexpected tycpath parameters in tpsKnd"
98 :    
99 : blume 902 fun genTT() =
100 :     let
101 :    
102 : monnier 245 fun tpsTyc d tp =
103 : gkuan 2740 let fun h (TP_VAR {tdepth, num, ...}, cur) =
104 : dbm 2451 LT.tcc_var(DI.calc(cur, tdepth), num)
105 : monnier 245 | h (TP_TYC tc, cur) = tycTyc(tc, cur)
106 :     | h (TP_SEL (tp, i), cur) = LT.tcc_proj(h(tp, cur), i)
107 :     | h (TP_APP (tp, ps), cur) =
108 :     LT.tcc_app(h(tp, cur), map (fn x => h(x, cur)) ps)
109 :     | h (TP_FCT (ps, ts), cur) =
110 :     let val ks = map tpsKnd ps
111 :     val cur' = DI.next cur
112 :     val ts' = map (fn x => h(x, cur')) ts
113 :     in LT.tcc_fn(ks, LT.tcc_seq ts')
114 :     end
115 :    
116 :     in h(tp, d)
117 :     end
118 :    
119 :     (*
120 :     and tycTyc x =
121 :     Stats.doPhase(Stats.makePhase "Compiler 043 1-tycTyc") tycTyc0 x
122 :     *)
123 :    
124 :     and tycTyc(tc, d) =
125 :     let fun dtsTyc nd ({dcons: dconDesc list, arity=i, ...} : dtmember) =
126 :     let val nnd = if i=0 then nd else DI.next nd
127 :     fun f ({domain=NONE, rep, name}, r) = (LT.tcc_unit)::r
128 :     | f ({domain=SOME t, rep, name}, r) = (toTyc nnd t)::r
129 :    
130 :     val _ = enterRecTy i
131 :     val core = LT.tcc_sum(foldr f [] dcons)
132 :     val _ = exitRecTy()
133 :    
134 :     val resTyc = if i=0 then core
135 :     else (let val ks = LT.tkc_arg i
136 :     in LT.tcc_fn(ks, core)
137 :     end)
138 :     in (LT.tkc_int i, resTyc)
139 :     end
140 :    
141 : blume 902 fun dtsFam (freetycs, fam as { members, ... } : dtypeFamily) =
142 :     case ModulePropLists.dtfLtyc fam of
143 :     SOME (tc, od) =>
144 : gkuan 2395 LT.tc_adj(tc, od, d) (* invariant: tc contains no free variables
145 : blume 902 * so tc_adj should have no effects *)
146 :     | NONE =>
147 :     let fun ttk (GENtyc { arity, ... }) = LT.tkc_int arity
148 :     | ttk (DEFtyc{tyfun=TYFUN{arity=i, ...},...}) =
149 :     LT.tkc_int i
150 :     | ttk _ = bug "unexpected ttk in dtsFam"
151 :     val ks = map ttk freetycs
152 :     val (nd, hdr) =
153 :     case ks of [] => (d, fn t => t)
154 :     | _ => (DI.next d, fn t => LT.tcc_fn(ks, t))
155 :     val mbs = Vector.foldr (op ::) nil members
156 :     val mtcs = map (dtsTyc (DI.next nd)) mbs
157 :     val (fks, fts) = ListPair.unzip mtcs
158 :     val nft = case fts of [x] => x | _ => LT.tcc_seq fts
159 :     val tc = hdr(LT.tcc_fn(fks, nft))
160 :     val _ = ModulePropLists.setDtfLtyc (fam, SOME(tc, d))
161 :     in tc
162 :     end
163 :    
164 :     (*
165 : monnier 245 fun dtsFam (_, {lambdatyc=ref (SOME (tc,od)), ...} : dtypeFamily) =
166 :     LT.tc_adj(tc, od, d) (* invariant: tc contains no free variables
167 :     so tc_adj should have no effects *)
168 :     | dtsFam (freetycs, {members, lambdatyc=x, ...}) =
169 : blume 587 let fun ttk (GENtyc { arity, ... }) = LT.tkc_int arity
170 : monnier 245 | ttk (DEFtyc{tyfun=TYFUN{arity=i, ...},...}) = LT.tkc_int i
171 :     | ttk _ = bug "unexpected ttk in dtsFam"
172 :     val ks = map ttk freetycs
173 :     val (nd, hdr) =
174 :     case ks of [] => (d, fn t => t)
175 :     | _ => (DI.next d, fn t => LT.tcc_fn(ks, t))
176 :     val mbs = Vector.foldr (op ::) nil members
177 :     val mtcs = map (dtsTyc (DI.next nd)) mbs
178 :     val (fks, fts) = ListPair.unzip mtcs
179 :     val nft = case fts of [x] => x | _ => LT.tcc_seq fts
180 :     val tc = hdr(LT.tcc_fn(fks, nft))
181 :     val _ = (x := SOME(tc, d))
182 :     in tc
183 :     end
184 : blume 902 *)
185 : monnier 245
186 : blume 902 fun h (PRIMITIVE pt, _) = LT.tcc_prim (PrimTyc.pt_fromint pt)
187 : monnier 245 | h (DATATYPE {index, family, freetycs, stamps, root}, _) =
188 :     let val tc = dtsFam (freetycs, family)
189 :     val n = Vector.length stamps
190 : blume 2222 val names = Vector.map (fn ({tycname,...}: dtmember) => Symbol.name tycname)
191 :     (#members family)
192 :     (* invariant: n should be the number of family members *)
193 :     in LT.tcc_fix((n, names, tc, (map g freetycs)), index)
194 : monnier 245 end
195 :     | h (ABSTRACT tc, 0) = (g tc)
196 :     (*>>> LT.tcc_abs(g tc) <<<*)
197 :     | h (ABSTRACT tc, n) = (g tc)
198 :     (*>>> we tempoarily turned off the use of abstract tycons in
199 :     the intermediate language; proper support of ML-like
200 :     abstract types in the IL may require changes to the
201 :     ML language. (ZHONG)
202 :     let val ks = LT.tkc_arg n
203 :     fun fromto(i,j) = if i < j then (i::fromto(i+1,j)) else []
204 :     val fs = fromto(0, n)
205 :     val ts = map (fn i => LT.tcc_var(DI.innermost, i)) fs
206 :     val b = LT.tcc_app(tycTyc(tc, DI.next d), ts)
207 :     in LT.tcc_fn(ks, LT.tcc_abs b)
208 :     end
209 :     <<<*)
210 :     | h (FLEXTYC tp, _) = tpsTyc d tp
211 :     | h (FORMAL, _) = bug "unexpected FORMAL kind in tycTyc-h"
212 :     | h (TEMP, _) = bug "unexpected TEMP kind in tycTyc-h"
213 :    
214 : blume 587 and g (tycon as GENtyc { arity, kind, ... }) =
215 :     (case kind of
216 :     k as DATATYPE _ =>
217 :     if TU.eqTycon(tycon, BT.refTycon) then LT.tcc_prim (PT.ptc_ref)
218 :     else h(k, arity)
219 :     | k => h (k, arity))
220 : monnier 245 | g (DEFtyc{tyfun, ...}) = tfTyc(tyfun, d)
221 :     | g (RECtyc i) = recTyc i
222 :     | g (FREEtyc i) = freeTyc i
223 :     | g (RECORDtyc _) = bug "unexpected RECORDtyc in tycTyc-g"
224 :     | g (PATHtyc{arity, path=InvPath.IPATH ss, entPath}) =
225 :     ((* say "*** Warning for compiler writers: PATHtyc ";
226 :     app (fn x => (say (Symbol.name x); say ".")) ss;
227 :     say " in translate: ";
228 :     say (EntPath.entPathToString entPath);
229 :     say "\n"; *)
230 :     if arity > 0 then LT.tcc_fn(LT.tkc_arg arity, LT.tcc_void)
231 :     else LT.tcc_void)
232 :     | g (ERRORtyc) = bug "unexpected tycon in tycTyc-g"
233 :    
234 :     in (g tc)
235 :     end
236 :    
237 :     and tfTyc (TYFUN{arity=0, body}, d) = toTyc d body
238 :     | tfTyc (TYFUN{arity, body}, d) =
239 :     let val ks = LT.tkc_arg arity
240 :     in LT.tcc_fn(ks, toTyc (DI.next d) body)
241 :     end
242 :    
243 :     and toTyc d t =
244 :     let val m : (tyvar * LT.tyc) list ref = ref []
245 :     fun lookTv tv =
246 :     let val xxx = !m
247 :     fun uu ((z as (a,x))::r, b, n) =
248 :     if a = tv then (x, z::((rev b)@r)) else uu(r, z::b, n+1)
249 :     | uu ([], b, n) = let val zz = h (!tv)
250 :     val nb = if n > 64 then tl b else b
251 :     in (zz, (tv, zz)::(rev b))
252 :     end
253 :     val (res, nxx) = uu(xxx, [], 0)
254 :     in m := nxx; res
255 :     end
256 :    
257 :     and h (INSTANTIATED t) = g t
258 : dbm 2451 | h (LBOUND{depth,index}) =
259 :     LT.tcc_var(DI.calc(d, depth), index)
260 : gkuan 2394 | h (UBOUND _) = LT.tcc_void
261 : blume 2222 (* dbm: should this have been converted to a TV_MARK before
262 : gkuan 2394 * being passed to toTyc?
263 :     * gk: Doesn't seem to experimentally *)
264 :     | h (OPEN _) = LT.tcc_void
265 : blume 2222 | h _ = bug "toTyc:h" (* LITERAL and SCHEME should not occur *)
266 : monnier 245
267 :     and g (VARty tv) = (* h(!tv) *) lookTv tv
268 :     | g (CONty(RECORDtyc _, [])) = LT.tcc_unit
269 :     | g (CONty(RECORDtyc _, ts)) = LT.tcc_tuple (map g ts)
270 :     | g (CONty(tyc, [])) = tycTyc(tyc, d)
271 :     | g (CONty(DEFtyc{tyfun,...}, args)) = g(TU.applyTyfun(tyfun,args))
272 : blume 587 | g (CONty (tc as GENtyc { kind, ... }, ts)) =
273 :     (case (kind, ts) of
274 :     (ABSTRACT _, ts) =>
275 :     LT.tcc_app(tycTyc(tc, d), map g ts)
276 :     | (_, [t1, t2]) =>
277 :     if TU.eqTycon(tc, BT.arrowTycon) then LT.tcc_parrow(g t1, g t2)
278 :     else LT.tcc_app(tycTyc(tc, d), [g t1, g t2])
279 :     | _ => LT.tcc_app (tycTyc (tc, d), map g ts))
280 : monnier 245 | g (CONty(tyc, ts)) = LT.tcc_app(tycTyc(tyc, d), map g ts)
281 : blume 2222 | g (IBOUND i) = LT.tcc_var(DI.innermost, i)
282 :     (* [KM] IBOUNDs are encountered when toTyc
283 :     * is called on the body of a POLYty in
284 :     * toLty (see below). *)
285 : monnier 245 | g (POLYty _) = bug "unexpected poly-type in toTyc"
286 :     | g (UNDEFty) = bug "unexpected undef-type in toTyc"
287 : blume 2222 | g (WILDCARDty) = bug "unexpected wildcard-type in toTyc"
288 :     in g t
289 : monnier 245 end
290 :    
291 :     and toLty d (POLYty {tyfun=TYFUN{arity=0, body}, ...}) = toLty d body
292 :     | toLty d (POLYty {tyfun=TYFUN{arity, body},...}) =
293 :     let val ks = LT.tkc_arg arity
294 :     in LT.ltc_poly(ks, [toLty (DI.next d) body])
295 :     end
296 :    
297 :     | toLty d x = LT.ltc_tyc (toTyc d x)
298 :    
299 :     (****************************************************************************
300 :     * TRANSLATING ML MODULES INTO FLINT TYPES *
301 :     ****************************************************************************)
302 :    
303 :     fun specLty (elements, entEnv, depth, compInfo) =
304 :     let fun g ([], entEnv, ltys) = rev ltys
305 : dbm 2571 | g ((sym, (TYCspec _ ))::rest, entEnv, ltys) =
306 :     g(rest, entEnv, ltys)
307 : monnier 245 | g ((sym, STRspec {sign, entVar, ...})::rest, entEnv, ltys) =
308 :     let val rlzn = EE.lookStrEnt(entEnv,entVar)
309 :     val lt = strRlznLty(sign, rlzn, depth, compInfo)
310 :     in g(rest, entEnv, lt::ltys)
311 :     end
312 :     | g ((sym, FCTspec {sign, entVar, ...})::rest, entEnv, ltys) =
313 :     let val rlzn = EE.lookFctEnt(entEnv,entVar)
314 :     val lt = fctRlznLty(sign, rlzn, depth, compInfo)
315 :     in g(rest, entEnv, lt::ltys)
316 :     end
317 :     | g ((sym, spec)::rest, entEnv, ltys) =
318 :     let val _ = debugmsg ">>specLtyElt"
319 :     fun transty ty =
320 :     ((MU.transType entEnv ty)
321 :     handle EE.Unbound =>
322 :     (debugmsg "$specLty";
323 :     withInternals(fn () =>
324 :     debugPrint("entEnv: ",
325 :     (fn pps => fn ee =>
326 :     PPModules.ppEntityEnv pps (ee,SE.empty,12)),
327 :     entEnv));
328 :     debugmsg ("$specLty: should have printed entEnv");
329 :     raise EE.Unbound))
330 :    
331 :     fun mapty t = toLty depth (transty t)
332 :    
333 :     in case spec
334 :     of VALspec{spec=typ,...} =>
335 :     g(rest, entEnv, (mapty typ)::ltys)
336 :     | CONspec{spec=DATACON{rep=DA.EXN _,
337 :     typ, ...}, ...} =>
338 :     let val argt =
339 :     if BT.isArrowType typ then
340 :     #1(LT.ltd_parrow (mapty typ))
341 :     else LT.ltc_unit
342 :     in g(rest, entEnv, (LT.ltc_etag argt)::ltys)
343 :     end
344 :     | CONspec{spec=DATACON _, ...} =>
345 :     g(rest, entEnv, ltys)
346 :     | _ => bug "unexpected spec in specLty"
347 :     end
348 :    
349 :     in g (elements, entEnv, [])
350 :     end
351 :    
352 :     (*
353 :     and signLty (sign, depth, compInfo) =
354 :     let fun h (SIG {kind=SOME _, lambdaty=ref (SOME(lt, od)), ...}) = lt
355 :     (* LT.lt_adj(lt, od, depth) *)
356 :     | h (sign as SIG{kind=SOME _, lambdaty as ref NONE, ...}) =
357 :     (* Invariant: we assum that all Named signatures (kind=SOME _) are
358 :     * defined at top-level, outside any functor definitions. (ZHONG)
359 :     *)
360 :     let val {rlzn=rlzn, tycpaths=tycpaths} =
361 :     INS.instParam {sign=sign, entEnv=EE.empty, depth=depth,
362 :     rpath=InvPath.IPATH[], compInfo=compInfo,
363 :     region=SourceMap.nullRegion}
364 :     val nd = DI.next depth
365 :     val nlty = strMetaLty(sign, rlzn, nd, compInfo)
366 :    
367 :     val ks = map tpsKnd tycpaths
368 :     val lt = LT.ltc_poly(ks, nlty)
369 :     in lambdaty := SOME (lt, depth); lt
370 :     end
371 :     | h _ = bug "unexpected sign in signLty"
372 :     in h sign
373 :     end
374 :     *)
375 : blume 902 and strMetaLty (sign, rlzn as { entities, ... }: strEntity, depth, compInfo) =
376 :     case (sign, ModulePropLists.strEntityLty rlzn) of
377 :     (_, SOME (lt, od)) => LT.lt_adj(lt, od, depth)
378 :     | (SIG { elements, ... }, NONE) =>
379 : blume 587 let val ltys = specLty (elements, entities, depth, compInfo)
380 :     val lt = (* case ltys of [] => LT.ltc_int
381 :     | _ => *) LT.ltc_str(ltys)
382 : blume 902 in
383 :     ModulePropLists.setStrEntityLty (rlzn, SOME(lt, depth));
384 :     lt
385 : blume 587 end
386 :     | _ => bug "unexpected sign and rlzn in strMetaLty"
387 : monnier 245
388 : blume 587 and strRlznLty (sign, rlzn : strEntity, depth, compInfo) =
389 : blume 902 case (sign, ModulePropLists.strEntityLty rlzn) of
390 :     (sign, SOME (lt,od)) => LT.lt_adj(lt, od, depth)
391 : monnier 245
392 :     (* Note: the code here is designed to improve the "toLty" translation;
393 :     by translating the signature instead of the structure, this can
394 :     potentially save time on strLty. But it can increase the cost of
395 :     other procedures. Thus we turn it off temporarily. (ZHONG)
396 :    
397 : blume 587 | (SIG{kind=SOME _, ...}, {lambdaty, ...}) =>
398 : monnier 245 let val sgt = signLty(sign, depth, compInfo)
399 :     (* Invariant: we assum that all Named signatures
400 :     * (kind=SOME _) are defined at top-level, outside any
401 :     * functor definitions. (ZHONG)
402 :     *)
403 :     val argtycs = INS.getTycPaths{sign=sign, rlzn=rlzn,
404 :     entEnv=EE.empty, compInfo=compInfo}
405 :     val lt = LT.lt_inst(sgt, map (tpsTyc depth) argtycs)
406 :     in lambdaty := SOME(lt, depth); lt
407 :     end
408 :     *)
409 : blume 587 | _ => strMetaLty(sign, rlzn, depth, compInfo)
410 : monnier 245
411 :     and fctRlznLty (sign, rlzn, depth, compInfo) =
412 : blume 902 case (sign, ModulePropLists.fctEntityLty rlzn, rlzn) of
413 :     (sign, SOME (lt, od), _) => LT.lt_adj(lt, od, depth)
414 :     | (FSIG{paramsig, bodysig, ...}, _,
415 :     {closure as CLOSURE{env,...}, ...}) =>
416 : blume 587 let val {rlzn=argRlzn, tycpaths=tycpaths} =
417 : dbm 2451 INS.instParam {sign=paramsig, entEnv=env, tdepth=depth,
418 : blume 587 rpath=InvPath.IPATH[], compInfo=compInfo,
419 :     region=SourceMap.nullRegion}
420 :     val nd = DI.next depth
421 :     val paramLty = strMetaLty(paramsig, argRlzn, nd, compInfo)
422 :     val ks = map tpsKnd tycpaths
423 :     val bodyRlzn =
424 :     EV.evalApp(rlzn, argRlzn, nd, EPC.initContext,
425 :     IP.empty, compInfo)
426 :     val bodyLty = strRlznLty(bodysig, bodyRlzn, nd, compInfo)
427 :    
428 :     val lt = LT.ltc_poly(ks, [LT.ltc_fct([paramLty],[bodyLty])])
429 : blume 902 in
430 :     ModulePropLists.setFctEntityLty (rlzn, SOME (lt, depth));
431 :     lt
432 : blume 587 end
433 :     | _ => bug "fctRlznLty"
434 : monnier 245
435 : blume 587 and strLty (str as STR { sign, rlzn, ... }, depth, compInfo) =
436 : blume 902 (case ModulePropLists.strEntityLty rlzn of
437 :     SOME (lt, od) => LT.lt_adj(lt, od, depth)
438 :     | NONE =>
439 : blume 587 let val lt = strRlznLty(sign, rlzn, depth, compInfo)
440 : blume 902 in
441 :     ModulePropLists.setStrEntityLty (rlzn, SOME(lt, depth));
442 :     lt
443 : blume 587 end)
444 :     | strLty _ = bug "unexpected structure in strLty"
445 : monnier 245
446 : blume 587 and fctLty (fct as FCT { sign, rlzn, ... }, depth, compInfo) =
447 : blume 902 (case ModulePropLists.fctEntityLty rlzn of
448 :     SOME (lt,od) => LT.lt_adj(lt, od, depth)
449 :     | NONE =>
450 : blume 587 let val lt = fctRlznLty(sign, rlzn, depth, compInfo)
451 : blume 902 in
452 :     ModulePropLists.setFctEntityLty (rlzn, SOME(lt,depth));
453 :     lt
454 : blume 587 end)
455 :     | fctLty _ = bug "unexpected functor in fctLty"
456 : monnier 245
457 :     (****************************************************************************
458 :     * A HASH-CONSING VERSION OF THE ABOVE TRANSLATIONS *
459 :     ****************************************************************************)
460 :    
461 : blume 587 (*
462 : monnier 498 structure MIDict = RedBlackMapFn(struct type ord_key = ModuleId.modId
463 : monnier 411 val compare = ModuleId.cmp
464 : monnier 245 end)
465 : blume 587 *)
466 : monnier 245
467 :     (*
468 :     val m1 = ref (MIDict.mkDict()) (* modid (tycon) -> LT.tyc *)
469 :     val m2 = ref (MIDict.mkDict()) (* modid (str/fct) -> LT.lty *)
470 :    
471 :     fun tycTycLook (t as (GENtyc _ | DEFtyc _), d) =
472 :     let tid = MU.tycId t
473 :     in (case MIDict.peek(!m1, tid)
474 : gkuan 2395 of SOME (t', od) => LT.tc_adj(t', od, d)
475 : monnier 245 | NONE =>
476 :     let val x = tycTyc (t, d)
477 :     val _ = (m1 := TcDict.insert(!m1, tid, (x, d)))
478 :     in x
479 :     end)
480 :     end
481 :     | tycTycLook x = tycTyc tycTycLook x
482 :    
483 :     (*
484 :     val toTyc = toTyc tycTycLook
485 :     val toLty = toTyc tycTycLook
486 :     *)
487 :     val coreDict = (toTyc, toLty)
488 :    
489 :     fun strLtyLook (s as STR _, d) =
490 :     let sid = MU.strId s
491 :     in (case MIDict.peek(!m2, sid)
492 :     of SOME (t', od) => LT.lt_adj(t', od, d)
493 :     | NONE =>
494 :     let val x = strLty (coreDict, strLtyLook,
495 :     fctLtyLook) (s, d)
496 :     val _ = (m2 := TcDict.insert(!m2, sid, (x, d)))
497 :     in x
498 :     end)
499 :     end
500 :     | strLtyLook x = strLty (coreDict, strLtyLook, fctLtyLook)
501 :    
502 :     and fctLtyLook (f as FCT _, d) =
503 :     let fid = fctId f
504 :     in (case MIDict.peek(!m2, fid)
505 :     of SOME (t', od) => LT.lt_adj(t', od, d)
506 :     | NONE =>
507 :     let val x = fctLty (tycTycLook, strLtyLook,
508 :     fctLtyLook) (s, d)
509 :     val _ = (m2 := TcDict.insert(!m2, fid, (x, d)))
510 :     in x
511 :     end)
512 :     end
513 :     | fctLtyLook x = fctLty (coreDict, strLtyLook, fctLtyLook)
514 :     *)
515 :    
516 :     in {tpsKnd=tpsKnd, tpsTyc=tpsTyc,
517 : dbm 2451 toTyc=toTyc, toLty=toLty, strLty=strLty, fctLty=fctLty}
518 : monnier 245 end (* function genTT *)
519 :    
520 :     end (* toplevel local *)
521 :     end (* structure TransTypes *)

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