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