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 651 - (view) (download)

1 : monnier 245 (* 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 : monnier 498 structure TcDict = RedBlackMapFn(struct type ord_key = tyc
32 : monnier 411 val compare = tc_cmp
33 :     end)
34 : monnier 245
35 : monnier 498 structure LtDict = RedBlackMapFn(struct type ord_key = lty
36 : monnier 411 val compare = lt_cmp
37 :     end)
38 : monnier 245
39 :     type tyc = tyc
40 :     type lty = lty
41 :    
42 :     fun tmemo_gen {tcf, ltf} =
43 : monnier 411 let val m1 = ref (TcDict.empty)
44 :     val m2 = ref (LtDict.empty)
45 : monnier 245
46 :     fun tc_look t =
47 : monnier 411 (case TcDict.find(!m1, t)
48 : monnier 245 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 : monnier 411 (case LtDict.find(!m2, t)
57 : monnier 245 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 : monnier 411 let val m1 = ref (TcDict.empty)
68 :     val m2 = ref (TcDict.empty)
69 :     val m3 = ref (LtDict.empty)
70 : monnier 245
71 :     fun tcw_look t =
72 : monnier 411 (case TcDict.find(!m1, t)
73 : monnier 245 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 : monnier 411 (case TcDict.find(!m2, t)
82 : monnier 245 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 : monnier 411 (case LtDict.find(!m3, t)
91 : monnier 245 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 :    
108 :    

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