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