Commit | Line | Data |
---|---|---|
7f918cf1 CE |
1 | (* Copyright (C) 2009-2010 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. | |
5 | * | |
6 | * MLton is released under a BSD-style license. | |
7 | * See the file MLton-LICENSE for details. | |
8 | *) | |
9 | ||
10 | functor PolyHash (S: SSA_TRANSFORM_STRUCTS): SSA_TRANSFORM = | |
11 | struct | |
12 | ||
13 | open S | |
14 | ||
15 | (* | |
16 | * This pass implements polymorphic, structural hashing. | |
17 | * | |
18 | * For each datatype tycon and vector type, it builds a hashing function and | |
19 | * translates calls to MLton_hash into calls to that function. | |
20 | * | |
21 | * For tuples, it does the hashing inline. I.E. it does not create | |
22 | * a separate hashing function for each tuple type. | |
23 | * | |
24 | * All hashing functions are only created if necessary, i.e. if hashing | |
25 | * is actually used at a type. | |
26 | * | |
27 | * Optimizations: | |
28 | *) | |
29 | ||
30 | open Exp Transfer | |
31 | ||
32 | structure Dexp = | |
33 | struct | |
34 | open DirectExp | |
35 | ||
36 | fun wordFromWord (w: word, ws: WordSize.t): t = | |
37 | word (WordX.fromIntInf (Word.toIntInf w, ws)) | |
38 | ||
39 | fun shiftInt i = | |
40 | word (WordX.fromIntInf (i, WordSize.shiftArg)) | |
41 | fun shiftBits b = shiftInt (Bits.toIntInf b) | |
42 | ||
43 | local | |
44 | fun mk prim = | |
45 | fn (e1: t, e2: t, s) => | |
46 | primApp {prim = prim s, | |
47 | targs = Vector.new0 (), | |
48 | args = Vector.new2 (e1, e2), | |
49 | ty = Type.word s} | |
50 | in | |
51 | val add = mk Prim.wordAdd | |
52 | val andb = mk Prim.wordAndb | |
53 | val rshift = mk (fn s => Prim.wordRshift (s, {signed = false})) | |
54 | val xorb = mk Prim.wordXorb | |
55 | end | |
56 | local | |
57 | fun mk prim = | |
58 | fn (e1: t, e2: t, s, sg) => | |
59 | primApp {prim = prim (s, sg), | |
60 | targs = Vector.new0 (), | |
61 | args = Vector.new2 (e1, e2), | |
62 | ty = Type.word s} | |
63 | in | |
64 | val mul = mk Prim.wordMul | |
65 | end | |
66 | ||
67 | fun wordEqual (e1: t, e2: t, s): t = | |
68 | primApp {prim = Prim.wordEqual s, | |
69 | targs = Vector.new0 (), | |
70 | args = Vector.new2 (e1, e2), | |
71 | ty = Type.bool} | |
72 | end | |
73 | ||
74 | structure Hash = | |
75 | struct | |
76 | val resWordSize = WordSize.word32 | |
77 | val resTy = Type.word resWordSize | |
78 | ||
79 | fun mkWordBytes {stateTy: Type.t, | |
80 | workWordSize: WordSize.t, | |
81 | combByte: Dexp.t * Dexp.t -> Dexp.t, | |
82 | mix: Dexp.t -> Dexp.t} = | |
83 | let | |
84 | val workBits = WordSize.bits workWordSize | |
85 | val workTy = Type.word workWordSize | |
86 | fun wordBytes (st,w,ws) = | |
87 | let | |
88 | fun extdW w = | |
89 | if WordSize.equals (ws, workWordSize) | |
90 | then w | |
91 | else Dexp.primApp {prim = Prim.wordExtdToWord | |
92 | (ws, workWordSize, | |
93 | {signed = false}), | |
94 | targs = Vector.new0 (), | |
95 | args = Vector.new1 w, | |
96 | ty = workTy} | |
97 | ||
98 | val mask = | |
99 | (Dexp.word o WordX.resize) | |
100 | (WordX.allOnes WordSize.word8, | |
101 | workWordSize) | |
102 | ||
103 | fun loop (st, w, b) = | |
104 | if Bits.<= (b, Bits.zero) | |
105 | then st | |
106 | else let | |
107 | val dst0 = st | |
108 | val w0 = Var.newNoname () | |
109 | val dw0 = Dexp.var (w0, workTy) | |
110 | val bw = Var.newNoname () | |
111 | val dbw = Dexp.var (bw, workTy) | |
112 | val st1 = Var.newNoname () | |
113 | val dst1 = Dexp.var (st1, stateTy) | |
114 | val st2 = Var.newNoname () | |
115 | val dst2 = Dexp.var (st2, stateTy) | |
116 | in | |
117 | Dexp.lett | |
118 | {decs = [{var = w0, exp = w}, | |
119 | {var = bw, exp = | |
120 | Dexp.andb (dw0, mask, workWordSize)}, | |
121 | {var = st1, exp = | |
122 | combByte (dst0, dbw)}, | |
123 | {var = st2, exp = | |
124 | mix dst1}], | |
125 | body = loop (dst2, | |
126 | Dexp.rshift (dw0, | |
127 | Dexp.shiftBits Bits.inWord8, | |
128 | workWordSize), | |
129 | Bits.- (b, Bits.inWord8))} | |
130 | end | |
131 | fun lp (st, w, b) = | |
132 | if Bits.<= (b, Bits.zero) | |
133 | then st | |
134 | else let | |
135 | val dst0 = st | |
136 | val w0 = Var.newNoname () | |
137 | val dw0 = Dexp.var (w0, Type.word ws) | |
138 | val ew = Var.newNoname () | |
139 | val dew = Dexp.var (ew, workTy) | |
140 | val loopBits = Bits.min (b, workBits) | |
141 | val st1 = Var.newNoname () | |
142 | val dst1 = Dexp.var (st1, stateTy) | |
143 | in | |
144 | Dexp.lett | |
145 | {decs = [{var = w0, exp = w}, | |
146 | {var = ew, exp = extdW dw0}, | |
147 | {var = st1, exp = loop (dst0, dew, loopBits)}], | |
148 | body = lp (dst1, | |
149 | Dexp.rshift (dw0, | |
150 | Dexp.shiftBits workBits, | |
151 | ws), | |
152 | Bits.- (b, workBits))} | |
153 | end | |
154 | val st0 = Var.newNoname () | |
155 | val dst0 = Dexp.var (st0, stateTy) | |
156 | in | |
157 | Dexp.lett | |
158 | {decs = [{var = st0, exp = st}], | |
159 | body = lp (dst0, w, WordSize.bits ws)} | |
160 | end | |
161 | in | |
162 | wordBytes | |
163 | end | |
164 | ||
165 | (* | |
166 | (* Jenkins hash function | |
167 | * http://en.wikipedia.org/wiki/Jenkins_hash_function (20100315) | |
168 | *) | |
169 | val {stateTy: Type.t, | |
170 | init: unit -> Dexp.t, | |
171 | wordBytes: Dexp.t * Dexp.t * WordSize.t -> Dexp.t, | |
172 | fini: Dexp.t -> Dexp.t} = | |
173 | let | |
174 | val stateWordSize = resWordSize | |
175 | val stateTy = Type.word stateWordSize | |
176 | val workWordSize = resWordSize | |
177 | val workTy = Type.word workWordSize | |
178 | ||
179 | local | |
180 | fun mk prim = | |
181 | fn (w1, w2) => prim (w1, w2, stateWordSize) | |
182 | in | |
183 | val add = mk Dexp.add | |
184 | val lshift = mk Dexp.lshift | |
185 | val rshift = mk Dexp.rshift | |
186 | val xorb = mk Dexp.xorb | |
187 | end | |
188 | ||
189 | fun init () = Dexp.word (WordX.zero stateWordSize) | |
190 | fun combByte (hexp, wexp) = | |
191 | let | |
192 | val h0 = Var.newNoname () | |
193 | val dh0 = Dexp.var (h0, stateTy) | |
194 | val w0 = Var.newNoname () | |
195 | val dw0 = Dexp.var (w0, workTy) | |
196 | val h1 = Var.newNoname () | |
197 | val dh1 = Dexp.var (h1, stateTy) | |
198 | in | |
199 | Dexp.lett | |
200 | {decs = [{var = h0, exp = hexp}, | |
201 | {var = w0, exp = wexp}, | |
202 | {var = h1, exp = add (dh0, dw0)}], | |
203 | body = dh1} | |
204 | end | |
205 | fun mix hexp = | |
206 | let | |
207 | val h0 = Var.newNoname () | |
208 | val dh0 = Dexp.var (h0, stateTy) | |
209 | val h1 = Var.newNoname () | |
210 | val dh1 = Dexp.var (h1, stateTy) | |
211 | val h2 = Var.newNoname () | |
212 | val dh2 = Dexp.var (h2, stateTy) | |
213 | in | |
214 | Dexp.lett | |
215 | {decs = [{var = h0, exp = hexp}, | |
216 | {var = h1, exp = add (dh0, lshift (dh0, Dexp.shiftInt 10))}, | |
217 | {var = h2, exp = xorb (dh1, rshift (dh1, Dexp.shiftInt 6))}], | |
218 | body = dh2} | |
219 | end | |
220 | val wordBytes = | |
221 | mkWordBytes | |
222 | {stateTy = stateTy, | |
223 | workWordSize = workWordSize, | |
224 | combByte = combByte, | |
225 | mix = mix} | |
226 | fun fini hexp = | |
227 | let | |
228 | val h0 = Var.newNoname () | |
229 | val dh0 = Dexp.var (h0, stateTy) | |
230 | val h1 = Var.newNoname () | |
231 | val dh1 = Dexp.var (h1, stateTy) | |
232 | val h2 = Var.newNoname () | |
233 | val dh2 = Dexp.var (h2, stateTy) | |
234 | val h3 = Var.newNoname () | |
235 | val dh3 = Dexp.var (h3, stateTy) | |
236 | in | |
237 | Dexp.lett | |
238 | {decs = [{var = h0, exp = hexp}, | |
239 | {var = h1, exp = add (dh0, lshift (dh0, Dexp.shiftInt 3))}, | |
240 | {var = h2, exp = xorb (dh1, rshift (dh1, Dexp.shiftInt 11))}, | |
241 | {var = h3, exp = add (dh2, lshift (dh2, Dexp.shiftInt 15))}], | |
242 | body = dh3} | |
243 | end | |
244 | in | |
245 | {stateTy = stateTy, | |
246 | init = init, | |
247 | wordBytes = wordBytes, | |
248 | fini = fini} | |
249 | end | |
250 | *) | |
251 | ||
252 | (* FNV-1a hash function | |
253 | * http://en.wikipedia.org/wiki/Fowler-Noll-Vo_hash_function (20100315) | |
254 | *) | |
255 | val {stateTy: Type.t, | |
256 | init: unit -> Dexp.t, | |
257 | wordBytes: Dexp.t * Dexp.t * WordSize.t -> Dexp.t, | |
258 | fini: Dexp.t -> Dexp.t} = | |
259 | let | |
260 | val stateWordSize = resWordSize | |
261 | val stateTy = Type.word stateWordSize | |
262 | val workWordSize = resWordSize | |
263 | val workTy = Type.word workWordSize | |
264 | ||
265 | local | |
266 | fun mk prim = | |
267 | fn (w1, w2) => prim (w1, w2, stateWordSize) | |
268 | in | |
269 | val mul = mk (fn (w1,w2,s) => Dexp.mul (w1,w2,s,{signed = false})) | |
270 | val xorb = mk Dexp.xorb | |
271 | end | |
272 | ||
273 | val fnv_prime = WordX.fromIntInf (16777619, stateWordSize) | |
274 | val fnv_offset_bias = WordX.fromIntInf (2166136261, stateWordSize) | |
275 | ||
276 | fun init () = Dexp.word fnv_offset_bias | |
277 | fun combByte (hexp, wexp) = | |
278 | let | |
279 | val h0 = Var.newNoname () | |
280 | val dh0 = Dexp.var (h0, stateTy) | |
281 | val w0 = Var.newNoname () | |
282 | val dw0 = Dexp.var (w0, workTy) | |
283 | val h1 = Var.newNoname () | |
284 | val dh1 = Dexp.var (h1, stateTy) | |
285 | in | |
286 | Dexp.lett | |
287 | {decs = [{var = h0, exp = hexp}, | |
288 | {var = w0, exp = wexp}, | |
289 | {var = h1, exp = xorb (dh0, dw0)}], | |
290 | body = dh1} | |
291 | end | |
292 | fun mix hexp = | |
293 | let | |
294 | val h0 = Var.newNoname () | |
295 | val dh0 = Dexp.var (h0, stateTy) | |
296 | val p = Dexp.word fnv_prime | |
297 | val h1 = Var.newNoname () | |
298 | val dh1 = Dexp.var (h1, stateTy) | |
299 | in | |
300 | Dexp.lett | |
301 | {decs = [{var = h0, exp = hexp}, | |
302 | {var = h1, exp = mul (dh0, p)}], | |
303 | body = dh1} | |
304 | end | |
305 | val wordBytes = | |
306 | mkWordBytes | |
307 | {stateTy = stateTy, | |
308 | workWordSize = workWordSize, | |
309 | combByte = combByte, | |
310 | mix = mix} | |
311 | fun fini hexp = hexp | |
312 | in | |
313 | {stateTy = stateTy, | |
314 | init = init, | |
315 | wordBytes = wordBytes, | |
316 | fini = fini} | |
317 | end | |
318 | fun wordBytesFromWord (st: Dexp.t, w:word, ws: WordSize.t) = | |
319 | wordBytes (st, Dexp.wordFromWord (w, ws), ws) | |
320 | end | |
321 | ||
322 | fun transform (Program.T {datatypes, globals, functions, main}) = | |
323 | let | |
324 | val {get = funcInfo: Func.t -> {hasHash: bool}, | |
325 | set = setFuncInfo, ...} = | |
326 | Property.getSet (Func.plist, Property.initConst {hasHash = false}) | |
327 | val {get = labelInfo: Label.t -> {hasHash: bool}, | |
328 | set = setLabelInfo, ...} = | |
329 | Property.getSet (Label.plist, Property.initConst {hasHash = false}) | |
330 | val {get = tyconInfo: Tycon.t -> {cons: {con: Con.t, | |
331 | args: Type.t vector} vector}, | |
332 | set = setTyconInfo, ...} = | |
333 | Property.getSetOnce | |
334 | (Tycon.plist, Property.initRaise ("PolyHash.info", Tycon.layout)) | |
335 | val tyconCons = #cons o tyconInfo | |
336 | val {get = getHashFunc: Type.t -> Func.t option, | |
337 | set = setHashFunc, | |
338 | destroy = destroyHashFunc} = | |
339 | Property.destGetSet (Type.plist, Property.initConst NONE) | |
340 | val {get = getTyconHashFunc: Tycon.t -> Func.t option, | |
341 | set = setTyconHashFunc, ...} = | |
342 | Property.getSet (Tycon.plist, Property.initConst NONE) | |
343 | val {get = getVectorHashFunc: Type.t -> Func.t option, | |
344 | set = setVectorHashFunc, | |
345 | destroy = destroyVectorHashFunc} = | |
346 | Property.destGetSet (Type.plist, Property.initConst NONE) | |
347 | val returns = SOME (Vector.new1 Hash.stateTy) | |
348 | val seqIndexWordSize = WordSize.seqIndex () | |
349 | val seqIndexTy = Type.word seqIndexWordSize | |
350 | val newFunctions: Function.t list ref = ref [] | |
351 | fun newFunction z = | |
352 | List.push (newFunctions, | |
353 | Function.profile (Function.new z, | |
354 | SourceInfo.polyHash)) | |
355 | fun hashTyconFunc (tycon: Tycon.t): Func.t = | |
356 | case getTyconHashFunc tycon of | |
357 | SOME f => f | |
358 | | NONE => | |
359 | let | |
360 | val name = | |
361 | Func.newString (concat ["hash_", Tycon.originalName tycon]) | |
362 | val _ = setTyconHashFunc (tycon, SOME name) | |
363 | val ty = Type.datatypee tycon | |
364 | val st = (Var.newNoname (), Hash.stateTy) | |
365 | val x = (Var.newNoname (), ty) | |
366 | val args = Vector.new2 (st, x) | |
367 | val dst = Dexp.var st | |
368 | val dx = Dexp.var x | |
369 | val cons = tyconCons tycon | |
370 | val body = | |
371 | Dexp.casee | |
372 | {test = dx, | |
373 | ty = Hash.stateTy, | |
374 | default = NONE, | |
375 | cases = | |
376 | (Dexp.Con o Vector.map) | |
377 | (cons, fn {con, args} => | |
378 | let | |
379 | val xs = | |
380 | Vector.map | |
381 | (args, fn ty => | |
382 | (Var.newNoname (), ty)) | |
383 | in | |
384 | {con = con, | |
385 | args = xs, | |
386 | body = | |
387 | Vector.fold | |
388 | (xs, | |
389 | Hash.wordBytesFromWord | |
390 | (dst, Con.hash con, WordSize.word32), | |
391 | fn ((x,ty), dstate) => | |
392 | hashExp (dstate, Dexp.var (x, ty), ty))} | |
393 | end)} | |
394 | val (start, blocks) = Dexp.linearize (body, Handler.Caller) | |
395 | val blocks = Vector.fromList blocks | |
396 | val _ = | |
397 | newFunction {args = args, | |
398 | blocks = blocks, | |
399 | mayInline = true, | |
400 | name = name, | |
401 | raises = NONE, | |
402 | returns = returns, | |
403 | start = start} | |
404 | in | |
405 | name | |
406 | end | |
407 | and vectorHashFunc (ty: Type.t): Func.t = | |
408 | case getVectorHashFunc ty of | |
409 | SOME f => f | |
410 | | NONE => | |
411 | let | |
412 | (* Build two functions, one that hashes the length and the | |
413 | * other that loops. | |
414 | *) | |
415 | val name = Func.newString "vectorHash" | |
416 | val _ = setVectorHashFunc (ty, SOME name) | |
417 | val loop = Func.newString "vectorHashLoop" | |
418 | val vty = Type.vector ty | |
419 | local | |
420 | val st = (Var.newNoname (), Hash.stateTy) | |
421 | val vec = (Var.newNoname (), vty) | |
422 | val args = Vector.new2 (st, vec) | |
423 | val dst = Dexp.var st | |
424 | val dvec = Dexp.var vec | |
425 | val len = (Var.newNoname (), seqIndexTy) | |
426 | val dlen = Dexp.var len | |
427 | val body = | |
428 | Dexp.lett | |
429 | {decs = [{var = #1 len, exp = | |
430 | Dexp.primApp {prim = Prim.vectorLength, | |
431 | targs = Vector.new1 ty, | |
432 | args = Vector.new1 dvec, | |
433 | ty = seqIndexTy}}], | |
434 | body = | |
435 | Dexp.call | |
436 | {func = loop, | |
437 | args = (Vector.new4 | |
438 | (Hash.wordBytes (dst, dlen, seqIndexWordSize), | |
439 | dvec, dlen, Dexp.word (WordX.zero seqIndexWordSize))), | |
440 | ty = Hash.stateTy}} | |
441 | val (start, blocks) = Dexp.linearize (body, Handler.Caller) | |
442 | val blocks = Vector.fromList blocks | |
443 | in | |
444 | val _ = | |
445 | newFunction {args = args, | |
446 | blocks = blocks, | |
447 | mayInline = true, | |
448 | name = name, | |
449 | raises = NONE, | |
450 | returns = returns, | |
451 | start = start} | |
452 | end | |
453 | local | |
454 | val st = (Var.newNoname (), Hash.stateTy) | |
455 | val vec = (Var.newNoname (), vty) | |
456 | val len = (Var.newNoname (), seqIndexTy) | |
457 | val i = (Var.newNoname (), seqIndexTy) | |
458 | val args = Vector.new4 (st, vec, len, i) | |
459 | val dst = Dexp.var st | |
460 | val dvec = Dexp.var vec | |
461 | val dlen = Dexp.var len | |
462 | val di = Dexp.var i | |
463 | val body = | |
464 | let | |
465 | val args = | |
466 | Vector.new4 | |
467 | (hashExp | |
468 | (dst, | |
469 | Dexp.primApp {prim = Prim.vectorSub, | |
470 | targs = Vector.new1 ty, | |
471 | args = Vector.new2 (dvec, di), | |
472 | ty = ty}, | |
473 | ty), | |
474 | dvec, | |
475 | dlen, | |
476 | Dexp.add (di, | |
477 | Dexp.word (WordX.one seqIndexWordSize), | |
478 | seqIndexWordSize)) | |
479 | in | |
480 | Dexp.casee | |
481 | {test = Dexp.wordEqual | |
482 | (di, dlen, seqIndexWordSize), | |
483 | ty = Hash.stateTy, | |
484 | default = NONE, | |
485 | cases = (Dexp.Con o Vector.new2) | |
486 | ({con = Con.truee, | |
487 | args = Vector.new0 (), | |
488 | body = dst}, | |
489 | {con = Con.falsee, | |
490 | args = Vector.new0 (), | |
491 | body = Dexp.call {args = args, | |
492 | func = loop, | |
493 | ty = Hash.stateTy}})} | |
494 | end | |
495 | val (start, blocks) = Dexp.linearize (body, Handler.Caller) | |
496 | val blocks = Vector.fromList blocks | |
497 | in | |
498 | val _ = | |
499 | newFunction {args = args, | |
500 | blocks = blocks, | |
501 | mayInline = true, | |
502 | name = loop, | |
503 | raises = NONE, | |
504 | returns = returns, | |
505 | start = start} | |
506 | end | |
507 | in | |
508 | name | |
509 | end | |
510 | and hashExp (st: Dexp.t, x: Dexp.t, ty: Type.t): Dexp.t = | |
511 | Dexp.name (st, fn st => | |
512 | Dexp.name (x, fn x => hash (st, x, ty))) | |
513 | and hash (st: Var.t, x: Var.t, ty: Type.t): Dexp.t = | |
514 | let | |
515 | val dst = Dexp.var (st, Hash.stateTy) | |
516 | val dx = Dexp.var (x, ty) | |
517 | fun stateful () = | |
518 | Hash.wordBytesFromWord | |
519 | (dst, Type.hash ty, WordSize.word32) | |
520 | ||
521 | val body = | |
522 | case Type.dest ty of | |
523 | Type.Array _ => stateful () | |
524 | | Type.CPointer => | |
525 | let | |
526 | val ws = WordSize.cpointer () | |
527 | val toWord = | |
528 | Dexp.primApp | |
529 | {prim = Prim.cpointerToWord, | |
530 | targs = Vector.new0 (), | |
531 | args = Vector.new1 dx, | |
532 | ty = Type.word ws} | |
533 | in | |
534 | Hash.wordBytes (dst, toWord, ws) | |
535 | end | |
536 | | Type.Datatype tycon => | |
537 | Dexp.call {func = hashTyconFunc tycon, | |
538 | args = Vector.new2 (dst, dx), | |
539 | ty = Hash.stateTy} | |
540 | | Type.IntInf => | |
541 | let | |
542 | val sws = WordSize.smallIntInfWord () | |
543 | val bws = WordSize.bigIntInfWord () | |
544 | val toWord = | |
545 | Dexp.primApp | |
546 | {prim = Prim.intInfToWord, | |
547 | targs = Vector.new0 (), | |
548 | args = Vector.new1 dx, | |
549 | ty = Type.word sws} | |
550 | val toVector = | |
551 | Dexp.primApp | |
552 | {prim = Prim.intInfToVector, | |
553 | targs = Vector.new0 (), | |
554 | args = Vector.new1 dx, | |
555 | ty = Type.vector (Type.word bws)} | |
556 | val w = Var.newNoname () | |
557 | val dw = Dexp.var (w, Type.word sws) | |
558 | val one = Dexp.word (WordX.one sws) | |
559 | in | |
560 | Dexp.lett | |
561 | {decs = [{var = w, exp = toWord}], | |
562 | body = | |
563 | Dexp.casee | |
564 | {test = Dexp.wordEqual (Dexp.andb (dw, one, sws), one, sws), | |
565 | ty = Hash.stateTy, | |
566 | default = NONE, | |
567 | cases = | |
568 | (Dexp.Con o Vector.new2) | |
569 | ({con = Con.truee, | |
570 | args = Vector.new0 (), | |
571 | body = Hash.wordBytes (dst, dw, sws)}, | |
572 | {con = Con.falsee, | |
573 | args = Vector.new0 (), | |
574 | body = | |
575 | Dexp.call {func = vectorHashFunc (Type.word bws), | |
576 | args = Vector.new2 (dst, toVector), | |
577 | ty = Hash.stateTy}})}} | |
578 | end | |
579 | | Type.Real rs => | |
580 | let | |
581 | val ws = WordSize.fromBits (RealSize.bits rs) | |
582 | val toWord = | |
583 | Dexp.primApp | |
584 | {prim = Prim.realCastToWord (rs, ws), | |
585 | targs = Vector.new0 (), | |
586 | args = Vector.new1 dx, | |
587 | ty = Type.word ws} | |
588 | in | |
589 | Hash.wordBytes (dst, toWord, ws) | |
590 | end | |
591 | | Type.Ref _ => stateful () | |
592 | | Type.Thread => stateful () | |
593 | | Type.Tuple tys => | |
594 | let | |
595 | val max = Vector.length tys - 1 | |
596 | (* hash components i, i+1, ... *) | |
597 | fun loop (i: int, dst): Dexp.t = | |
598 | if i > max | |
599 | then dst | |
600 | else let | |
601 | val ty = Vector.sub (tys, i) | |
602 | val select = | |
603 | Dexp.select {tuple = dx, | |
604 | offset = i, | |
605 | ty = ty} | |
606 | in | |
607 | loop | |
608 | (i + 1, | |
609 | hashExp (dst, select, ty)) | |
610 | end | |
611 | in | |
612 | loop (0, dst) | |
613 | end | |
614 | | Type.Vector ty => | |
615 | Dexp.call {func = vectorHashFunc ty, | |
616 | args = Vector.new2 (dst, dx), | |
617 | ty = Hash.stateTy} | |
618 | | Type.Weak _ => stateful () | |
619 | | Type.Word ws => Hash.wordBytes (dst, dx, ws) | |
620 | in | |
621 | body | |
622 | end | |
623 | fun hashFunc (ty: Type.t): Func.t = | |
624 | case getHashFunc ty of | |
625 | SOME f => f | |
626 | | NONE => | |
627 | let | |
628 | val name = Func.newString "hash" | |
629 | val _ = setHashFunc (ty, SOME name) | |
630 | val x = (Var.newNoname (), ty) | |
631 | val args = Vector.new1 x | |
632 | val sti = Var.newNoname () | |
633 | val dsti = Dexp.var (sti, Hash.stateTy) | |
634 | val dx = Dexp.var x | |
635 | val stf = Var.newNoname () | |
636 | val dstf = Dexp.var (stf, Hash.stateTy) | |
637 | val w = Var.newNoname () | |
638 | val dw = Dexp.var (w, Hash.resTy) | |
639 | val body = | |
640 | Dexp.lett | |
641 | {decs = [{var = sti, exp = Hash.init ()}, | |
642 | {var = stf, exp = hashExp (dsti, dx, ty)}, | |
643 | {var = w, exp = Hash.fini dstf}], | |
644 | body = dw} | |
645 | val (start, blocks) = Dexp.linearize (body, Handler.Caller) | |
646 | val blocks = Vector.fromList blocks | |
647 | val _ = | |
648 | newFunction {args = args, | |
649 | blocks = blocks, | |
650 | mayInline = true, | |
651 | name = name, | |
652 | raises = NONE, | |
653 | returns = returns, | |
654 | start = start} | |
655 | in | |
656 | name | |
657 | end | |
658 | ||
659 | val _ = | |
660 | Vector.foreach | |
661 | (datatypes, fn Datatype.T {tycon, cons} => | |
662 | setTyconInfo (tycon, | |
663 | {cons = cons})) | |
664 | val () = | |
665 | List.foreach | |
666 | (functions, fn f => | |
667 | let | |
668 | val {name, blocks, ...} = Function.dest f | |
669 | in | |
670 | Vector.foreach | |
671 | (blocks, fn Block.T {label, statements, ...} => | |
672 | let | |
673 | fun setHasHash () = | |
674 | (setFuncInfo (name, {hasHash = true}) | |
675 | ; setLabelInfo (label, {hasHash = true})) | |
676 | in | |
677 | Vector.foreach | |
678 | (statements, fn Statement.T {exp, ...} => | |
679 | (case exp of | |
680 | PrimApp {prim, ...} => | |
681 | (case Prim.name prim of | |
682 | Prim.Name.MLton_hash => setHasHash () | |
683 | | _ => ()) | |
684 | | _ => ())) | |
685 | end) | |
686 | end) | |
687 | fun doit blocks = | |
688 | let | |
689 | val blocks = | |
690 | Vector.fold | |
691 | (blocks, [], | |
692 | fn (block as Block.T {label, args, statements, transfer}, blocks) => | |
693 | if not (#hasHash (labelInfo label)) | |
694 | then block::blocks | |
695 | else | |
696 | let | |
697 | fun finish ({label, args, statements}, transfer) = | |
698 | Block.T {label = label, | |
699 | args = args, | |
700 | statements = Vector.fromListRev statements, | |
701 | transfer = transfer} | |
702 | val (blocks, las) = | |
703 | Vector.fold | |
704 | (statements, | |
705 | (blocks, {label = label, args = args, statements = []}), | |
706 | fn (stmt as Statement.T {exp, var, ...}, | |
707 | (blocks, las as {label, args, statements})) => | |
708 | let | |
709 | fun normal () = (blocks, | |
710 | {label = label, | |
711 | args = args, | |
712 | statements = stmt::statements}) | |
713 | in | |
714 | case exp of | |
715 | PrimApp {prim, targs, args, ...} => | |
716 | (case (Prim.name prim, Vector.length targs) of | |
717 | (Prim.Name.MLton_hash, 1) => | |
718 | let | |
719 | val ty = Vector.first targs | |
720 | val x = Vector.first args | |
721 | val l = Label.newNoname () | |
722 | in | |
723 | (finish | |
724 | (las, | |
725 | Call {args = Vector.new1 x, | |
726 | func = hashFunc ty, | |
727 | return = Return.NonTail | |
728 | {cont = l, | |
729 | handler = Handler.Caller}}) | |
730 | :: blocks, | |
731 | {label = l, | |
732 | args = Vector.new1 (valOf var, Hash.resTy), | |
733 | statements = []}) | |
734 | end | |
735 | | _ => normal ()) | |
736 | | _ => normal () | |
737 | end) | |
738 | in | |
739 | finish (las, transfer) | |
740 | :: blocks | |
741 | end) | |
742 | in | |
743 | Vector.fromList blocks | |
744 | end | |
745 | val functions = | |
746 | List.revMap | |
747 | (functions, fn f => | |
748 | let | |
749 | val {args, blocks, mayInline, name, raises, returns, start} = | |
750 | Function.dest f | |
751 | val f = | |
752 | if #hasHash (funcInfo name) | |
753 | then Function.new {args = args, | |
754 | blocks = doit blocks, | |
755 | mayInline = mayInline, | |
756 | name = name, | |
757 | raises = raises, | |
758 | returns = returns, | |
759 | start = start} | |
760 | else f | |
761 | val () = Function.clear f | |
762 | in | |
763 | f | |
764 | end) | |
765 | val program = | |
766 | Program.T {datatypes = datatypes, | |
767 | globals = globals, | |
768 | functions = (!newFunctions) @ functions, | |
769 | main = main} | |
770 | val _ = destroyHashFunc () | |
771 | val _ = destroyVectorHashFunc () | |
772 | val _ = Program.clearTop program | |
773 | in | |
774 | program | |
775 | end | |
776 | ||
777 | end |