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 733 - (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 216 cleanUp: unit -> unit,
10 :     addLty: (FLINT.lvar * FLINT.lty) -> unit}
11 : monnier 16 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 : monnier 216 (** these two functions are applicable to the types of primops and data
29 : monnier 16 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 216 fun recover (fdec, postRep) =
43 : blume 733 let val zz : lty IntHashTable.hash_table =
44 :     IntHashTable.mkTable(32, RecoverLty)
45 :     val get = IntHashTable.lookup zz
46 :     val addv = IntHashTable.insert zz
47 : monnier 216 fun addvs vts = app addv vts
48 :     fun getlty (VAR v) = get v
49 : monnier 197 | getlty (INT _ | WORD _) = LT.ltc_int
50 :     | getlty (INT32 _ | WORD32 _) = LT.ltc_int32
51 :     | getlty (REAL _) = LT.ltc_real
52 :     | getlty (STRING _) = LT.ltc_string
53 : monnier 16
54 : monnier 197 val lt_nvar_cvt = LT.lt_nvar_cvt_gen()
55 :    
56 : monnier 16 (* loop : depth -> lexp -> lty list *)
57 : monnier 216 fun loop e =
58 : monnier 197 let fun lpv u = getlty u
59 : monnier 16 fun lpvs vs = map lpv vs
60 :    
61 :     fun lpd (fk, f, vts, e) =
62 :     (addvs vts; addv (f, LT.ltc_fkfun(fk, map #2 vts, lpe e)))
63 :    
64 : monnier 184 and lpds (fds as ((fk as {isrec=SOME _, ...},_,_,_)::_)) =
65 : monnier 197 let fun h ((fk as {isrec=SOME (rts,_), ...},
66 : monnier 16 f, vts, _) : fundec) =
67 :     addv(f, LT.ltc_fkfun(fk, map #2 vts, rts))
68 :     | h _ = bug "unexpected case in lpds"
69 :     val _ = app h fds
70 :     in app lpd fds
71 :     end
72 :     | lpds [fd] = lpd fd
73 :     | lpds _ = bug "unexpected case 2 in lpds"
74 :    
75 :     and lpc (DATAcon((_,_,lt), ts, v), e) =
76 :     (addv (v, arglty(lt, ts)); lpe e)
77 :     | lpc (_, e) = lpe e
78 :    
79 :     and lpe (RET vs) = lpvs vs
80 :     | lpe (LET(vs, e1, e2)) =
81 :     (addvs (ListPair.zip(vs, lpe e1)); lpe e2)
82 :     | lpe (FIX(fdecs, e)) = (lpds fdecs; lpe e)
83 :     | lpe (APP(u, vs)) = #2(LT.ltd_fkfun (lpv u))
84 : monnier 220 | lpe (TFN((tfk, v, tvks, e1), e2)) =
85 : monnier 216 (addv(v, LT.lt_nvpoly(tvks, loop e1));
86 : monnier 16 lpe e2)
87 :     | lpe (TAPP(v, ts)) = LT.lt_inst (lpv v, ts)
88 :     | lpe (RECORD(rk,vs,v,e)) =
89 :     (addv (v, LT.ltc_rkind(rk, lpvs vs)); lpe e)
90 :     | lpe (SELECT(u,i,v,e)) =
91 :     (addv (v, LT.ltd_rkind(lpv u, i)); lpe e)
92 :     | lpe (CON((_,_,lt),ts,_,v,e)) =
93 :     (addv (v, reslty(lt, ts)); lpe e)
94 :     | lpe (SWITCH(_, _, ces, e)) =
95 :     let val lts = map lpc ces
96 :     in case e of NONE => hd lts
97 :     | SOME e => lpe e
98 :     end
99 :     | lpe (RAISE (_, lts)) = lts
100 :     | lpe (HANDLE(e, _)) = lpe e
101 :     | lpe (BRANCH(p, _, e1, e2)) =
102 :     let val _ = lpe e1
103 :     in lpe e2
104 :     end
105 : monnier 69 | lpe (PRIMOP((_,PrimOp.WCAST, lt, []), _, v, e)) =
106 :     if postRep then
107 :     (case LT.ltd_fct lt
108 :     of ([_],[r]) => (addv(v, r); lpe e)
109 :     | _ => bug "unexpected case for WCAST")
110 :     else bug "unexpected primop WCAST in recover"
111 : monnier 16 | lpe (PRIMOP((_,_,lt,ts), _, v, e)) =
112 :     (addv (v, reslty (lt, ts)); lpe e)
113 :    
114 :     in lpe e
115 :     end (* function transform *)
116 :    
117 :     val (fkind, f, vts, e) = fdec
118 : monnier 216 val _ = addvs vts
119 : monnier 16 val atys = map #2 vts
120 : monnier 216 val rtys = loop e
121 :     val _ = addv (f, LT.ltc_fkfun(fkind, atys, rtys))
122 : blume 733 in {getLty=getlty, cleanUp=fn () => IntHashTable.clear zz, addLty=addv}
123 : monnier 16 end (* function recover *)
124 :    
125 :     end (* local *)
126 : monnier 69 end (* structure Recover *)

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