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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 203 - (view) (download)

1 : monnier 16 (* COPYRIGHT (c) 1998 YALE FLINT PROJECT *)
2 :     (* recover.sml *)
3 :    
4 :     (* recover the type information of a closed FLINT program *)
5 :     signature RECOVER =
6 :     sig
7 : monnier 69 val recover : (FLINT.prog * bool) ->
8 : monnier 197 {getLty: FLINT.value -> FLINT.lty,
9 : monnier 16 cleanUp: unit -> unit}
10 :     end (* signature SPECIALIZE *)
11 :    
12 :     structure Recover : RECOVER =
13 :     struct
14 :    
15 :     local structure LT = LtyExtern
16 :     structure DI = DebIndex
17 :     open FLINT
18 :     in
19 :    
20 :     fun bug s = ErrorMsg.impossible ("Recover: "^s)
21 :    
22 :     fun ltInst (lt, ts) =
23 :     (case LT.lt_inst(lt, ts)
24 :     of [x] => x
25 :     | _ => bug "unexpected case in ltInst")
26 :    
27 :     (** there two functions are applicable to the types of primops and data
28 :     constructors only (ZHONG) *)
29 :     fun arglty (lt, ts) =
30 :     let val (_, atys, _) = LT.ltd_arrow(ltInst(lt, ts))
31 :     in case atys of [x] => x
32 :     | _ => bug "unexpected case in arglty"
33 :     end
34 :     fun reslty (lt, ts) =
35 :     let val (_, _, rtys) = LT.ltd_arrow(ltInst(lt, ts))
36 :     in case rtys of [x] => x
37 :     | _ => bug "unexpected case in reslty"
38 :     end
39 :    
40 :     exception RecoverLty
41 : monnier 69 fun recover (fdec, postRep) =
42 : monnier 16 let val zz : (lty * DI.depth) Intmap.intmap = Intmap.new(32, RecoverLty)
43 :     val add = Intmap.add zz
44 :     val get = Intmap.map zz
45 :     fun addvar d (x, t) = add(x, (t, d))
46 :     fun addvars d vts = app (addvar d) vts
47 : monnier 197 fun getlty (VAR v) =
48 : monnier 16 let val (t, od) = get v
49 : monnier 197 in t (* LT.lt_adj(t, od, d) *)
50 : monnier 16 end
51 : monnier 197 | 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 : monnier 16
56 : monnier 197 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
73 :    
74 : monnier 16 (* loop : depth -> lexp -> lty list *)
75 :     fun loop d e =
76 : monnier 197 let fun lpv u = getlty u
77 : monnier 16 fun lpvs vs = map lpv vs
78 :     val addv = addvar d
79 :     val addvs = addvars d
80 :    
81 :     fun lpd (fk, f, vts, e) =
82 :     (addvs vts; addv (f, LT.ltc_fkfun(fk, map #2 vts, lpe e)))
83 :    
84 : monnier 184 and lpds (fds as ((fk as {isrec=SOME _, ...},_,_,_)::_)) =
85 : monnier 197 let fun h ((fk as {isrec=SOME (rts,_), ...},
86 : monnier 16 f, vts, _) : fundec) =
87 :     addv(f, LT.ltc_fkfun(fk, map #2 vts, rts))
88 :     | h _ = bug "unexpected case in lpds"
89 :     val _ = app h fds
90 :     in app lpd fds
91 :     end
92 :     | lpds [fd] = lpd fd
93 :     | lpds _ = bug "unexpected case 2 in lpds"
94 :    
95 :     and lpc (DATAcon((_,_,lt), ts, v), e) =
96 :     (addv (v, arglty(lt, ts)); lpe e)
97 :     | lpc (_, e) = lpe e
98 :    
99 :     and lpe (RET vs) = lpvs vs
100 :     | lpe (LET(vs, e1, e2)) =
101 :     (addvs (ListPair.zip(vs, lpe e1)); lpe e2)
102 :     | lpe (FIX(fdecs, e)) = (lpds fdecs; lpe e)
103 :     | lpe (APP(u, vs)) = #2(LT.ltd_fkfun (lpv u))
104 :     | lpe (TFN((v, tvks, e1), e2)) =
105 : monnier 197 (addv(v, lt_nvpoly(tvks, loop (DI.next d) e1));
106 : monnier 16 lpe e2)
107 :     | lpe (TAPP(v, ts)) = LT.lt_inst (lpv v, ts)
108 :     | lpe (RECORD(rk,vs,v,e)) =
109 :     (addv (v, LT.ltc_rkind(rk, lpvs vs)); lpe e)
110 :     | lpe (SELECT(u,i,v,e)) =
111 :     (addv (v, LT.ltd_rkind(lpv u, i)); lpe e)
112 :     | lpe (CON((_,_,lt),ts,_,v,e)) =
113 :     (addv (v, reslty(lt, ts)); lpe e)
114 :     | lpe (SWITCH(_, _, ces, e)) =
115 :     let val lts = map lpc ces
116 :     in case e of NONE => hd lts
117 :     | SOME e => lpe e
118 :     end
119 :     | lpe (RAISE (_, lts)) = lts
120 :     | lpe (HANDLE(e, _)) = lpe e
121 :     | lpe (BRANCH(p, _, e1, e2)) =
122 :     let val _ = lpe e1
123 :     in lpe e2
124 :     end
125 : monnier 69 | lpe (PRIMOP((_,PrimOp.WCAST, lt, []), _, v, e)) =
126 :     if postRep then
127 :     (case LT.ltd_fct lt
128 :     of ([_],[r]) => (addv(v, r); lpe e)
129 :     | _ => bug "unexpected case for WCAST")
130 :     else bug "unexpected primop WCAST in recover"
131 : monnier 16 | lpe (PRIMOP((_,_,lt,ts), _, v, e)) =
132 :     (addv (v, reslty (lt, ts)); lpe e)
133 :    
134 :     in lpe e
135 :     end (* function transform *)
136 :    
137 :     val (fkind, f, vts, e) = fdec
138 :     val d = DI.top
139 :     val _ = addvars d vts
140 :     val atys = map #2 vts
141 :     val rtys = loop d e
142 :     val _ = addvar d (f, LT.ltc_fkfun(fkind, atys, rtys))
143 :     in {getLty=getlty, cleanUp=fn () => Intmap.clear zz}
144 :     end (* function recover *)
145 :    
146 : monnier 203 val recover = Stats.doPhase (Stats.makePhase "Compiler 050 recover") recover
147 :    
148 : monnier 16 end (* local *)
149 : monnier 69 end (* structure Recover *)

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