Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Tracker SCM

SCM Repository

[smlnj] Diff of /sml/branches/SMLNJ/src/compiler/FLINT/trans/transtypes.sml
ViewVC logotype

Diff of /sml/branches/SMLNJ/src/compiler/FLINT/trans/transtypes.sml

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 44, Sun Mar 22 20:10:57 1998 UTC revision 45, Sun Mar 22 20:11:09 1998 UTC
# Line 3  Line 3 
3    
4  signature TRANSTYPES =  signature TRANSTYPES =
5  sig  sig
6    val tpsKnd : Types.tycpath -> PLambdaType.tkind    val genTT  : unit -> {tpsKnd : Types.tycpath -> PLambdaType.tkind,
7    val tpsTyc : DebIndex.depth -> Types.tycpath -> PLambdaType.tyc                          tpsTyc : DebIndex.depth -> Types.tycpath
8                                     -> PLambdaType.tyc,
9    val toTyc  : DebIndex.depth -> Types.ty -> PLambdaType.tyc                          toTyc  : DebIndex.depth -> Types.ty -> PLambdaType.tyc,
10    val toLty  : DebIndex.depth -> Types.ty -> PLambdaType.lty                          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                                     * ElabUtil.compInfo -> PLambdaType.lty}
15  end (* signature TRANSTYPES *)  end (* signature TRANSTYPES *)
16    
17  structure TransTypes : TRANSTYPES =  structure TransTypes : TRANSTYPES =
18  struct  struct
19  local structure BT = BasicTypes  local structure BT = BasicTypes
20          structure DA = Access
21        structure DI = DebIndex        structure DI = DebIndex
22        structure PT = PrimTyc        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        structure LT = PLambdaType
29          structure PT = PrimTyc
30          structure MU = ModuleUtil
31          structure SE = StaticEnv
32        structure TU = TypesUtil        structure TU = TypesUtil
33        open Types        open Types Modules ElabDebug
   
       val tcAppSt = LT.tcc_app  
34  in  in
35    
36  fun bug msg = ErrorMsg.impossible ("TransTypes: " ^ msg)  fun bug msg = ErrorMsg.impossible ("TransTypes: " ^ msg)
37  val say = Control.Print.say  val say = Control.Print.say
38    val debugging = Control.CG.tmdebugging
39    fun debugmsg (msg: string) =
40      if !debugging then (say msg; say "\n") else ()
41    val debugPrint = (fn x => debugPrint debugging x)
42    val defaultError =
43      EM.errorNoFile(EM.defaultConsumer(),ref false) SourceMap.nullRegion
44    
45  local  local
46  structure PP = PrettyPrint  structure PP = PrettyPrint
 structure EM = ErrorMsg  
