Commit | Line | Data |
---|---|---|
7f918cf1 CE |
1 | (* Copyright (C) 2017 Matthew Fluet. |
2 | * Copyright (C) 1999-2005, 2008 Henry Cejtin, Matthew Fluet, Suresh | |
3 | * Jagannathan, and Stephen Weeks. | |
4 | * Copyright (C) 1997-2000 NEC Research Institute. | |
5 | * | |
6 | * MLton is released under a BSD-style license. | |
7 | * See the file MLton-LICENSE for details. | |
8 | *) | |
9 | ||
10 | functor Global (S: GLOBAL_STRUCTS): GLOBAL = | |
11 | struct | |
12 | ||
13 | open S | |
14 | open Exp | |
15 | ||
16 | fun equalss (xs, xs') = Vector.equals (xs, xs', Var.equals) | |
17 | ||
18 | val expEquals = | |
19 | fn (ConApp {con = c, args}, ConApp {con = c', args = args'}) => | |
20 | Con.equals (c, c') andalso equalss (args, args') | |
21 | | (Const c, Const c') => Const.equals (c, c') | |
22 | | (PrimApp {prim = p, targs = ts, args = xs}, | |
23 | PrimApp {prim = p', targs = ts', args = xs'}) => | |
24 | let | |
25 | datatype z = datatype Prim.Name.t | |
26 | val n = Prim.name p | |
27 | val n' = Prim.name p' | |
28 | in | |
29 | case (n, n') of | |
30 | (Vector_vector, Vector_vector) => | |
31 | Vector.equals (ts, ts', Type.equals) | |
32 | andalso equalss (xs, xs') | |
33 | | _ => false | |
34 | end | |
35 | | (Tuple xs, Tuple xs') => equalss (xs, xs') | |
36 | | _ => false | |
37 | ||
38 | fun make () = | |
39 | let | |
40 | type bind = {var: Var.t, ty: Type.t, exp: Exp.t} | |
41 | val binds: bind list ref = ref [] | |
42 | fun all () = Vector.fromList | |
43 | (List.revMap | |
44 | (!binds, fn {var, ty, exp} => | |
45 | Statement.T {var = SOME var, ty = ty, exp = exp})) | |
46 | before binds := [] | |
47 | val set: (word * bind) HashSet.t = HashSet.new {hash = #1} | |
48 | fun new (ty: Type.t, exp: Exp.t): Var.t = | |
49 | let | |
50 | val hash = hash exp | |
51 | in | |
52 | #var | |
53 | (#2 | |
54 | (HashSet.lookupOrInsert | |
55 | (set, hash, | |
56 | fn (_, {exp = exp', ...}) => expEquals (exp, exp'), | |
57 | fn () => | |
58 | let | |
59 | val x = Var.newString "global" | |
60 | val bind = {var = x, ty = ty, exp = exp} | |
61 | in List.push (binds, bind) | |
62 | ; (hash, bind) | |
63 | end))) | |
64 | end | |
65 | in {new = new, all = all} | |
66 | end | |
67 | end |