Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Diff of /sml/branches/primop-branch-gkuan/compiler/FLINT/trans/transtypes.sml
ViewVC logotype

Diff of /sml/branches/primop-branch-gkuan/compiler/FLINT/trans/transtypes.sml

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

revision 2947, Sat Feb 16 00:17:56 2008 UTC revision 2948, Sat Feb 16 18:11:07 2008 UTC
# Line 3  Line 3 
3    
4  signature TRANSTYPES =  signature TRANSTYPES =
5  sig  sig
6    val genTT  : unit -> {tpsKnd : AbsynTP.tycpath -> PLambdaType.tkind,    val genTT  : unit -> {tpsKnd : TypesTP.tycpath -> PLambdaType.tkind,
7                          tpsTyc : DebIndex.depth -> AbsynTP.tycpath                          tpsTyc : DebIndex.depth -> TypesTP.tycpath
8                                   -> PLambdaType.tyc,                                   -> PLambdaType.tyc,
9                          toTyc  : DebIndex.depth -> Types.ty -> PLambdaType.tyc,                          toTyc  : DebIndex.depth -> Types.ty -> PLambdaType.tyc,
10                          toLty  : DebIndex.depth -> Types.ty -> PLambdaType.lty,                          toLty  : DebIndex.depth -> Types.ty -> PLambdaType.lty,
# Line 31  Line 31 
31        structure SE = StaticEnv        structure SE = StaticEnv
32        structure TU = TypesUtil        structure TU = TypesUtil
33        structure PP = PrettyPrintNew        structure PP = PrettyPrintNew
34          structure TP = TypesTP
35    
36        open AbsynTP Types Modules ElabDebug        open AbsynTP Types Modules ElabDebug
37  in  in
38    
# Line 87  Line 89 
89        end        end
90  end (* end of recTyc and freeTyc hack *)  end (* end of recTyc and freeTyc hack *)
91    
92  fun tpsKnd (TP_VAR{kind,...}) = kind  fun tpsKnd (TP.TP_VAR{kind,...}) = kind
93          (* let fun kindToTKind PK_MONO = LT.tkc_int 0          (* let fun kindToTKind PK_MONO = LT.tkc_int 0
94                | kindToTKind (PK_SEQ x) = LT.tkc_seq(map kindToTKind x)                | kindToTKind (PK_SEQ x) = LT.tkc_seq(map kindToTKind x)
95                | kindToTKind (PK_FUN (paramks,bodyknd)) =                | kindToTKind (PK_FUN (paramks,bodyknd)) =
# Line 100  Line 102 
102    let    let
103    
104  fun tpsTyc d tp =  fun tpsTyc d tp =
105    let fun h (TP_VAR {tdepth, num, ...}, cur) =    let fun h (TP.TP_VAR {tdepth, num, ...}, cur) =
106                LT.tcc_var(DI.calc(cur, tdepth), num)                LT.tcc_var(DI.calc(cur, tdepth), num)
107          | h (TP_TYC tc, cur) = tycTyc(tc, cur)          | h (TP.TP_TYC tc, cur) = tycTyc(TP.tycStripTP tc, cur)
108          | h (TP_SEL (tp, i), cur) = LT.tcc_proj(h(tp, cur), i)          | h (TP.TP_SEL (tp, i), cur) = LT.tcc_proj(h(tp, cur), i)
109          | h (TP_APP (tp, ps), cur) =          | h (TP.TP_APP (tp, ps), cur) =
110                LT.tcc_app(h(tp, cur), map (fn x => h(x, cur)) ps)                LT.tcc_app(h(tp, cur), map (fn x => h(x, cur)) ps)
111          | h (TP_FCT (ps, ts), cur) =          | h (TP.TP_FCT (ps, ts), cur) =
112                let val ks = map tpsKnd ps                let val ks = map tpsKnd ps
113                    val cur' = DI.next cur                    val cur' = DI.next cur
114                    val ts' = map (fn x => h(x, cur')) ts                    val ts' = map (fn x => h(x, cur')) ts
# Line 121  Line 123 
123    Stats.doPhase(Stats.makePhase "Compiler 043 1-tycTyc") tycTyc0 x    Stats.doPhase(Stats.makePhase "Compiler 043 1-tycTyc") tycTyc0 x
124  *)  *)
125    
126  and tycTyc(tc, d) =  and tycTyc(tc : Types.tycon, d) =
127    let fun dtsTyc nd ({dcons: dconDesc list, arity=i, ...} : dtmember) =    let fun dtsTyc nd ({dcons: dconDesc list, arity=i, ...} : dtmember) =
128              let val nnd = if i=0 then nd else DI.next nd              let val nnd = if i=0 then nd else DI.next nd
129                  fun f ({domain=NONE, rep, name}, r) = (LT.tcc_unit)::r                  fun f ({domain=NONE, rep, name}, r) = (LT.tcc_unit)::r
130                    | f ({domain=SOME t, rep, name}, r) = (toTyc nnd t)::r                    | f ({domain=SOME t, rep, name}, r) =
131                        (toTyc nnd t)::r
132    
133                  val _ = enterRecTy i                  val _ = enterRecTy i
134                  val core = LT.tcc_sum(foldr f [] dcons)                  val core = LT.tcc_sum(foldr f [] dcons)
# Line 187  Line 190 
190          | h (DATATYPE {index, family, freetycs, stamps, root}, _) =          | h (DATATYPE {index, family, freetycs, stamps, root}, _) =
191                let val tc = dtsFam (freetycs, family)                let val tc = dtsFam (freetycs, family)
192                    val n = Vector.length stamps                    val n = Vector.length stamps
193                    val names = Vector.map (fn ({tycname,...}: dtmember) => Symbol.name tycname)                    val names = Vector.map (fn ({tycname,...}: dtmember) =>
194                                                 Symbol.name tycname)
195                                           (#members family)                                           (#members family)
196                    (* invariant: n should be the number of family members *)                    (* invariant: n should be the number of family members *)
197                 in LT.tcc_fix((n, names, tc, (map g freetycs)), index)                 in LT.tcc_fix((n, names, tc, (map g freetycs)), index)
# Line 207  Line 211 
211                 in LT.tcc_fn(ks, LT.tcc_abs b)                 in LT.tcc_fn(ks, LT.tcc_abs b)
212                end                end
213                <<<*)                <<<*)
214  (*         | h (FLEXTYC tp, _) = tpsTyc d tp *)          (* | h (TP.FLEXTYC tp, _) = tpsTyc d tp *)
215          | h (FORMAL, _) = bug "unexpected FORMAL kind in tycTyc-h"          | h (FORMAL, n) = LT.tcc_fn([LT.tkc_int n], LT.tcc_seq [])
216             (* bug "unexpected FORMAL kind in tycTyc-h" *)
217              (* raise FND_FORMAL *)
218          | h (TEMP, _) = bug "unexpected TEMP kind in tycTyc-h"          | h (TEMP, _) = bug "unexpected TEMP kind in tycTyc-h"
219    
220        and g (tycon as GENtyc { arity, kind, ... }) =        and g (tycon as GENtyc { arity, kind, ... }) =
# Line 230  Line 236 
236                 if arity > 0 then LT.tcc_fn(LT.tkc_arg arity, LT.tcc_void)                 if arity > 0 then LT.tcc_fn(LT.tkc_arg arity, LT.tcc_void)
237                 else LT.tcc_void)                 else LT.tcc_void)
238          | g (ERRORtyc) = bug "unexpected tycon in tycTyc-g"          | g (ERRORtyc) = bug "unexpected tycon in tycTyc-g"
239       in g tc
    in (g tc)  
