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/kernel/ltydict.sml
ViewVC logotype

Annotation of /sml/trunk/src/compiler/FLINT/kernel/ltydict.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 41 - (view) (download)

1 : monnier 41 (* Copyright (c) 1997 YALE FLINT PROJECT *)
2 :     (* ltydict.sml *)
3 :    
4 :     signature LTYDICT = sig
5 :     type tyc = LtyKernel.tyc
6 :     type lty = LtyKernel.lty
7 :     val tmemo_gen : {tcf: (tyc -> 'a) -> (tyc -> 'a),
8 :     ltf: ((tyc -> 'a) * (lty -> 'b)) -> (lty -> 'b)}
9 :     -> {tc_map: tyc -> 'a, lt_map: lty -> 'b}
10 :    
11 :     val wmemo_gen : {tc_wmap : ((tyc -> 'a) * (tyc -> 'a)) -> (tyc -> 'a),
12 :     tc_umap : ((tyc -> 'a) * (tyc -> 'a)) -> (tyc -> 'a),
13 :     lt_umap : ((tyc -> 'a) * (lty -> 'b)) -> (lty -> 'b)}
14 :     -> {tc_wmap : tyc -> 'a,
15 :     tc_umap : tyc -> 'a,
16 :     lt_umap : lty -> 'b,
17 :     cleanup : unit -> unit}
18 :    
19 :     end (* signature LTYDICT *)
20 :    
21 :     structure LtyDict : LTYDICT =
22 :     struct
23 :    
24 :     local structure LT = LtyBasic
25 :     open LtyKernel
26 :     in
27 :    
28 :     fun bug s = ErrorMsg.impossible ("LtyDict: " ^ s)
29 :     val say = Control.Print.say
30 :    
31 :     structure TcDict = BinaryDict(struct type ord_key = tyc
32 :     val cmpKey = tc_cmp
33 :     end)
34 :    
35 :     structure LtDict = BinaryDict(struct type ord_key = lty
36 :     val cmpKey = lt_cmp
37 :     end)
38 :    
39 :     type tyc = tyc
40 :     type lty = lty
41 :    
42 :     fun tmemo_gen {tcf, ltf} =
43 :     let val m1 = ref (TcDict.mkDict())
44 :     val m2 = ref (LtDict.mkDict())
45 :    
46 :     fun tc_look t =
47 :     (case TcDict.peek(!m1, t)
48 :     of SOME t' => t'
49 :     | NONE =>
50 :     let val x = (tcf tc_look) t
51 :     val _ = (m1 := TcDict.insert(!m1, t, x))
52 :     in x
53 :     end)
54 :    
55 :     and lt_look t =
56 :     (case LtDict.peek(!m2, t)
57 :     of SOME t' => t'
58 :     | NONE =>
59 :     let val x = ltf (tc_look, lt_look) t
60 :     val _ = (m2 := LtDict.insert(!m2, t, x))
61 :     in x
62 :     end)
63 :     in {tc_map=tc_look, lt_map=lt_look}
64 :     end (* tmemo_gen *)
65 :    
66 :     fun wmemo_gen {tc_wmap, tc_umap, lt_umap} =
67 :     let val m1 = ref (TcDict.mkDict())
68 :     val m2 = ref (TcDict.mkDict())
69 :     val m3 = ref (LtDict.mkDict())
70 :    
71 :     fun tcw_look t =
72 :     (case TcDict.peek(!m1, t)
73 :     of SOME t' => t'
74 :     | NONE =>
75 :     let val x = (tc_wmap (tcw_look, tcu_look)) t
76 :     val _ = (m1 := TcDict.insert(!m1, t, x))
77 :     in x
78 :     end)
79 :    
80 :     and tcu_look t =
81 :     (case TcDict.peek(!m2, t)
82 :     of SOME t' => t'
83 :     | NONE =>
84 :     let val x = (tc_umap (tcu_look, tcw_look)) t
85 :     val _ = (m2 := TcDict.insert(!m2, t, x))
86 :     in x
87 :     end)
88 :    
89 :     and ltu_look t =
90 :     (case LtDict.peek(!m3, t)
91 :     of SOME t' => t'
92 :     | NONE =>
93 :     let val x = lt_umap (tcu_look, ltu_look) t
94 :     val _ = (m3 := LtDict.insert(!m3, t, x))
95 :     in x
96 :     end)
97 :    
98 :     fun cleanup () = ()
99 :     in {tc_wmap=tcw_look, tc_umap=tcu_look, lt_umap=ltu_look, cleanup=cleanup}
100 :     end (* wmemo_gen *)
101 :    
102 :     end (* toplevel local *)
103 :     end (* structure LtyDict *)
104 :    
105 :    
106 :    
107 :    

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