47  in  in
48  val env = StaticEnv.empty  val env = StaticEnv.empty
49  fun ppType x =  fun ppType x =
# Line 45  Line 61 
61    handle _ => say "fail to print anything")    handle _ => say "fail to print anything")
62  end  end
63    
64    (****************************************************************************
65     *               TRANSLATING ML TYPES INTO FLINT TYPES                      *
66     ****************************************************************************)
67  local val recTyContext = ref [~1]  local val recTyContext = ref [~1]
68  in  in
69  fun enterRecTy (a) = (recTyContext := (a::(!recTyContext)))  fun enterRecTy (a) = (recTyContext := (a::(!recTyContext)))
# Line 145  Line 164 
164                    fun fromto(i,j) = if i < j then (i::fromto(i+1,j)) else []                    fun fromto(i,j) = if i < j then (i::fromto(i+1,j)) else []
165                    val fs = fromto(0, n)                    val fs = fromto(0, n)
166                    val ts = map (fn i => LT.tcc_var(DI.innermost, i)) fs                    val ts = map (fn i => LT.tcc_var(DI.innermost, i)) fs
167                    val b = tcAppSt(tycTyc(tc, DI.next d), ts)                    val b = LT.tcc_app(tycTyc(tc, DI.next d), ts)
168                 in LT.tcc_fn(ks, LT.tcc_abs b)                 in LT.tcc_fn(ks, LT.tcc_abs b)
169                end                end
170                <<<*)                <<<*)
# Line 184  Line 203 
203    let val m : (tyvar * LT.tyc) list ref = ref []    let val m : (tyvar * LT.tyc) list ref = ref []
204        fun lookTv tv =        fun lookTv tv =
205          let val xxx = !m          let val xxx = !m
206              fun uu ((a,x)::r) = if a = tv then x else uu r              fun uu ((z as (a,x))::r, b, n) =
207                | uu [] = let val zz = h (!tv)                   if a = tv then (x, z::((rev b)@r)) else uu(r, z::b, n+1)
208                              val _ = (m := ((tv,zz)::xxx))                | uu ([], b, n) = let val zz = h (!tv)
209                           in zz                                      val nb = if n > 64 then tl b else b
210                                     in (zz, (tv, zz)::(rev b))
211                          end                          end
212           in uu xxx              val (res, nxx) = uu(xxx, [], 0)
213             in m := nxx; res
214          end          end
215    
216        and h (INSTANTIATED t) = g t        and h (INSTANTIATED t) = g t
# Line 203  Line 224 
224          | g (CONty(tyc, [])) = tycTyc(tyc, d)          | g (CONty(tyc, [])) = tycTyc(tyc, d)
225          | g (CONty(DEFtyc{tyfun,...}, args)) = g(TU.applyTyfun(tyfun,args))          | g (CONty(DEFtyc{tyfun,...}, args)) = g(TU.applyTyfun(tyfun,args))
226          | g (CONty(tc as GENtyc {kind=ABSTRACT _, ...}, ts)) =          | g (CONty(tc as GENtyc {kind=ABSTRACT _, ...}, ts)) =
227                tcAppSt(tycTyc(tc, d), map g ts)                LT.tcc_app(tycTyc(tc, d), map g ts)
228          | g (CONty(tc as GENtyc _, [t1, t2])) =          | g (CONty(tc as GENtyc _, [t1, t2])) =
229                if TU.eqTycon(tc, BT.arrowTycon) then LT.tcc_parrow(g t1, g t2)                if TU.eqTycon(tc, BT.arrowTycon) then LT.tcc_parrow(g t1, g t2)
230                else LT.tcc_app(tycTyc(tc, d), [g t1, g t2])                else LT.tcc_app(tycTyc(tc, d), [g t1, g t2])
# Line 224  Line 245 
245    
246    | toLty d x = LT.ltc_tyc (toTyc d x)    | toLty d x = LT.ltc_tyc (toTyc d x)
247    
248    (****************************************************************************
249     *               TRANSLATING ML MODULES INTO FLINT TYPES                    *
250     ****************************************************************************)
251    
252    fun specLty (elements, entEnv, depth, compInfo) =
253      let fun g ([], entEnv, ltys) = rev ltys
254            | g ((sym, TYCspec _)::rest, entEnv, ltys) = g(rest, entEnv, ltys)
255            | g ((sym, STRspec {sign, entVar, ...})::rest, entEnv, ltys) =
256                  let val rlzn = EE.lookStrEnt(entEnv,entVar)
257                      val lt = strRlznLty(sign, rlzn, depth, compInfo)
258                   in g(rest, entEnv, lt::ltys)
259                  end
260            | g ((sym, FCTspec {sign, entVar, ...})::rest, entEnv, ltys) =
261                  let val rlzn = EE.lookFctEnt(entEnv,entVar)
262                      val lt = fctRlznLty(sign, rlzn, depth, compInfo)
263                   in g(rest, entEnv, lt::ltys)
264                  end
265            | g ((sym, spec)::rest, entEnv, ltys) =
266                  let val _ = debugmsg ">>specLtyElt"
267                      fun transty ty =
268                        ((MU.transType entEnv ty)
269                          handle EE.Unbound =>
270                             (debugmsg "$specLty";
271                              withInternals(fn () =>
272                               debugPrint("entEnv: ",
273                                     (fn pps => fn ee =>
274                                      PPModules.ppEntityEnv pps (ee,SE.empty,12)),
275                                      entEnv));
276                              debugmsg ("$specLty: should have printed entEnv");
277                              raise EE.Unbound))
278    
279                      fun mapty t = toLty depth (transty t)
280    
281                   in case spec
282                       of VALspec{spec=typ,...} =>
283                            g(rest, entEnv, (mapty typ)::ltys)
284                        | CONspec{spec=DATACON{rep=DA.EXN _,
285                                               typ, ...}, ...} =>
286                            let val argt =
287                                  if BT.isArrowType typ then
288                                       #1(LT.ltd_parrow (mapty typ))
289                                  else LT.ltc_unit
290                             in g(rest, entEnv, (LT.ltc_etag argt)::ltys)
291                            end
292                        | CONspec{spec=DATACON _, ...} =>
293                            g(rest, entEnv, ltys)
294                        | _ => bug "unexpected spec in specLty"
295                  end
296    
297       in g (elements, entEnv, [])
298      end
299    
300  (*  (*
301  val toTyc  =  and signLty (sign, depth, compInfo) =
302    (fn x => fn y =>    let fun h (SIG {kind=SOME _, lambdaty=ref (SOME(lt, od)), ...}) = lt
303       (Stats.doPhase(Stats.makePhase "Compiler 043 2-toTyc") (toTyc x) y))               (* LT.lt_adj(lt, od, depth) *)
304            | h (sign as SIG{kind=SOME _, lambdaty as ref NONE, ...}) =
305  val toLty  =            (* Invariant: we assum that all Named signatures (kind=SOME _) are
306    (fn x => fn y =>             * defined at top-level, outside any functor definitions. (ZHONG)
307       (Stats.doPhase(Stats.makePhase "Compiler 043 3-toLty") (toLty x) y))             *)
308                 let val {rlzn=rlzn, tycpaths=tycpaths} =
309                       INS.instParam {sign=sign, entEnv=EE.empty, depth=depth,
310                                      rpath=InvPath.IPATH[], compInfo=compInfo,
311                                      region=SourceMap.nullRegion}
312                     val nd = DI.next depth
313                     val nlty = strMetaLty(sign, rlzn, nd, compInfo)
314    
315                     val ks = map tpsKnd tycpaths
316                     val lt = LT.ltc_poly(ks, nlty)
317                  in lambdaty := SOME (lt, depth); lt
318                 end
319            | h _ = bug "unexpected sign in signLty"
320       in h sign
321      end
322  *)  *)
323    and strMetaLty (sign, rlzn, depth, compInfo) =
324      let fun g (sign, rlzn as {lambdaty = ref (SOME (lt,od)), ...}) =
325                 LT.lt_adj(lt, od, depth)
326            | g (sign as SIG{elements, ...},
327                 rlzn as {entities, lambdaty, ...} : strEntity) =
328                   let val ltys = specLty(elements, entities, depth, compInfo)
329                       val lt = (* case ltys of [] => LT.ltc_int
330                                           | _ => *) LT.ltc_str(ltys)
331                    in lambdaty := SOME(lt, depth); lt
332                   end
333            | g _ = bug "unexpected sign and rlzn in strMetaLty"
334    
335       in g(sign, rlzn)
336      end
337    
338    and strRlznLty (sign, rlzn, depth, compInfo) =
339      let fun g (sign, rlzn as {lambdaty = ref (SOME (lt,od)), ...} : strEntity) =
340                 LT.lt_adj(lt, od, depth)
341    
342    (* Note: the code here is designed to improve the "toLty" translation;
343       by translating the signature instead of the structure, this can
344       potentially save time on strLty. But it can increase the cost of
345       other procedures. Thus we turn it off temporarily. (ZHONG)
346    
347            | g (sign as SIG{kind=SOME _, ...}, rlzn as {lambdaty, ...}) =
348                 let val sgt = signLty(sign, depth, compInfo)
349                     (* Invariant: we assum that all Named signatures
350                      * (kind=SOME _) are defined at top-level, outside any
351                      * functor definitions. (ZHONG)
352                      *)
353                     val argtycs = INS.getTycPaths{sign=sign, rlzn=rlzn,
354                             entEnv=EE.empty, compInfo=compInfo}
355                     val lt = LT.lt_inst(sgt, map (tpsTyc depth) argtycs)
356                  in lambdaty := SOME(lt, depth); lt
357                 end
358    *)
359            | g _ = strMetaLty(sign, rlzn, depth, compInfo)
360    
361       in g(sign, rlzn)
362      end
363    
364    and fctRlznLty (sign, rlzn, depth, compInfo) =
365      let fun g (sign, rlzn as {lambdaty = ref (SOME (lt, od)), ...}) =
366                 LT.lt_adj(lt, od, depth)
367            | g (sign as FSIG{paramsig, bodysig, ...},
368                 rlzn as {stamp, closure as CLOSURE{env,...}, lambdaty, ...}) =
369                   let val {rlzn=argRlzn, tycpaths=tycpaths} =
370                         INS.instParam {sign=paramsig, entEnv=env, depth=depth,
371                                        rpath=InvPath.IPATH[], compInfo=compInfo,
372                                        region=SourceMap.nullRegion}
373                       val nd = DI.next depth
374                       val paramLty = strMetaLty(paramsig, argRlzn, nd, compInfo)
375                       val ks = map tpsKnd tycpaths
376                       val bodyRlzn =
377                         EV.evalApp(rlzn, argRlzn, nd, EPC.initContext,
378                                    IP.empty, compInfo)
379                       val bodyLty = strRlznLty(bodysig, bodyRlzn, nd, compInfo)
380    
381                       val lt = LT.ltc_poly(ks, [LT.ltc_fct([paramLty],[bodyLty])])
382                    in lambdaty := SOME (lt, depth); lt
383                   end
384    
385            | g _ = bug "fctRlznLty"
386    
387       in g(sign, rlzn)
388      end
389    
390    and strLty (str, depth, compInfo) =
391      let fun g (STR{rlzn={lambdaty=ref (SOME (lt, od)), ...}, ...}) =
392                  LT.lt_adj(lt, od, depth)
393            | g (STR{sign, rlzn as {lambdaty as ref NONE, ...}, ...}) =
394                  let val lt = strRlznLty(sign, rlzn, depth, compInfo)
395                   in (lambdaty := SOME(lt, depth); lt)
396                  end
397            | g _ = bug "unexpected structure in strLty"
398       in g str
399      end
400    
401    and fctLty (fct, depth, compInfo) =
402      let fun g (FCT{rlzn={lambdaty=ref(SOME (lt,od)),...}, ...}) =
403                  LT.lt_adj(lt, od, depth)
404            | g (FCT{sign, rlzn as {lambdaty as ref NONE, ...}, ...}) =
405                  let val lt = fctRlznLty(sign, rlzn, depth, compInfo)
406                   in (lambdaty := SOME(lt,depth); lt)
407                  end
408            | g _ = bug "unexpected functor in fctLty"
409       in g fct
410      end
411    
412    (****************************************************************************
413     *           A HASH-CONSING VERSION OF THE ABOVE TRANSLATIONS               *
414     ****************************************************************************)
415    
416    structure MIDict = BinaryDict(struct type ord_key = ModuleId.modId
417                                         val cmpKey = ModuleId.cmp
418                                  end)
419    
420    fun genTT() =
421      let val _ = ()
422    (*
423          val m1 = ref (MIDict.mkDict())   (* modid (tycon) -> LT.tyc *)
424          val m2 = ref (MIDict.mkDict())   (* modid (str/fct) -> LT.lty *)
425    
426          fun tycTycLook (t as (GENtyc _ | DEFtyc _), d) =
427                let tid = MU.tycId t
428                 in (case MIDict.peek(!m1, tid)
429                      of SOME (t', od) => LT.tc_adj(t', od, d)
430                       | NONE =>
431                           let val x = tycTyc (t, d)
432                               val _ = (m1 := TcDict.insert(!m1, tid, (x, d)))
433                            in x
434                           end)
435                end
436            | tycTycLook x = tycTyc tycTycLook x
437    
438    (*
439          val toTyc = toTyc tycTycLook
440          val toLty = toTyc tycTycLook
441    *)
442          val coreDict = (toTyc, toLty)
443    
444          fun strLtyLook (s as STR _, d) =
445                let sid = MU.strId s
446                 in (case MIDict.peek(!m2, sid)
447                      of SOME (t', od) => LT.lt_adj(t', od, d)
448                       | NONE =>
449                           let val x = strLty (coreDict, strLtyLook,
450                                               fctLtyLook) (s, d)
451                               val _ = (m2 := TcDict.insert(!m2, sid, (x, d)))
452                            in x
453                           end)
454                end
455            | strLtyLook x = strLty (coreDict, strLtyLook, fctLtyLook)
456    
457          and fctLtyLook (f as FCT _, d) =
458                let fid = fctId f
459                 in (case MIDict.peek(!m2, fid)
460                      of SOME (t', od) => LT.lt_adj(t', od, d)
461                       | NONE =>
462                           let val x = fctLty (tycTycLook, strLtyLook,
463                                               fctLtyLook) (s, d)
464                               val _ = (m2 := TcDict.insert(!m2, fid, (x, d)))
465                            in x
466                           end)
467                end
468            | fctLtyLook x = fctLty (coreDict, strLtyLook, fctLtyLook)
469    *)
470    
471       in {tpsKnd=tpsKnd, tpsTyc=tpsTyc,
472           toTyc=toTyc, toLty=toLty, strLty=strLty, fctLty=fctLty}
473      end (* function genTT *)
474    
475  end (* toplevel local *)  end (* toplevel local *)
476  end (* structure TransTypes *)  end (* structure TransTypes *)

Legend:
Removed from v.44  
changed lines
  Added in v.45

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