240    end    end
241    
242  and tfTyc (TYFUN{arity=0, body}, d) = toTyc d body  and tfTyc (TYFUN{arity=0, body}, d) = toTyc d body
# Line 264  Line 269 
269          | h (OPEN _) = LT.tcc_void          | h (OPEN _) = LT.tcc_void
270          | h _ = bug "toTyc:h" (* LITERAL and SCHEME should not occur *)          | h _ = bug "toTyc:h" (* LITERAL and SCHEME should not occur *)
271    
272        and g (VARty tv) = (* h(!tv) *) lookTv tv        and g (VARty tv) = lookTv tv
273          | g (CONty(RECORDtyc _, [])) = LT.tcc_unit          | g (CONty(RECORDtyc _, [])) = LT.tcc_unit
274          | g (CONty(RECORDtyc _, ts)) = LT.tcc_tuple (map g ts)          | g (CONty(RECORDtyc _, ts)) = LT.tcc_tuple (map g ts)
275          | g (CONty(tyc, [])) = tycTyc(tyc, d)          | g (CONty(tyc, [])) = tycTyc(tyc, d)
276          | g (CONty(DEFtyc{tyfun,...}, args)) = g(TU.applyTyfun(tyfun,args))          | g (CONty(DEFtyc{tyfun,...}, args)) =
277              g(TU.applyTyfun(tyfun, args))
278          | g (CONty (tc as GENtyc { kind, ... }, ts)) =          | g (CONty (tc as GENtyc { kind, ... }, ts)) =
279            (case (kind, ts) of            (case (kind, ts) of
280                 (ABSTRACT _, ts) =>                 (ABSTRACT _, ts) =>
281                 LT.tcc_app(tycTyc(tc, d), map g ts)                 LT.tcc_app(tycTyc(tc, d), map g ts)
282               | (_, [t1, t2]) =>               | (_, [t1, t2]) =>
283                 if TU.eqTycon(tc, BT.arrowTycon) then LT.tcc_parrow(g t1, g t2)                 if TU.eqTycon(tc, BT.arrowTycon)
284                   then LT.tcc_parrow(g t1, g t2)
285                 else LT.tcc_app(tycTyc(tc, d), [g t1, g t2])                 else LT.tcc_app(tycTyc(tc, d), [g t1, g t2])
286               | _ => LT.tcc_app (tycTyc (tc, d), map g ts))               | _ => LT.tcc_app (tycTyc (tc, d), map g ts))
287          | g (CONty(tyc, ts)) = LT.tcc_app(tycTyc(tyc, d), map g ts)          | g (CONty(tyc, ts)) = LT.tcc_app(tycTyc(tyc, d), map g ts)
# Line 285  Line 292 
292          | g (POLYty _) = bug "unexpected poly-type in toTyc"          | g (POLYty _) = bug "unexpected poly-type in toTyc"
293          | g (UNDEFty) = bug "unexpected undef-type in toTyc"          | g (UNDEFty) = bug "unexpected undef-type in toTyc"
294          | g (WILDCARDty) = bug "unexpected wildcard-type in toTyc"          | g (WILDCARDty) = bug "unexpected wildcard-type in toTyc"
295    
296     in g t     in g t
297    end    end (* toTyc *)
298    
299  and toLty d (POLYty {tyfun=TYFUN{arity=0, body}, ...}) = toLty d body  and toLty d (POLYty {tyfun=TYFUN{arity=0, body}, ...}) =
300        toLty d body
301    | toLty d (POLYty {tyfun=TYFUN{arity, body},...}) =    | toLty d (POLYty {tyfun=TYFUN{arity, body},...}) =
302        let val ks = LT.tkc_arg arity        let val ks = LT.tkc_arg arity
303         in LT.ltc_poly(ks, [toLty (DI.next d) body])         in LT.ltc_poly(ks, [toLty (DI.next d) body])
304        end        end
   
