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 16 - (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 :     val recover : FLINT.prog ->
9 :     {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 :     fun recover fdec =
43 :     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 :     and lpds (fds as ((fk as FK_FUN{isrec=SOME _, ...},_,_,_)::_)) =
68 :     let fun h ((fk as FK_FUN{isrec=SOME rts, ...},
69 :     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 :     | lpe (PRIMOP((_,_,lt,ts), _, v, e)) =
109 :     (addv (v, reslty (lt, ts)); lpe e)
110 :    
111 :     in lpe e
112 :     end (* function transform *)
113 :    
114 :     val (fkind, f, vts, e) = fdec
115 :     val d = DI.top
116 :     val _ = addvars d vts
117 :     val atys = map #2 vts
118 :     val rtys = loop d e
119 :     val _ = addvar d (f, LT.ltc_fkfun(fkind, atys, rtys))
120 :     in {getLty=getlty, cleanUp=fn () => Intmap.clear zz}
121 :     end (* function recover *)
122 :    
123 :     end (* local *)
124 :     end (* structure Recover *)

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