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 /smlnj-lib/trunk/HashCons/hash-cons.sml
ViewVC logotype

Annotation of /smlnj-lib/trunk/HashCons/hash-cons.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 2144 - (view) (download)

1 : jhr 967 (* hash-cons.sml
2 :     *
3 :     * COPYRIGHT (c) 2001 Bell Labs, Lucent Technologies.
4 :     *)
5 :    
6 :     structure HashCons :> HASH_CONS =
7 :     struct
8 :    
9 :     type 'a obj = {nd : 'a, tag : word, hash : word}
10 :    
11 :     datatype 'a tbl = Tbl of {
12 :     eq : 'a * 'a -> bool,
13 :     nextTag : word ref,
14 :     tbl : 'a obj list Array.array ref
15 :     }
16 :    
17 :     val tblSz = PrimeSizes.pick 64
18 :    
19 :     fun new {eq} = Tbl{
20 :     eq = eq,
21 :     nextTag = ref 0w0,
22 :     tbl = ref(Array.array(tblSz, []))
23 :     }
24 :    
25 :     fun clear (Tbl{nextTag, tbl, ...}) = (
26 :     nextTag := 0w0;
27 :     Array.modify (fn _ => []) (!tbl))
28 :    
29 :     fun insert (Tbl{eq, nextTag, tbl}, h, term) = let
30 :     val tbl' = !tbl
31 :     val i = Word.toIntX(Word.mod(h, Word.fromInt(Array.length tbl')))
32 :     val bucket = Array.sub(tbl', i)
33 :     fun find [] = let
34 :     val id = !nextTag
35 :     val obj = {nd = term, hash = h, tag = id}
36 :     in
37 :     Array.update(tbl', i, obj::bucket);
38 :     (* check for table resize *)
39 :     obj
40 :     end
41 :     | find ((obj as {nd, hash, ...})::r) =
42 :     if (h = hash) andalso eq(term, nd)
43 :     then obj
44 :     else find r
45 :     in
46 :     find bucket
47 :     end
48 :    
49 :     fun node {nd, tag, hash} = nd
50 :     fun tag {nd, tag, hash} = tag
51 :    
52 :     fun same (a : 'a obj, b : 'a obj) = (#tag a = #tag b)
53 :     fun compare (a : 'a obj, b : 'a obj) = Word.compare(#tag a, #tag b)
54 :    
55 :     fun <+ (a, b) = Word.<<(a, 0w1) + b
56 :     infix <+
57 :    
58 :     fun cons0 tbl (id, c) = insert (tbl, id, c)
59 :    
60 :     fun cons1 tbl (id, cf) (b : 'b obj) =
61 :     insert (tbl, id <+ (#tag b), cf b)
62 :    
63 :     fun cons2 tbl (id, cf) (b : 'b obj, c : 'c obj) =
64 :     insert (tbl, id <+ (#tag b) <+ (#tag c), cf(b, c))
65 :    
66 :     fun cons3 tbl (id, cf) (b : 'b obj, c : 'c obj, d : 'd obj) =
67 :     insert (tbl, id <+ (#tag b) <+ (#tag c) <+ (#tag d), cf(b, c, d))
68 :    
69 :     fun cons4 tbl (id, cf) (b : 'b obj, c : 'c obj, d : 'd obj, e : 'e obj) =
70 :     insert (tbl, id <+ (#tag b) <+ (#tag c) <+ (#tag d) <+ (#tag e),
71 :     cf(b, c, d, e))
72 :    
73 :     fun cons5 tbl (id, cf)
74 :     (b : 'b obj, c : 'c obj, d : 'd obj, e : 'e obj, f : 'f obj) =
75 :     insert (tbl,
76 :     id <+ (#tag b) <+ (#tag c) <+ (#tag d) <+ (#tag e) <+ (#tag f),
77 :     cf(b, c, d, e, f))
78 :    
79 :     fun consList tbl (id, cf) (l : 'b obj list) =
80 :     insert (tbl, List.foldl (fn ({tag, ...}, sum) => sum <+ tag) id l, cf l)
81 :    
82 : jhr 1193 (* consing for records *)
83 :     fun consR1 tbl (id, inj, prj) r = cons1 tbl (id, inj) (prj r)
84 :     fun consR2 tbl (id, inj, prj) r = cons2 tbl (id, inj) (prj r)
85 :     fun consR3 tbl (id, inj, prj) r = cons3 tbl (id, inj) (prj r)
86 :     fun consR4 tbl (id, inj, prj) r = cons4 tbl (id, inj) (prj r)
87 :     fun consR5 tbl (id, inj, prj) r = cons5 tbl (id, inj) (prj r)
88 :    
89 : jhr 967 end

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