Commit | Line | Data |
---|---|---|
7f918cf1 CE |
1 | (* hash.sml |
2 | * 2005 Matthew Fluet (mfluet@acm.org) | |
3 | * Adapted for MLton. | |
4 | *) | |
5 | ||
6 | (* | |
7 | * hash.sml - Generating unique hash codes for C function types and | |
8 | * for ML types. | |
9 | * | |
10 | * (C) 2002, Lucent Technologies, Bell Labs | |
11 | * | |
12 | * author: Matthias Blume (blume@research.bell-labs.com) | |
13 | *) | |
14 | structure Hash : sig | |
15 | val mkFHasher : unit -> Spec.cft -> int | |
16 | val mkTHasher : unit -> PrettyPrint.mltype -> int | |
17 | end = struct | |
18 | ||
19 | structure S = Spec | |
20 | structure PP = PrettyPrint | |
21 | structure SM = StringMap | |
22 | structure LM = IntListMap | |
23 | ||
24 | fun tyConId S.SCHAR = 0 | |
25 | | tyConId S.UCHAR = 1 | |
26 | | tyConId S.SSHORT = 2 | |
27 | | tyConId S.USHORT = 3 | |
28 | | tyConId S.SINT = 4 | |
29 | | tyConId S.UINT = 5 | |
30 | | tyConId S.SLONG = 6 | |
31 | | tyConId S.ULONG = 7 | |
32 | | tyConId S.SLONGLONG = 8 | |
33 | | tyConId S.ULONGLONG = 9 | |
34 | | tyConId S.FLOAT = 10 | |
35 | | tyConId S.DOUBLE = 11 | |
36 | ||
37 | fun conConId S.RW = 0 | |
38 | | conConId S.RO = 1 | |
39 | ||
40 | fun look (next, find, insert) tab k = | |
41 | case find (!tab, k) of | |
42 | SOME i => i | |
43 | | NONE => let | |
44 | val i = !next | |
45 | in | |
46 | next := i + 1; | |
47 | tab := insert (!tab, k, i); | |
48 | i | |
49 | end | |
50 | ||
51 | fun mkFHasher () = let | |
52 | val stab = ref SM.empty | |
53 | val utab = ref SM.empty | |
54 | val etab = ref SM.empty | |
55 | val ltab = ref LM.empty | |
56 | ||
57 | val next = ref 13 | |
58 | ||
59 | val tlook = look (next, SM.find, SM.insert) | |
60 | val llook = look (next, LM.find, LM.insert) ltab | |
61 | ||
62 | fun hash (S.STRUCT t) = tlook stab t | |
63 | | hash (S.UNION t) = tlook utab t | |
64 | | hash (S.ENUM (t, _)) = tlook etab t | |
65 | | hash (S.FPTR x) = cfthash x | |
66 | | hash (S.PTR (c, ty)) = llook [1, conConId c, hash ty] | |
67 | | hash (S.ARR { t, d, esz }) = llook [2, hash t, d, esz] | |
68 | | hash (S.BASIC ty) = tyConId ty | |
69 | | hash (S.VOIDPTR) = 12 | |
70 | | hash _ = raise Fail "hash" | |
71 | ||
72 | and cfthash { args, res } = llook (0 :: opthash res :: map hash args) | |
73 | ||
74 | and opthash NONE = 0 | |
75 | | opthash (SOME ty) = 1 + hash ty | |
76 | in | |
77 | cfthash | |
78 | end | |
79 | ||
80 | fun mkTHasher () = let | |
81 | val stab = ref SM.empty | |
82 | val ltab = ref LM.empty | |
83 | ||
84 | val next = ref 0 | |
85 | ||
86 | val slook = look (next, SM.find, SM.insert) stab | |
87 | val llook = look (next, LM.find, LM.insert) ltab | |
88 | ||
89 | fun hash (PP.ARROW (t, t')) = llook [0, hash t, hash t'] | |
90 | | hash (PP.TUPLE tl) = llook (1 :: map hash tl) | |
91 | | hash (PP.CON (c, tl)) = llook (2 :: slook c :: map hash tl) | |
92 | | hash (PP.RECORD pl) = llook (3 :: map phash pl) | |
93 | ||
94 | and phash (n, t) = llook [4, slook n, hash t] | |
95 | in | |
96 | hash | |
97 | end | |
98 | end |