305    | toLty d x = LT.ltc_tyc (toTyc d x)    | toLty d x = LT.ltc_tyc (toTyc d x)
306    
307  (****************************************************************************  (****************************************************************************
# Line 303  Line 311 
311  fun specLty (elements, entEnv, depth, compInfo) =  fun specLty (elements, entEnv, depth, compInfo) =
312    let fun g ([], entEnv, ltys) = rev ltys    let fun g ([], entEnv, ltys) = rev ltys
313          | g ((sym, (TYCspec _ ))::rest, entEnv, ltys) =          | g ((sym, (TYCspec _ ))::rest, entEnv, ltys) =
314                g(rest, entEnv, ltys)                (print ">>specLty[TYCspec]\n"; g(rest, entEnv, ltys))
315          | g ((sym, STRspec {sign, entVar, ...})::rest, entEnv, ltys) =          | g ((sym, STRspec {sign, entVar, ...})::rest, entEnv, ltys) =
316                let val rlzn = EE.lookStrEnt(entEnv,entVar)                let val rlzn = EE.lookStrEnt(entEnv,entVar)
317                      val _ = print ">>specLty[STRspec]\n"
318                    val lt = strRlznLty(sign, rlzn, depth, compInfo)                    val lt = strRlznLty(sign, rlzn, depth, compInfo)
319                 in g(rest, entEnv, lt::ltys)                 in g(rest, entEnv, lt::ltys)
320                end                end
321          | g ((sym, FCTspec {sign, entVar, ...})::rest, entEnv, ltys) =          | g ((sym, FCTspec {sign, entVar, ...})::rest, entEnv, ltys) =
322                let val rlzn = EE.lookFctEnt(entEnv,entVar)                let val rlzn = EE.lookFctEnt(entEnv,entVar)
323                      val _ = print ">>specLty[FCTspec]\n"
324                    val lt = fctRlznLty(sign, rlzn, depth, compInfo)                    val lt = fctRlznLty(sign, rlzn, depth, compInfo)
325                 in g(rest, entEnv, lt::ltys)                 in g(rest, entEnv, lt::ltys)
326                end                end
327          | g ((sym, spec)::rest, entEnv, ltys) =          | g ((sym, spec)::rest, entEnv, ltys) =
328                let val _ = debugmsg ">>specLtyElt"                let val _ = debugmsg ">>specLtyElt"
329                      (* TODO translate entEnv results here? *)
330                    fun transty ty =                    fun transty ty =
331                      ((MU.transType entEnv ty)                      ((MU.transType entEnv ty)
332                        handle EE.Unbound =>                        handle EE.Unbound =>
# Line 328  Line 339 
339                            debugmsg ("$specLty: should have printed entEnv");                            debugmsg ("$specLty: should have printed entEnv");
340                            raise EE.Unbound))                            raise EE.Unbound))
341    
342                    fun mapty t = toLty depth (transty t)                    fun mapty t = toLty depth (transty t handle _ => (bug "specLty[mapty,transty]")) handle _ => bug "specLty[mapty]"
343    
344                 in case spec                 in case spec
345                     of VALspec{spec=typ,...} =>                     of VALspec{spec=typ,...} =>
346                          g(rest, entEnv, (mapty typ)::ltys)                          (print ">>specLty[VALspec]\n";
347                             g(rest, entEnv, (mapty typ)::ltys))
348                      | CONspec{spec=DATACON{rep=DA.EXN _,                      | CONspec{spec=DATACON{rep=DA.EXN _,
349                                             typ, ...}, ...} =>                                             typ, ...}, ...} =>
350                          let val argt =                          let val _ = print ">>specLty[CONspec]\n"
351                                val argt =
352                                if BT.isArrowType typ then                                if BT.isArrowType typ then
353                                     #1(LT.ltd_parrow (mapty typ))                                     #1(LT.ltd_parrow (mapty typ))
354                                else LT.ltc_unit                                else LT.ltc_unit
355                           in g(rest, entEnv, (LT.ltc_etag argt)::ltys)                           in g(rest, entEnv, (LT.ltc_etag argt)::ltys)
356                          end                          end
357                      | CONspec{spec=DATACON _, ...} =>                      | CONspec{spec=DATACON _, ...} =>
358                          g(rest, entEnv, ltys)                          (print ">>specLty[CONspec]\n"; g(rest, entEnv, ltys))
359                      | _ => bug "unexpected spec in specLty"                      | _ => bug "unexpected spec in specLty"
360                end                end
361    
# Line 372  Line 385 
385     in h sign     in h sign
386    end    end
387  *)  *)
388    (* sign is paramsig
389       rlzn is argRlzn
390     *)
391  and strMetaLty (sign, rlzn as { entities, ... }: strEntity, depth, compInfo) =  and strMetaLty (sign, rlzn as { entities, ... }: strEntity, depth, compInfo) =
392      case (sign, ModulePropLists.strEntityLty rlzn) of      case (sign, ModulePropLists.strEntityLty rlzn) of
393          (_, SOME (lt, od)) => LT.lt_adj(lt, od, depth)          (_, SOME (lt, od)) => LT.lt_adj(lt, od, depth)
394        | (SIG { elements, ... }, NONE) =>        | (SIG { elements, ... }, NONE) =>
395          let val ltys = specLty (elements, entities, depth, compInfo)          let val _ = print ">>specLty\n"
396                val ltys = specLty (elements, entities, depth, compInfo)
397                val _ = print "<<specLty\n"
398              val lt = (* case ltys of [] => LT.ltc_int              val lt = (* case ltys of [] => LT.ltc_int
399                                     | _ => *) LT.ltc_str(ltys)                                     | _ => *) LT.ltc_str(ltys)
400          in          in
# Line 406  Line 424 
424                in lambdaty := SOME(lt, depth); lt                in lambdaty := SOME(lt, depth); lt
425               end               end
426  *)  *)
427        | _ => strMetaLty(sign, rlzn, depth, compInfo)        | _ => (print ">>strRlznLty[strEntityLty NONE]\n";
428                  strMetaLty(sign, rlzn, depth, compInfo))
429    
430  and fctRlznLty (sign, rlzn, depth, compInfo) =  and fctRlznLty (sign, rlzn, depth, compInfo) =
431      case (sign, ModulePropLists.fctEntityLty rlzn, rlzn) of      case (sign, ModulePropLists.fctEntityLty rlzn, rlzn) of
432          (sign, SOME (lt, od), _) => LT.lt_adj(lt, od, depth)          (sign, SOME (lt, od), _) => LT.lt_adj(lt, od, depth)
433        | (fs as FSIG{paramsig, bodysig, ...}, _,        | (fs as FSIG{paramsig, bodysig, ...}, _,
434           {closure as CLOSURE{env,...}, paramEnts, ...}) =>           {closure as CLOSURE{env,...}, paramEnts, ...}) =>
435          let val argRlzn =          let val _ = print ">>instParam\n"
436                val argRlzn =
437                  INS.instParam {sign=paramsig, entEnv=env, tdepth=depth,                  INS.instParam {sign=paramsig, entEnv=env, tdepth=depth,
438                                 rpath=InvPath.IPATH[], compInfo=compInfo,                                 rpath=InvPath.IPATH[], compInfo=compInfo,
439                                 region=SourceMap.nullRegion}                                 region=SourceMap.nullRegion}
440              val nd = DI.next depth              val nd = DI.next depth
441                val _ = print ">>strMetaLty\n"
442              val paramLty = strMetaLty(paramsig, argRlzn, nd, compInfo)              val paramLty = strMetaLty(paramsig, argRlzn, nd, compInfo)
443              (* val ks = map tpsKnd tycpaths *)              (* val ks = map tpsKnd tycpaths *)
444              val ks = map tpsKnd (RepTycProps.getTk(fs, paramEnts, #entities argRlzn, []))              val _ = print ">>tpsKnd"
445                val ks = map tpsKnd (RepTycProps.getTk(fs, paramEnts,
446                                                       #entities argRlzn, []))
447    
448                val _ = print ">>evalApp\n"
449              val bodyRlzn =              val bodyRlzn =
450                  EV.evalApp(rlzn, argRlzn, nd, EPC.initContext,                  EV.evalApp(rlzn, argRlzn, nd, EPC.initContext,
451                             IP.empty, compInfo)                             IP.empty, compInfo)
452                val _ = print ">>strRlznLty\n"
453              val bodyLty = strRlznLty(bodysig, bodyRlzn, nd, compInfo)              val bodyLty = strRlznLty(bodysig, bodyRlzn, nd, compInfo)
454    
455              val lt = LT.ltc_poly(ks, [LT.ltc_fct([paramLty],[bodyLty])])              val lt = LT.ltc_poly(ks, [LT.ltc_fct([paramLty],[bodyLty])])

Legend:
Removed from v.2947  
changed lines
  Added in v.2948

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