basis/checksums/wyhash/wyhash.factor

   1 ! Copyright (C) 2021 John Benediktsson
   2 ! See http://factorcode.org/license.txt for BSD license
   3
   4 USING: accessors alien.c-types alien.data byte-arrays checksums
   5 endian grouping kernel literals math math.bitwise math.order
   6 sequences sequences.generalizations sequences.private
   7 specialized-arrays ;
   8 SPECIALIZED-ARRAY: uint64_t
   9 IN: checksums.wyhash
  10
  11 <PRIVATE
  12
  13 :: wymum ( a b -- a' b' )
  14     a -32 shift 32 bits :> Ha
  15     b -32 shift 32 bits :> Hb
  16     a 32 bits :> La
  17     b 32 bits :> Lb
  18     Ha Hb W* :> RH
  19     Ha Lb W* :> RM0
  20     Hb La W* :> RM1
  21     La Lb W* :> RL
  22
  23     RL RM0 32 shift W+ :> T
  24     T RM1 32 shift W+ :> LO
  25     T RL < 1 0 ? LO T < 1 0 ? W+ :> C
  26     RH RM0 -32 shift W+ RM1 -32 shift W+ C W+ :> HI
  27
  28     LO HI ;
  29
  30 : wymix ( a b -- c )
  31     wymum bitxor ;
  32
  33 CONSTANT: P0 0xa0761d6478bd642f
  34 CONSTANT: P1 0xe7037ed1a0b428db
  35 CONSTANT: P2 0x8ebc6af09c88c6e3
  36 CONSTANT: P3 0x589965cc75374cc3
  37
  38 : wyrand ( seed -- seed' rand )
  39     P0 W+ dup dup P1 bitxor wymix ;
  40
  41 : wyhash64 ( a b -- c )
  42     [ P0 bitxor ] [ P1 bitxor ] bi* wymum
  43     [ P0 bitxor ] [ P1 bitxor ] bi* wymix ;
  44
  45 : wy2u01 ( r -- [0,1) )
  46     -12 shift 0x1.0p-52 * ;
  47
  48 : wy2gau ( r -- gaussian )
  49     [ ] [ -21 shift ] [ -42 shift ] tri
  50     [ 0x1fffff bitand ] tri@ + + 0x1.0p-20 * 3.0 - ;
  51
  52 :: native-mapper ( from to bytes c-type -- seq )
  53     from to bytes <slice>
  54     bytes byte-array? little-endian? and
  55     [ c-type cast-array ]
  56     [ c-type heap-size <groups> [ le> ] map ] if ; inline
  57
  58 PRIVATE>
  59
  60 TUPLE: wyhash seed ;
  61
  62 C: <wyhash> wyhash
  63
  64 M:: wyhash checksum-bytes ( bytes checksum -- value )
  65
  66     checksum seed>> P0 bitxor :> seed!
  67     bytes length :> len
  68
  69     len 16 <= [
  70         len 8 <= [
  71             len 4 >= [
  72                 bytes [ 4 head-slice ] [ 4 tail-slice* ] bi [ le> ] bi@
  73             ] [
  74                 len 0 > [
  75                     0 bytes nth 16 shift
  76                     len 2/ bytes nth 8 shift bitor
  77                     len 1 - bytes nth bitor
  78                     0
  79                 ] [
  80                     0 0
  81                 ] if
  82             ] if
  83         ] [
  84             bytes [ 8 head-slice ] [ 8 tail-slice* ] bi [ le> ] bi@
  85         ] if
  86     ] [
  87
  88         len 1 - dup 48 mod - :> len/48
  89         len 1 - dup 16 mod - :> len/16
  90
  91         0 len/48 bytes uint64_t native-mapper [
  92             seed :> see1!
  93             seed :> see2!
  94             6 <groups> [
  95                 6 firstn-unsafe :> ( n0 n1 n2 n3 n4 n5 )
  96                 n0 P1 bitxor n1 seed bitxor wymix seed!
  97                 n2 P2 bitxor n3 see1 bitxor wymix see1!
  98                 n4 P3 bitxor n5 see2 bitxor wymix see2!
  99             ] each
 100             see1 see2 bitxor seed bitxor seed!
 101         ] unless-empty
 102
 103         len/48 len/16 bytes uint64_t native-mapper [
 104             2 <groups> [
 105                 first2-unsafe :> ( n0 n1 )
 106                 n0 P1 bitxor n1 seed bitxor wymix seed!
 107             ] each
 108         ] unless-empty
 109
 110         len 16 - len bytes uint64_t native-mapper first2
 111
 112     ] if :> ( a b )
 113
 114     len P1 bitxor a P1 bitxor b seed bitxor wymix wymix ;