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

Parent Directory | Revision Log

---

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

---

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