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/trunk/src/compiler/FLINT/opt/recover.sml
ViewVC logotype

Diff of /sml/trunk/src/compiler/FLINT/opt/recover.sml

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

revision 196, Fri Nov 20 18:16:19 1998 UTC revision 197, Sun Nov 22 01:25:23 1998 UTC
# Line 2  Line 2 
2  (* recover.sml *)  (* recover.sml *)
3    
4  (* recover the type information of a closed FLINT program *)  (* recover the type information of a closed FLINT program *)
   
5  signature RECOVER =  signature RECOVER =
6  sig  sig
7    val recover : (FLINT.prog * bool) ->    val recover : (FLINT.prog * bool) ->
8                    {getLty: DebIndex.depth -> FLINT.value -> FLINT.lty,                    {getLty: FLINT.value -> FLINT.lty,
9                     cleanUp: unit -> unit}                     cleanUp: unit -> unit}
10  end (* signature SPECIALIZE *)  end (* signature SPECIALIZE *)
11    
# Line 45  Line 44 
44        val get = Intmap.map zz        val get = Intmap.map zz
45        fun addvar d (x, t) = add(x, (t, d))        fun addvar d (x, t) = add(x, (t, d))
46        fun addvars d vts = app (addvar d) vts        fun addvars d vts = app (addvar d) vts
47        fun getlty d (VAR v) =        fun getlty (VAR v) =
48              let val (t, od) = get v              let val (t, od) = get v
49               in LT.lt_adj(t, od, d)               in t (* LT.lt_adj(t, od, d) *)
50                end
51            | getlty (INT _ | WORD _) = LT.ltc_int
52            | getlty (INT32 _ | WORD32 _) = LT.ltc_int32
53            | getlty (REAL _) = LT.ltc_real
54            | getlty (STRING _) = LT.ltc_string
55    
56          val lt_nvar_cvt = LT.lt_nvar_cvt_gen()
57    
58          fun lt_nvpoly(tvks, lt) =
59              let
60                  fun frob ((tv,k)::tvks, n, ks, tvoffs) =
61                      frob (tvks, n+1, k::ks, (tv,n)::tvoffs)
62                    | frob ([], _, ks, tvoffs) =
63                      (rev ks, rev tvoffs)
64    
65                  val (ks, tvoffs) = frob (tvks, 0, [], [])
66                  fun cmp ((tvar1,_), (tvar2,_)) = tvar1 > tvar2
67                  val tvoffs = Sort.sort cmp tvoffs
68    
69                                            (* temporarily gen() *)
70                  val ltSubst = LT.lt_nvar_cvt_gen() tvoffs (DI.next DI.top)
71              in LT.ltc_poly(ks, map ltSubst lt)
72              end              end
         | getlty d (INT _ | WORD _) = LT.ltc_int  
         | getlty d (INT32 _ | WORD32 _) = LT.ltc_int32  
         | getlty d (REAL _) = LT.ltc_real  
         | getlty d (STRING _) = LT.ltc_string  
73    
74        (* loop : depth -> lexp -> lty list *)        (* loop : depth -> lexp -> lty list *)
75        fun loop d e =        fun loop d e =
76          let fun lpv u = getlty d u          let fun lpv u = getlty u
77              fun lpvs vs = map lpv vs              fun lpvs vs = map lpv vs
78              val addv = addvar d              val addv = addvar d
79              val addvs = addvars d              val addvs = addvars d
# Line 85  Line 102 
102                | lpe (FIX(fdecs, e)) = (lpds fdecs; lpe e)                | lpe (FIX(fdecs, e)) = (lpds fdecs; lpe e)
103                | lpe (APP(u, vs)) = #2(LT.ltd_fkfun (lpv u))                | lpe (APP(u, vs)) = #2(LT.ltd_fkfun (lpv u))
104                | lpe (TFN((v, tvks, e1), e2)) =                | lpe (TFN((v, tvks, e1), e2)) =
105                    (addv(v, LT.ltc_poly(map #2 tvks, loop (DI.next d) e1));                    (addv(v, lt_nvpoly(tvks, loop (DI.next d) e1));
106                     lpe e2)                     lpe e2)
107                | lpe (TAPP(v, ts)) = LT.lt_inst (lpv v, ts)                | lpe (TAPP(v, ts)) = LT.lt_inst (lpv v, ts)
108                | lpe (RECORD(rk,vs,v,e)) =                | lpe (RECORD(rk,vs,v,e)) =

Legend:
Removed from v.196  
changed lines
  Added in v.197

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