1 (* Copyright (C) 2017 Matthew Fluet.
2 * Copyright (C) 1999-2008 Henry Cejtin, Matthew Fluet, Suresh
3 * Jagannathan, and Stephen Weeks.
4 * Copyright (C) 1997-2000 NEC Research Institute.
6 * MLton is released under a BSD-style license.
7 * See the file MLton-LICENSE for details.
10 functor HashType (S: HASH_TYPE_STRUCTS): HASH_TYPE =
20 plist: PropertyList.t,
25 | Con of Tycon.t * t vector
28 fun make f (T r) = f r
31 val plist = make #plist
39 fn Var a => Tyvar.layout a
42 Vector.layout (layoutTree o tree) ts]
47 datatype dest = datatype tree
57 fun makeHom {con, var} =
59 val {get, destroy, ...} =
66 | Con (c, ts) => con (t, c, Vector.map (ts, get))))
67 in {hom = get, destroy = destroy}
70 fun hom {ty, var, con} =
72 val {hom, destroy} = makeHom {var = var o #2,
73 con = fn (_, c, xs) => con (c, xs)}
79 fun makeMonoHom {con} =
80 makeHom {var = fn _ => Error.bug "HashType.Type.makeMonoHom: type variable",
83 fun equals (t, t'): bool = PropertyList.equals (plist t, plist t')
85 fun layoutPretty (ty: t): Layout.t =
86 #1 (hom {con = fn (c, ts) => (Tycon.layoutAppPretty
87 (c, ts, {layoutPretty = Tycon.layout})),
89 var = fn a => LayoutPretty.simple (Tyvar.layout a)})
91 fun layout (ty: t): Layout.t =
92 hom {con = Tycon.layoutApp,
97 val same: tree * tree -> bool =
98 fn (Var a, Var a') => Tyvar.equals (a, a')
99 | (Con (c, ts), Con (c', ts')) =>
101 andalso Vector.equals (ts, ts', equals)
104 Trace.trace2 ("HashType.Type.same", layoutTree, layoutTree, Bool.layout)
106 val table: t HashSet.t = HashSet.new {hash = hash}
108 fun lookup (hash, tr) =
109 HashSet.lookupOrInsert (table, hash,
110 fn t => same (tr, tree t),
111 fn () => T {hash = hash,
112 plist = PropertyList.new (),
117 in align [seq [str "num types in hash table = ",
118 Int.layout (HashSet.size table)],
119 Control.sizeMessage ("types hash table", table)]
123 fun var a = lookup (Tyvar.hash a, Var a)
126 val generator: Word.t = 0wx5555
129 lookup (Vector.fold (ts, Tycon.hash c, fn (t, w) =>
130 Word.xorb (w * generator, hash t)),
132 val con = Trace.trace2 ("HashType.Type.con",
134 Vector.layout layout,
138 structure Ops = TypeOps (structure Tycon = Tycon
142 val string = word8Vector
146 datatype z = datatype Const.t
151 | Real r => real (RealX.size r)
152 | Word w => word (WordX.size w)
153 | WordVector v => vector (word (WordXVector.elementSize v))
158 Con (c, ts) => Vector.isEmpty ts andalso Tycon.equals (c, Tycon.tuple)
161 fun substitute (ty, v) =
163 then ty (* This optimization is important so that monotypes
164 * are not substituted inside of.
168 var = fn a => (case Vector.peek (v, fn (a', _) =>
169 Tyvar.equals (a, a')) of
171 | SOME (_, ty) => ty),
176 ("HashType.substitute",
178 Vector.layout (Layout.tuple2 (Tyvar.layout, Type.layout)),
182 (* fun equalss (ts: t list): t option =
185 * let fun loop [] = SOME t
186 * | loop (t' :: ts) = if equals (t, t') then loop ts else NONE
189 * | [] => Error.bug "HashType.equals"
194 val print = Out.outputc out
197 fun error (msg, lay) =
198 (print (concat ["Type error: ", msg, "\n"])
199 ; Layout.output (lay, out)
207 | _ => Error.bug "HashType.tycon: type variable"
209 fun containsTycon (ty, tycon) =
212 con = fn (tycon', bs) => (Tycon.equals (tycon, tycon')
213 orelse Vector.exists (bs, fn b => b))}
215 fun checkPrimApp {args, prim, result, targs}: bool =
220 typeOps = {array = array,