[MLton-commit] r6374
Vesa Karvonen
vesak at mlton.org
Mon Feb 4 06:43:27 PST 2008
Moved hashing of labels and constructors to the Generics module and made
it non-recursive, hashing only a fixed number of characters from the end
of the label or constructor, to allow it to be constant folded. The
labels and constructors should practically always be known in compile-time
(although it is possible to write programs where that isn't the case).
----------------------------------------------------------------------
U mltonlib/trunk/com/ssh/generic/unstable/detail/framework/generics.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-hash.sml
U mltonlib/trunk/com/ssh/generic/unstable/public/extra/generic-extra.sig
U mltonlib/trunk/com/ssh/generic/unstable/public/framework/generics.sig
----------------------------------------------------------------------
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/framework/generics.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/framework/generics.sml 2008-02-04 14:10:30 UTC (rev 6373)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/framework/generics.sml 2008-02-04 14:43:26 UTC (rev 6374)
@@ -1,4 +1,4 @@
-(* Copyright (C) 2007 SSH Communications Security, Helsinki, Finland
+(* Copyright (C) 2007-2008 SSH Communications Security, Helsinki, Finland
*
* This code is released under the MLton license, a BSD-style license.
* See the LICENSE file or http://mlton.org/License for details.
@@ -9,9 +9,12 @@
open TopLevel
(* SML/NJ workaround --> *)
+ structure W = Word32
+
structure Label = struct
- open String
- val toString = id
+ type t = W.t * String.t
+ val toString = Pair.snd
+ val hash = Pair.fst
end
structure Con = Label
@@ -19,6 +22,24 @@
structure Record = Unit
structure Tuple = Unit
- val L = id
- val C = id
+ local
+ (* The idea here is to compute the hash of at most some fixed number
+ * of characters non-recursively. This allows MLton to constant
+ * fold the computation given a large enough inlining threshold.
+ * -inline 275 with -loop-passes 2 has worked; default is -inline
+ * 60 and -loop-passes 1, at the time of writing.
+ *)
+ fun hash s = let
+ fun S (hi as (h, i)) =
+ if i < 0
+ then hi
+ else (h * 0w33 + W.fromInt (ord (String.sub (s, i))), i-1)
+ in
+ case S(S(S(S(S(S(S(S(0w5381, size s-1))))))))
+ of (h, n) => h + W.fromInt n
+ end
+ in
+ fun L s = (hash s, s)
+ val C = L
+ end
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-hash.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-hash.sml 2008-02-04 14:10:30 UTC (rev 6373)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-hash.sml 2008-02-04 14:43:26 UTC (rev 6374)
@@ -1,4 +1,4 @@
-(* Copyright (C) 2007 SSH Communications Security, Helsinki, Finland
+(* Copyright (C) 2007-2008 SSH Communications Security, Helsinki, Finland
*
* This code is released under the MLton license, a BSD-style license.
* See the LICENSE file or http://mlton.org/License for details.
@@ -9,21 +9,14 @@
open TopLevel
(* SML/NJ workaround --> *)
- local
- open Word32
- in
- fun unary c h = h * 0w19 + c
- fun binary c (l, r) = l * 0w13 + r * 0w17 + c
- local
- fun textStep (c, h) = h * 0w33 + fromInt (ord c)
- in
- fun text s = String.foldl textStep 0w5381 s
- end
- end
+ structure W = Word32
+ fun unary c h : W.t = h * 0w19 + c
+ fun binary c (l, r) : W.t = l * 0w13 + r * 0w17 + c
+
structure TypeHashRep = LayerRep
(open Arg
- structure Rep = MkClosedRep (type 'a t = Word32.t))
+ structure Rep = MkClosedRep (type 'a t = W.t))
val typeHash = TypeHashRep.This.getT
@@ -34,21 +27,21 @@
val op *` = binary 0wx00ADB6DB
val T = unary 0wx00B6DB6B
- fun R l = unary (text (Generics.Label.toString l))
+ fun R l = unary (Generics.Label.hash l)
val tuple = unary 0wx00DB6DB5
val record = unary 0wx01B6DB55
val op +` = binary 0wx02DB6D4D
- val unit = 0wx036DB6C5 : Word32.t
- val C0 = text o Generics.Con.toString
- fun C1 c = unary (text (Generics.Con.toString c))
+ val unit = 0wx036DB6C5 : W.t
+ val C0 = Generics.Con.hash
+ fun C1 c = unary (Generics.Con.hash c)
val data = unary 0wx04DB6D63
- val Y = Tie.id (0wx05B6DB51 : Word32.t)
+ val Y = Tie.id (0wx05B6DB51 : W.t)
val op --> = binary 0wx06DB6D61
- val exn = 0wx08DB6B69 : Word32.t
+ val exn = 0wx08DB6B69 : W.t
fun regExn0 _ _ = ()
fun regExn1 _ _ _ = ()
@@ -59,26 +52,26 @@
val array = unary 0wx0B6DB651
val refc = unary 0wx0CDB6D51
- val fixedInt = 0wx0DB6DAA1 : Word32.t
- val largeInt = 0wx1B6DB541 : Word32.t
+ val fixedInt = 0wx0DB6DAA1 : W.t
+ val largeInt = 0wx1B6DB541 : W.t
- val largeReal = 0wx2DB6D851 : Word32.t
- val largeWord = 0wx36DB6D01 : Word32.t
+ val largeReal = 0wx2DB6D851 : W.t
+ val largeWord = 0wx36DB6D01 : W.t
- val bool = 0wx4DB6DA41 : Word32.t
- val char = 0wx5B6DB085 : Word32.t
- val int = 0wx6DB6D405 : Word32.t
- val real = 0wx8DB6D605 : Word32.t
- val string = 0wx9B6DB141 : Word32.t
- val word = 0wxADB6D441 : Word32.t
+ val bool = 0wx4DB6DA41 : W.t
+ val char = 0wx5B6DB085 : W.t
+ val int = 0wx6DB6D405 : W.t
+ val real = 0wx8DB6D605 : W.t
+ val string = 0wx9B6DB141 : W.t
+ val word = 0wxADB6D441 : W.t
- val word8 = 0wxB6DB6809 : Word32.t
- val word32 = 0wxCDB6D501 : Word32.t
+ val word8 = 0wxB6DB6809 : W.t
+ val word32 = 0wxCDB6D501 : W.t
(*
- val word64 = 0wxDB6DB101 : Word32.t
+ val word64 = 0wxDB6DB101 : W.t
*)
- fun hole () = 0w0 : Word32.t
+ fun hole () = 0w0 : W.t
open Arg TypeHashRep)
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/extra/generic-extra.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/extra/generic-extra.sig 2008-02-04 14:10:30 UTC (rev 6373)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/extra/generic-extra.sig 2008-02-04 14:43:26 UTC (rev 6374)
@@ -1,4 +1,4 @@
-(* Copyright (C) 2007 SSH Communications Security, Helsinki, Finland
+(* Copyright (C) 2007-2008 SSH Communications Security, Helsinki, Finland
*
* This code is released under the MLton license, a BSD-style license.
* See the LICENSE file or http://mlton.org/License for details.
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/framework/generics.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/framework/generics.sig 2008-02-04 14:10:30 UTC (rev 6373)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/framework/generics.sig 2008-02-04 14:43:26 UTC (rev 6374)
@@ -1,4 +1,4 @@
-(* Copyright (C) 2007 SSH Communications Security, Helsinki, Finland
+(* Copyright (C) 2007-2008 SSH Communications Security, Helsinki, Finland
*
* This code is released under the MLton license, a BSD-style license.
* See the LICENSE file or http://mlton.org/License for details.
@@ -11,11 +11,13 @@
structure Label : sig
eqtype t
val toString : t -> String.t
+ val hash : t -> Word32.t
end
structure Con : sig
eqtype t
val toString : t -> String.t
+ val hash : t -> Word32.t
end
structure Record : T
More information about the MLton-commit
mailing list