diff --git a/cbits/Makefile b/cbits/Makefile new file mode 100644 --- /dev/null +++ b/cbits/Makefile @@ -0,0 +1,14 @@ +check: default.c common.c check.c sse-42.c + @echo "Testing portable version..." + @gcc -o check -O3 default.c common.c check.c + @./check + @rm check + + @echo + @echo "Testing SSE 4.2 version..." + @gcc -o check -O3 -msse4.2 sse-42.c common.c check.c sse-42-check.c + @./check + @rm check + +clean: + rm -f *.o check diff --git a/cbits/check.c b/cbits/check.c new file mode 100644 --- /dev/null +++ b/cbits/check.c @@ -0,0 +1,185 @@ +#include +#include +#include "defs.h" + +static const int NUMH = 64 / sizeof(small_hash_t); + +static small_hash_t t_sevens[32] = + { 7,7,7,7,7,7,7,7, + 7,7,7,7,7,7,7,7, + 7,7,7,7,7,7,7,7, + 7,7,7,7,7,7,7,7 }; + +static small_hash_t t_zeroes[32] = + { 0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0 }; + +static small_hash_t t_mixed[32] = + { 7,1,7,7,2,7,7,7, + 7,7,3,7,7,7,7,7, + 7,7,7,7,1,7,7,7, + 7,7,7,7,3,7,7,9 }; + +static int num_tests = 0; +static int num_errors = 0; + +void CHECK(int actual, int expected, char* what) { + ++num_tests; + if (actual != expected) { + fprintf(stderr, "%s: expected %d, got %d\n", what, expected, actual); + + ++num_errors; + } +} + + +void check_forward_search_2() { + /* forward_search_2 */ + /* - offset zero */ + CHECK(forward_search_2(t_sevens, 0, NUMH, 0, 7 ), 0, "fs2-sevens-ok-1" ); + CHECK(forward_search_2(t_sevens, 0, NUMH, 7, 0 ), 0, "fs2-sevens-ok-2" ); + CHECK(forward_search_2(t_sevens, 0, NUMH, 7, 7 ), 0, "fs2-sevens-ok-3" ); + CHECK(forward_search_2(t_sevens, 0, NUMH, 3, 0 ), -1, "fs2-sevens-fail-1"); + CHECK(forward_search_2(t_zeroes, 0, NUMH, 0, 1 ), 0, "fs2-zeroes-ok-1" ); + CHECK(forward_search_2(t_zeroes, 0, NUMH, 2, 0 ), 0, "fs2-zeroes-ok-2" ); + CHECK(forward_search_2(t_zeroes, 0, NUMH, 2, 0xf0), -1, "fs2-zeroes-fail-1"); + + /* - offset 5 */ + CHECK(forward_search_2(t_sevens, 5, NUMH, 0, 7), 5, "fs2-o-sevens-ok-1" ); + CHECK(forward_search_2(t_sevens, 5, NUMH, 7, 0), 5, "fs2-o-sevens-ok-2" ); + CHECK(forward_search_2(t_sevens, 5, NUMH, 7, 7), 5, "fs2-o-sevens-ok-3" ); + CHECK(forward_search_2(t_sevens, 5, NUMH, 3, 0), -1, "fs2-o-sevens-fail-1"); + CHECK(forward_search_2(t_zeroes, 5, NUMH, 0, 1), 5, "fs2-o-zeroes-ok-1" ); + CHECK(forward_search_2(t_zeroes, 5, NUMH, 2, 0), 5, "fs2-o-zeroes-ok-2" ); + CHECK(forward_search_2(t_zeroes, 5, NUMH, 2, 0xf0), -1, "fs2-o-zeroes-fail-1"); + + /* - mixed, offset zero */ + CHECK(forward_search_2(t_mixed, 0, NUMH, 2, 0xf0), 4, "fs2-mixed-ok-1" ); + CHECK(forward_search_2(t_mixed, 0, NUMH, 4, 0xf0), -1, "fs2-mixed-fail-1"); + CHECK(forward_search_2(t_mixed, 0, NUMH, 2, 1), 1, "fs2-mixed-ok-2" ); + CHECK(forward_search_2(t_mixed, 0, NUMH, 2, 7), 0, "fs2-mixed-ok-3" ); + CHECK(forward_search_2(t_mixed, 0, NUMH, 2, 3), 4, "fs2-mixed-ok-4" ); + CHECK(forward_search_2(t_mixed, 0, NUMH, 9, 3), 10, "fs2-mixed-ok-5" ); + CHECK(forward_search_2(t_mixed, 0, NUMH, 3, 9), 10, "fs2-mixed-ok-5" ); + CHECK(forward_search_2(t_mixed, 0, NUMH, 8, 9), 31, "fs2-mixed-ok-6" ); + + /* - mixed, offset 16 */ + CHECK(forward_search_2(t_mixed, 16, NUMH, 2, 0xf0), 4, "fs2-o-mixed-ok-1" ); + CHECK(forward_search_2(t_mixed, 16, NUMH, 4, 0xf0), -1, "fs2-o-mixed-fail-1"); + CHECK(forward_search_2(t_mixed, 16, NUMH, 2, 1), 20, "fs2-o-mixed-ok-2" ); + CHECK(forward_search_2(t_mixed, 16, NUMH, 2, 7), 16, "fs2-o-mixed-ok-3" ); + CHECK(forward_search_2(t_mixed, 16, NUMH, 2, 3), 28, "fs2-o-mixed-ok-4" ); + CHECK(forward_search_2(t_mixed, 16, NUMH, 9, 3), 28, "fs2-o-mixed-ok-5" ); + CHECK(forward_search_2(t_mixed, 16, NUMH, 3, 9), 28, "fs2-o-mixed-ok-5" ); + CHECK(forward_search_2(t_mixed, 16, NUMH, 8, 9), 31, "fs2-o-mixed-ok-6" ); +} + +void check_forward_search_3() { + /* forward_search_3 */ + /* - offset zero */ + CHECK(forward_search_3(t_sevens, 0, NUMH, 0, 7, 88), 0, "fs3-sevens-ok-1" ); + CHECK(forward_search_3(t_sevens, 0, NUMH, 7, 0, 88), 0, "fs3-sevens-ok-2" ); + CHECK(forward_search_3(t_sevens, 0, NUMH, 7, 7, 88), 0, "fs3-sevens-ok-3" ); + CHECK(forward_search_3(t_sevens, 0, NUMH, 3, 0, 88), -1, "fs3-sevens-fail-1"); + CHECK(forward_search_3(t_zeroes, 0, NUMH, 0, 1, 88), 0, "fs3-zeroes-ok-1" ); + CHECK(forward_search_3(t_zeroes, 0, NUMH, 2, 0, 88), 0, "fs3-zeroes-ok-2" ); + CHECK(forward_search_3(t_zeroes, 0, NUMH, 2, 11, 0 ), 0, "fs3-zeroes-ok-3" ); + CHECK(forward_search_3(t_zeroes, 0, NUMH, 2, 32, 88), -1, "fs3-zeroes-fail-1"); + + /* - offset 5 */ + CHECK(forward_search_3(t_sevens, 5, NUMH, 0, 7, 7 ), 5, "fs3-o-sevens-ok-1" ); + CHECK(forward_search_3(t_sevens, 5, NUMH, 7, 0, 21), 5, "fs3-o-sevens-ok-2" ); + CHECK(forward_search_3(t_sevens, 5, NUMH, 7, 7, 21), 5, "fs3-o-sevens-ok-3" ); + CHECK(forward_search_3(t_sevens, 5, NUMH, 3, 0, 21), -1, "fs3-o-sevens-fail-1"); + CHECK(forward_search_3(t_zeroes, 5, NUMH, 0, 1, 21), 5, "fs3-o-zeroes-ok-1" ); + CHECK(forward_search_3(t_zeroes, 5, NUMH, 2, 0, 21), 5, "fs3-o-zeroes-ok-2" ); + CHECK(forward_search_3(t_zeroes, 5, NUMH, 2, 0xf0, 21), -1, "fs3-o-zeroes-fail-1"); + + /* - mixed, offset zero */ + CHECK(forward_search_3(t_mixed, 0, NUMH, 2, 0xf0, -1), 4, "fs3-mixed-ok-1" ); + CHECK(forward_search_3(t_mixed, 0, NUMH, 4, 0xf0, -1), -1, "fs3-mixed-fail-1"); + CHECK(forward_search_3(t_mixed, 0, NUMH, 2, 1, -1), 1, "fs3-mixed-ok-2" ); + CHECK(forward_search_3(t_mixed, 0, NUMH, 2, 7, -1), 0, "fs3-mixed-ok-3" ); + CHECK(forward_search_3(t_mixed, 0, NUMH, 2, 3, -1), 4, "fs3-mixed-ok-4" ); + CHECK(forward_search_3(t_mixed, 0, NUMH, 9, 3, -1), 10, "fs3-mixed-ok-5" ); + CHECK(forward_search_3(t_mixed, 0, NUMH, 3, 9, -1), 10, "fs3-mixed-ok-5" ); + CHECK(forward_search_3(t_mixed, 0, NUMH, 8, 9, -1), 31, "fs3-mixed-ok-6" ); + + /* - mixed, offset 16 */ + CHECK(forward_search_3(t_mixed, 16, NUMH, 2, 96, 33), 4, "fs3-o-mixed-ok-1" ); + CHECK(forward_search_3(t_mixed, 16, NUMH, 4, 96, 33), -1, "fs3-o-mixed-fail-1"); + CHECK(forward_search_3(t_mixed, 16, NUMH, 2, 1, 33), 20, "fs3-o-mixed-ok-2" ); + CHECK(forward_search_3(t_mixed, 16, NUMH, 2, 7, 33), 16, "fs3-o-mixed-ok-3" ); + CHECK(forward_search_3(t_mixed, 16, NUMH, 2, 3, 33), 28, "fs3-o-mixed-ok-4" ); + CHECK(forward_search_3(t_mixed, 16, NUMH, 9, 3, 33), 28, "fs3-o-mixed-ok-5" ); + CHECK(forward_search_3(t_mixed, 16, NUMH, 3, 9, 33), 28, "fs3-o-mixed-ok-5" ); + CHECK(forward_search_3(t_mixed, 16, NUMH, 8, 9, 33), 31, "fs3-o-mixed-ok-6" ); + CHECK(forward_search_3(t_mixed, 16, NUMH, 8, 33, 9 ), 31, "fs3-o-mixed-ok-7" ); +} + +void check_line_search() { + CHECK(line_search(t_sevens, 0, 7), 0, "ls-7s-ok-1"); + CHECK(line_search(t_sevens, 5, 7), 5, "ls-7s-ok-2"); + CHECK(line_search(t_sevens, 31, 7), 31, "ls-7s-ok-3"); + CHECK(line_search(t_sevens, 0, 1), -1, "ls-7s-fail-1"); + CHECK(line_search(t_sevens, 31, 1), -1, "ls-7s-fail-2"); + + CHECK(line_search(t_mixed, 0, 7), 0, "ls-m-ok-1"); + CHECK(line_search(t_mixed, 0, 1), 1, "ls-m-ok-2"); + CHECK(line_search(t_mixed, 1, 7), 2, "ls-m-ok-3"); + CHECK(line_search(t_mixed, 0, 9), 31, "ls-m-ok-4"); + CHECK(line_search(t_mixed, 0, 8), -1, "ls-m-fail-1"); + + CHECK(line_search(t_mixed, 16, 1), 20, "ls-m-ok-5"); +} + +void check_line_search_2() { + CHECK(line_search_2(t_sevens, 0, 7, 3), 0, "ls2-7s-ok-1"); + CHECK(line_search_2(t_sevens, 5, 7, 9), 5, "ls2-7s-ok-2"); + CHECK(line_search_2(t_sevens, 31, 0, 7), 31, "ls2-7s-ok-3"); + CHECK(line_search_2(t_sevens, 0, 1, 3), -1, "ls2-7s-fail-1"); + CHECK(line_search_2(t_sevens, 31, 6, 1), -1, "ls2-7s-fail-2"); + + CHECK(line_search_2(t_mixed, 0, 7, 9), 0, "ls2-m-ok-1"); + CHECK(line_search_2(t_mixed, 0, 9, 1), 1, "ls2-m-ok-2"); + CHECK(line_search_2(t_mixed, 1, 7, 9), 2, "ls2-m-ok-3"); + CHECK(line_search_2(t_mixed, 0, 8, 9), 31, "ls2-m-ok-4"); + CHECK(line_search_2(t_mixed, 0, 8, 4), -1, "ls2-m-fail-1"); + + CHECK(line_search_2(t_mixed, 16, 3, 1), 20, "ls2-m-ok-5"); +} + +void check_line_search_3() { + CHECK(line_search_3(t_sevens, 0, 4, 7, 3), 0, "ls2-7s-ok-1"); + CHECK(line_search_3(t_sevens, 5, 7, 4, 9), 5, "ls2-7s-ok-2"); + CHECK(line_search_3(t_sevens, 31, 0, 7, 4), 31, "ls2-7s-ok-3"); + CHECK(line_search_3(t_sevens, 0, 1, 4, 3), -1, "ls2-7s-fail-1"); + CHECK(line_search_3(t_sevens, 31, 4, 6, 1), -1, "ls2-7s-fail-2"); + + CHECK(line_search_3(t_mixed, 0, 4, 7, 9), 0, "ls2-m-ok-1"); + CHECK(line_search_3(t_mixed, 0, 9, 4, 1), 1, "ls2-m-ok-2"); + CHECK(line_search_3(t_mixed, 1, 7, 9, 4), 2, "ls2-m-ok-3"); + CHECK(line_search_3(t_mixed, 0, 8, 4, 9), 31, "ls2-m-ok-4"); + CHECK(line_search_3(t_mixed, 0, 8, 4, 6), -1, "ls2-m-fail-1"); + + CHECK(line_search_3(t_mixed, 16, 3, 1, 6), 20, "ls2-m-ok-5"); +} + + +int main() { + check_forward_search_2(); + check_forward_search_3(); + check_line_search(); + check_line_search_2(); + check_line_search_3(); + check_impl_specific(); + + if (num_errors > 0) { + printf("\n*** %d/%d tests failed.\n", num_errors, num_tests); + } else { + printf("All %d tests passed.\n", num_tests); + } + exit(num_errors < 255 ? num_errors : 255); +} diff --git a/cbits/common.c b/cbits/common.c new file mode 100644 --- /dev/null +++ b/cbits/common.c @@ -0,0 +1,83 @@ +#include "defs.h" + +#ifdef WIN32 +#include +#else +#include +#include +#endif + +#include + +void suicide(volatile int* check, int t) { + int secs = (3*t + 999999) / 1000000; + if (secs < 1) secs = 1; +#ifdef WIN32 + Sleep(secs * 1000); +#else + sleep(secs); +#endif + if (*check) { + printf("timeout expired, dying!!\n"); +#ifdef WIN32 + abort(); +#else + raise(SIGKILL); +#endif + } +} + +#if defined(__GNUC__) +#define PREFETCH_READ(x) (__builtin_prefetch(x, 0, 3)) +#define PREFETCH_WRITE(x) (__builtin_prefetch(x, 1, 3)) +#else +#define PREFETCH_READ(x) +#define PREFETCH_WRITE(x) +#endif + +void prefetch_cacheline_read(small_hash_t* line, int start) +{ + PREFETCH_READ((void*)(&line[start])); +} + +void prefetch_cacheline_write(small_hash_t* line, int start) +{ + PREFETCH_WRITE((void*)(&line[start])); +} + +int forward_search_2(small_hash_t* array, int start, int end, + small_hash_t x1, small_hash_t x2) { + small_hash_t* ep = array + end; + small_hash_t* p = array + start; + int wrapped = 0; + while (1) { + if (p >= ep) { + if (wrapped) return -1; + ep = array + start; + p = array; + wrapped = 1; + continue; + } + if (*p == x1 || *p == x2) return p - array; + ++p; + } +} + +int forward_search_3(small_hash_t* array, int start, int end, + small_hash_t x1, small_hash_t x2, small_hash_t x3) { + small_hash_t* ep = array + end; + small_hash_t* p = array + start; + int wrapped = 0; + while (1) { + if (p >= ep) { + if (wrapped) return -1; + ep = array + start; + p = array; + wrapped = 1; + continue; + } + if (*p == x1 || *p == x2 || *p == x3) return p - array; + ++p; + } +} + diff --git a/cbits/default.c b/cbits/default.c new file mode 100644 --- /dev/null +++ b/cbits/default.c @@ -0,0 +1,203 @@ +// Specialized i686 versions of the cache line search functions. + +#include "defs.h" + +static inline int32_t mask(int32_t a, int32_t b) { return -(a == b); } + +#if defined(__GNUC__) +static inline int32_t first_bit_set(int32_t a) { + return __builtin_ffs(a) - 1; +} +#else +static uint8_t de_bruijn_table[] = { + 0, 1, 28, 2, 29, 14, 24, 3, 30, 22, 20, 15, 25, 17, 4, 8, + 31, 27, 13, 23, 21, 19, 16, 7, 26, 12, 18, 6, 11, 5, 10, 9 +}; + +static inline int32_t first_bit_set(int32_t a) { + int32_t zero_case = mask(0, a); + uint32_t x = (uint32_t) (a & -a); + x *= 0x077CB531; + x >>= 27; + return zero_case | de_bruijn_table[x]; +} +#endif + +static inline uint32_t line_mask(small_hash_t* array, int start, + small_hash_t x1) { + small_hash_t* p = array + start; + uint32_t m1 = 0; + uint32_t m2 = 0; + uint32_t m3 = 0; + int offset = start & 0x1f; + +#define M (mask(*p, x1)) + + switch (offset) { + case 0: m1 |= M & 0x1; ++p; + case 1: m2 |= M & 0x2; ++p; + case 2: m3 |= M & 0x4; ++p; + case 3: m1 |= M & 0x8; ++p; + case 4: m2 |= M & 0x10; ++p; + case 5: m3 |= M & 0x20; ++p; + case 6: m1 |= M & 0x40; ++p; + case 7: m2 |= M & 0x80; ++p; + case 8: m3 |= M & 0x100; ++p; + case 9: m1 |= M & 0x200; ++p; + case 10: m2 |= M & 0x400; ++p; + case 11: m3 |= M & 0x800; ++p; + case 12: m1 |= M & 0x1000; ++p; + case 13: m2 |= M & 0x2000; ++p; + case 14: m3 |= M & 0x4000; ++p; + case 15: m1 |= M & 0x8000; ++p; + case 16: m2 |= M & 0x10000; ++p; + case 17: m3 |= M & 0x20000; ++p; + case 18: m1 |= M & 0x40000; ++p; + case 19: m2 |= M & 0x80000; ++p; + case 20: m3 |= M & 0x100000; ++p; + case 21: m1 |= M & 0x200000; ++p; + case 22: m2 |= M & 0x400000; ++p; + case 23: m3 |= M & 0x800000; ++p; + case 24: m1 |= M & 0x1000000; ++p; + case 25: m2 |= M & 0x2000000; ++p; + case 26: m3 |= M & 0x4000000; ++p; + case 27: m1 |= M & 0x8000000; ++p; + case 28: m2 |= M & 0x10000000; ++p; + case 29: m3 |= M & 0x20000000; ++p; + case 30: m1 |= M & 0x40000000; ++p; + case 31: m2 |= M & 0x80000000; ++p; + } + +#undef M + + return (m1 | m2 | m3) >> offset; +} + +static inline uint32_t line_mask_2(small_hash_t* array, int start, + small_hash_t x1, small_hash_t x2) { + small_hash_t* p = array + start; + uint32_t m1 = 0; + uint32_t m2 = 0; + uint32_t m3 = 0; + int offset = start & 0x1f; + +#define M (mask(*p, x1) | mask(*p, x2)) + + switch (offset) { + case 0: m1 |= M & 0x1; ++p; + case 1: m2 |= M & 0x2; ++p; + case 2: m3 |= M & 0x4; ++p; + case 3: m1 |= M & 0x8; ++p; + case 4: m2 |= M & 0x10; ++p; + case 5: m3 |= M & 0x20; ++p; + case 6: m1 |= M & 0x40; ++p; + case 7: m2 |= M & 0x80; ++p; + case 8: m3 |= M & 0x100; ++p; + case 9: m1 |= M & 0x200; ++p; + case 10: m2 |= M & 0x400; ++p; + case 11: m3 |= M & 0x800; ++p; + case 12: m1 |= M & 0x1000; ++p; + case 13: m2 |= M & 0x2000; ++p; + case 14: m3 |= M & 0x4000; ++p; + case 15: m1 |= M & 0x8000; ++p; + case 16: m2 |= M & 0x10000; ++p; + case 17: m3 |= M & 0x20000; ++p; + case 18: m1 |= M & 0x40000; ++p; + case 19: m2 |= M & 0x80000; ++p; + case 20: m3 |= M & 0x100000; ++p; + case 21: m1 |= M & 0x200000; ++p; + case 22: m2 |= M & 0x400000; ++p; + case 23: m3 |= M & 0x800000; ++p; + case 24: m1 |= M & 0x1000000; ++p; + case 25: m2 |= M & 0x2000000; ++p; + case 26: m3 |= M & 0x4000000; ++p; + case 27: m1 |= M & 0x8000000; ++p; + case 28: m2 |= M & 0x10000000; ++p; + case 29: m3 |= M & 0x20000000; ++p; + case 30: m1 |= M & 0x40000000; ++p; + case 31: m2 |= M & 0x80000000; ++p; + } + +#undef M + + return (m1 | m2 | m3) >> offset; +} + +static inline uint32_t line_mask_3(small_hash_t* array, int start, + small_hash_t x1, small_hash_t x2, + small_hash_t x3) { + small_hash_t* p = array + start; + uint32_t m1 = 0; + uint32_t m2 = 0; + uint32_t m3 = 0; + int offset = start & 0x1f; + +#define M (mask(*p, x1) | mask(*p, x2) | mask(*p, x3)) + + switch (offset) { + case 0: m1 |= M & 0x1; ++p; + case 1: m2 |= M & 0x2; ++p; + case 2: m3 |= M & 0x4; ++p; + case 3: m1 |= M & 0x8; ++p; + case 4: m2 |= M & 0x10; ++p; + case 5: m3 |= M & 0x20; ++p; + case 6: m1 |= M & 0x40; ++p; + case 7: m2 |= M & 0x80; ++p; + case 8: m3 |= M & 0x100; ++p; + case 9: m1 |= M & 0x200; ++p; + case 10: m2 |= M & 0x400; ++p; + case 11: m3 |= M & 0x800; ++p; + case 12: m1 |= M & 0x1000; ++p; + case 13: m2 |= M & 0x2000; ++p; + case 14: m3 |= M & 0x4000; ++p; + case 15: m1 |= M & 0x8000; ++p; + case 16: m2 |= M & 0x10000; ++p; + case 17: m3 |= M & 0x20000; ++p; + case 18: m1 |= M & 0x40000; ++p; + case 19: m2 |= M & 0x80000; ++p; + case 20: m3 |= M & 0x100000; ++p; + case 21: m1 |= M & 0x200000; ++p; + case 22: m2 |= M & 0x400000; ++p; + case 23: m3 |= M & 0x800000; ++p; + case 24: m1 |= M & 0x1000000; ++p; + case 25: m2 |= M & 0x2000000; ++p; + case 26: m3 |= M & 0x4000000; ++p; + case 27: m1 |= M & 0x8000000; ++p; + case 28: m2 |= M & 0x10000000; ++p; + case 29: m3 |= M & 0x20000000; ++p; + case 30: m1 |= M & 0x40000000; ++p; + case 31: m2 |= M & 0x80000000; ++p; + } +#undef M + + return (m1 | m2 | m3) >> offset; +} + + +static inline int32_t line_result(uint32_t m, int start) { + int32_t p = first_bit_set((int32_t) m); + int32_t mm = mask(p, -1); + return mm | (start + p); +} + + +int line_search(small_hash_t* array, int start, small_hash_t x1) { + uint32_t m = line_mask(array, start, x1); + return line_result(m, start); +} + +int line_search_2(small_hash_t* array, int start, small_hash_t x1, + small_hash_t x2) { + uint32_t m = line_mask_2(array, start, x1, x2); + return line_result(m, start); +} + +int line_search_3(small_hash_t* array, int start, small_hash_t x1, + small_hash_t x2, small_hash_t x3) { + uint32_t m = line_mask_3(array, start, x1, x2, x3); + return line_result(m, start); +} + +void check_impl_specific(int* num_tests, int* num_errors) { + +} diff --git a/cbits/defs.h b/cbits/defs.h new file mode 100644 --- /dev/null +++ b/cbits/defs.h @@ -0,0 +1,35 @@ +#ifndef HASHTABLES_DEFS_H +#define HASHTABLES_DEFS_H + +#include +#include + +typedef uintptr_t full_hash_t; +typedef uint16_t small_hash_t; + +void prefetch_cacheline_write(small_hash_t* line, int start); +void prefetch_cacheline_read(small_hash_t* line, int start); + +int forward_search_2(small_hash_t* array, + int start, + int end, + small_hash_t x1, + small_hash_t x2); +int forward_search_3(small_hash_t* array, + int start, + int end, + small_hash_t x1, + small_hash_t x2, + small_hash_t x3); + +int line_search(small_hash_t* array, int start, small_hash_t x1); +int line_search_2(small_hash_t* array, int start, small_hash_t x1, + small_hash_t x2); +int line_search_3(small_hash_t* array, int start, small_hash_t x1, + small_hash_t x2, small_hash_t x3); +void suicide(volatile int* check, int i); + +void CHECK(int actual, int expected, char* what); +void check_impl_specific(); + +#endif /* HASHTABLES_DEFS_H */ diff --git a/cbits/sse-42-check.c b/cbits/sse-42-check.c new file mode 100644 --- /dev/null +++ b/cbits/sse-42-check.c @@ -0,0 +1,38 @@ +#include "defs.h" + +#include +#include + +extern __m128i fill(small_hash_t v); + +static void check_fill(small_hash_t v) { + int i; + char buf[256]; + small_hash_t v2; + + __m128i x = fill(v); + +#define F(i) do { \ + v2 = _mm_extract_epi16(x, i); \ + sprintf(buf, "fill-%x-%d-of-8", (int) v, i+1); \ + CHECK(v2, v, buf); \ + } while(0); + + F(0); + F(1); + F(2); + F(3); + F(4); + F(5); + F(6); + F(7); +#undef F +} + +void check_impl_specific() { + check_fill(0); + check_fill((small_hash_t) (-1)); + check_fill((small_hash_t) (-5)); + check_fill(7); + check_fill(0xff); +} diff --git a/cbits/sse-42.c b/cbits/sse-42.c new file mode 100644 --- /dev/null +++ b/cbits/sse-42.c @@ -0,0 +1,172 @@ +#include "defs.h" + +#include +#include + +/* Straight-line branchless SSE 4.2 code for searching an array of uint16_t + hash codes. */ + +static inline int32_t mask(int32_t a, int32_t b) { return -(a == b); } + +#if defined(__GNUC__) +static inline int32_t first_bit_set(int32_t a) { + return __builtin_ffs(a) - 1; +} +#else +static uint8_t de_bruijn_table[] = { + 0, 1, 28, 2, 29, 14, 24, 3, 30, 22, 20, 15, 25, 17, 4, 8, + 31, 27, 13, 23, 21, 19, 16, 7, 26, 12, 18, 6, 11, 5, 10, 9 +}; + +static inline int32_t first_bit_set(int32_t a) { + int32_t zero_case = mask(0, a); + uint32_t x = (uint32_t) (a & -a); + x *= 0x077CB531; + x >>= 27; + return zero_case | de_bruijn_table[x]; +} +#endif + +static inline __m128i fill(small_hash_t v) { + int32_t v1 = (((int)v) << 16) | v; + __m128i x = _mm_cvtsi32_si128(0); + x = _mm_insert_epi32(x, v1, 0); + return _mm_shuffle_epi32(x, _MM_SHUFFLE(0,0,0,0)); +} + +#ifndef SIDD_UWORD_OPS +#define SIDD_UWORD_OPS _SIDD_UWORD_OPS +#endif + +#ifndef SIDD_CMP_EQUAL_EACH +#define SIDD_CMP_EQUAL_EACH _SIDD_CMP_EQUAL_EACH +#endif + +#ifndef SIDD_BIT_MASK +#define SIDD_BIT_MASK _SIDD_BIT_MASK +#endif + +#define _MODE (SIDD_UWORD_OPS | SIDD_CMP_EQUAL_EACH) + +static inline __m128i cmp_mask(__m128i a, __m128i b) { + const int mode = SIDD_UWORD_OPS | SIDD_CMP_EQUAL_EACH | SIDD_BIT_MASK; + return _mm_cmpistrm(a, b, mode); +} + +static inline int32_t line_result(uint32_t m, int start) { + int32_t p = first_bit_set((int32_t) m); + int32_t mm = mask(p, -1); + return mm | (start + p); +} + +#define DUMP(xval) do { \ + uint16_t xval##_x0 = _mm_extract_epi16(xval, 0); \ + uint16_t xval##_x1 = _mm_extract_epi16(xval, 1); \ + uint16_t xval##_x2 = _mm_extract_epi16(xval, 2); \ + uint16_t xval##_x3 = _mm_extract_epi16(xval, 3); \ + uint16_t xval##_x4 = _mm_extract_epi16(xval, 4); \ + uint16_t xval##_x5 = _mm_extract_epi16(xval, 5); \ + uint16_t xval##_x6 = _mm_extract_epi16(xval, 6); \ + uint16_t xval##_x7 = _mm_extract_epi16(xval, 7); \ + printf(" % 10s: %04x-%04x-%04x-%04x-%04x-%04x-%04x-%04x\n", \ + #xval, xval##_x0, xval##_x1, xval##_x2, xval##_x3, \ + xval##_x4, xval##_x5, xval##_x6, xval##_x7); \ + } while(0); + + +int line_search(small_hash_t* array, int start0, small_hash_t v1) { + int offset = start0 & 31; + int start = start0 & ~31; + __m128i* p = (__m128i*) &array[start]; + __m128i x1, val1, val2, val3, val4; + __m128i m1, m2, m3, m4, dmask; + + x1 = fill(v1); + + val1 = *p++; + m1 = cmp_mask(x1, val1); + val2 = *p++; + m2 = _mm_slli_si128(cmp_mask(x1, val2), 1); + val3 = *p++; + m3 = _mm_slli_si128(cmp_mask(x1, val3), 2); + val4 = *p; + m4 = _mm_slli_si128(cmp_mask(x1, val4), 3); + + dmask = _mm_or_si128(_mm_or_si128(m1, m2), + _mm_or_si128(m3, m4)); + uint32_t imask = _mm_extract_epi32(dmask, 0); + + const uint32_t p2 = 1 << offset; + const uint32_t dest_mask = imask & ~(p2 - 1); + + return line_result(dest_mask, start); +} + +int line_search_2(small_hash_t* array, int start0, small_hash_t v1, + small_hash_t v2) { + int offset = start0 & 31; + int start = start0 & ~31; + __m128i* p = (__m128i*) &array[start]; + __m128i x1, x2, val1, val2, val3, val4; + __m128i m1, m2, m3, m4, dmask; + + x1 = fill(v1); + x2 = fill(v2); + +#define M(v) _mm_or_si128(cmp_mask(x1,(v)), \ + cmp_mask(x2,(v))) + val1 = *p++; + m1 = M(val1); + val2 = *p++; + m2 = _mm_slli_si128(M(val2), 1); + val3 = *p++; + m3 = _mm_slli_si128(M(val3), 2); + val4 = *p; + m4 = _mm_slli_si128(M(val4), 3); +#undef M + + dmask = _mm_or_si128(_mm_or_si128(m1, m2), + _mm_or_si128(m3, m4)); + uint32_t imask = _mm_extract_epi32(dmask, 0); + + const uint32_t p2 = 1 << offset; + const uint32_t dest_mask = imask & ~(p2 - 1); + + return line_result(dest_mask, start); +} + +int line_search_3(small_hash_t* array, int start0, small_hash_t v1, + small_hash_t v2, small_hash_t v3) { + int offset = start0 & 31; + int start = start0 & ~31; + __m128i* p = (__m128i*) &array[start]; + __m128i x1, x2, x3, val1, val2, val3, val4; + __m128i m1, m2, m3, m4, dmask; + + x1 = fill(v1); + x2 = fill(v2); + x3 = fill(v3); + +#define M(v) _mm_or_si128( \ + cmp_mask(x1,(v)), \ + _mm_or_si128(cmp_mask(x2,(v)), \ + cmp_mask(x3,(v)))) + val1 = *p++; + m1 = M(val1); + val2 = *p++; + m2 = _mm_slli_si128(M(val2), 1); + val3 = *p++; + m3 = _mm_slli_si128(M(val3), 2); + val4 = *p; + m4 = _mm_slli_si128(M(val4), 3); +#undef M + + dmask = _mm_or_si128(_mm_or_si128(m1, m2), + _mm_or_si128(m3, m4)); + uint32_t imask = _mm_extract_epi32(dmask, 0); + + const uint32_t p2 = 1 << offset; + const uint32_t dest_mask = imask & ~(p2 - 1); + + return line_result(dest_mask, start); +} diff --git a/impure-containers.cabal b/impure-containers.cabal --- a/impure-containers.cabal +++ b/impure-containers.cabal @@ -1,6 +1,6 @@ name: impure-containers -version: 0.1.1 -synopsis: Initial project template from stack +version: 0.2 +synopsis: Mutable containers in haskell description: Please see README.md homepage: https://github.com/andrewthad/impure-containers#readme license: BSD3 @@ -10,13 +10,16 @@ copyright: 2016 Andrew Martin category: web build-type: Simple --- extra-source-files: cabal-version: >=1.10 +extra-source-files: + cbits/Makefile + , cbits/check.c + , cbits/defs.h + , cbits/sse-42-check.c library hs-source-dirs: src exposed-modules: - Lib Data.HashMap.Mutable.Basic -- Data.Heap.Mutable.ModelA -- Data.Heap.Mutable.ModelB @@ -24,7 +27,9 @@ Data.Heap.Mutable.ModelD -- Data.Vector.Unique Data.Graph.Immutable - Data.Graph.Immutable.Tagged + Data.Graph.Mutable + Data.ArrayList.Generic + Data.Graph.Types other-modules: Data.HashMap.Mutable.Internal.Array Data.HashMap.Mutable.Internal.CacheLine @@ -42,6 +47,59 @@ , ghc-prim default-language: Haskell2010 + if flag(sse42) && !flag(portable) + cc-options: -DUSE_SSE_4_2 -msse4.2 + cpp-options: -DUSE_SSE_4_2 + C-sources: cbits/sse-42.c + + if !flag(portable) && !flag(sse42) + C-sources: cbits/default.c + + if !flag(portable) + C-sources: cbits/common.c + + if flag(portable) + cpp-options: -DNO_C_SEARCH -DPORTABLE + + if !flag(portable) && flag(unsafe-tricks) && impl(ghc) + build-depends: ghc-prim + cpp-options: -DUNSAFETRICKS + + if flag(debug) + cpp-options: -DDEBUG + + if flag(bounds-checking) + cpp-options: -DBOUNDS_CHECKING + + -- ghc-prof-options: -prof -auto-all + + if impl(ghc >= 6.12.0) + ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 + -fno-warn-unused-do-bind + else + ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 + +Flag unsafe-tricks + Description: turn on unsafe GHC tricks + Default: True + +Flag bounds-checking + Description: if on, use bounds-checking array accesses + Default: False + +Flag debug + Description: if on, spew debugging output to stdout + Default: False + +Flag sse42 + Description: if on, use SSE 4.2 extensions to search cache lines very + efficiently. The portable flag forces this off. + Default: False + +Flag portable + Description: if on, use only pure Haskell code and no GHC extensions. + Default: False + test-suite impure-containers-test type: exitcode-stdio-1.0 hs-source-dirs: test @@ -55,6 +113,7 @@ , QuickCheck , HUnit , test-framework-hunit + , vector ghc-options: -threaded -rtsopts -with-rtsopts=-N default-language: Haskell2010 diff --git a/src/Data/ArrayList/Generic.hs b/src/Data/ArrayList/Generic.hs new file mode 100644 --- /dev/null +++ b/src/Data/ArrayList/Generic.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE BangPatterns #-} + +module Data.ArrayList.Generic where + +import Control.Monad.Primitive +import Data.Vector.Generic.Mutable (MVector) +import Data.Vector.Generic (Vector, Mutable) +import Data.Primitive.MutVar +import qualified Data.Vector.Generic.Mutable as GM +import qualified Data.Vector.Generic as GV + +data ArrayList v s a = ArrayList + { arrayListSize :: !(MutVar s Int) + , arrayListVector :: !(MutVar s (v s a)) + } + +new :: (PrimMonad m, MVector v a) => Int -> m (ArrayList v (PrimState m) a) +new len = ArrayList <$> newMutVar 0 <*> (newMutVar =<< GM.new len) + +-- | Append an element to the end of the 'ArrayList'. +push :: (PrimMonad m, MVector v a) => ArrayList v (PrimState m) a -> a -> m () +push (ArrayList sizeRef mvecRef) a = do + !size <- readMutVar sizeRef + !mvec <- readMutVar mvecRef + let !newSize = size + 1 + vlen = GM.length mvec + writeMutVar sizeRef newSize + if size < vlen + then GM.unsafeWrite mvec size a + else do + newMVec <- GM.unsafeGrow mvec size + GM.unsafeWrite newMVec size a + writeMutVar mvecRef newMVec + +freeze :: (PrimMonad m, Vector v a) => ArrayList (Mutable v) (PrimState m) a -> m (v a) +freeze (ArrayList sizeRef mvecRef) = do + !size <- readMutVar sizeRef + !mvec <- readMutVar mvecRef + let sizedMVec = GM.unsafeTake size mvec + GV.freeze sizedMVec + diff --git a/src/Data/Graph/Immutable.hs b/src/Data/Graph/Immutable.hs --- a/src/Data/Graph/Immutable.hs +++ b/src/Data/Graph/Immutable.hs @@ -1,9 +1,208 @@ -{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE RankNTypes #-} module Data.Graph.Immutable where -import Data.Graph.Immutable.Tagged +import Data.Graph.Types +import Control.Monad.Primitive +import Data.Vector (Vector) +import Data.Vector.Mutable (MVector) +import Control.Monad +import Data.Word +import Control.Monad.ST (runST) +import Data.Primitive.MutVar +import qualified Data.Graph.Mutable as Mutable +import qualified Data.ArrayList.Generic as ArrayList +import qualified Data.HashMap.Mutable.Basic as HashTable +import qualified Data.Heap.Mutable.ModelD as Heap +import qualified Data.Vector as V +import qualified Data.Vector.Mutable as MV +import qualified Data.Vector.Unboxed as U +import qualified Data.Vector.Unboxed.Mutable as MU -data SomeGraph e v = forall g. SomeGraph { getSomeGraph :: Graph g e v } +mapVertices :: (v -> w) -> Graph g e v -> Graph g e w +mapVertices = fmap +dijkstra :: (Ord s, Monoid s) + => (v -> v -> s -> e -> s) + -> s -- ^ Weight to assign start vertex + -> Vertex g -- ^ start + -> Vertex g -- ^ end + -> Graph g e v + -> s +dijkstra f s start end g = + verticesRead (dijkstraTraversal f s start g) end +-- | This is a generalization of Dijkstra\'s algorithm. This function could +-- be written without unsafely pattern matching on 'Vertex', but doing +-- so allows us to use a faster heap implementation. +dijkstraTraversal :: + (Ord s, Monoid s) + => (v -> v -> s -> e -> s) -- ^ Weight combining function + -> s -- ^ Weight to assign start vertex + -> Vertex g -- ^ Start vertex + -> Graph g e v + -> Vertices g s +dijkstraTraversal f s0 v0 g = runST $ do + let theSize = size g + oldVertices = vertices g + newVertices <- Mutable.verticesReplicate theSize mempty + Mutable.verticesWrite newVertices v0 s0 + visited <- Mutable.verticesUReplicate theSize False + heap <- Heap.new (unSize theSize) + -- Using getVertex casts Vertex to Int. This is safe to do, + -- but going from Int to Vertex (done later) is normally unsafe. + -- We know it's ok in this case because the min heap does not + -- create Ints that we did not push onto it. + Heap.unsafePush s0 (getVertexInternal v0) heap + let go = do + m <- Heap.pop heap + case m of + Nothing -> return True + Just (s,unwrappedVertexIx) -> do + -- Unsafe cast from Int to Vertex + let vertex = Vertex unwrappedVertexIx + value = verticesRead oldVertices vertex + Mutable.verticesUWrite visited vertex True + Mutable.verticesWrite newVertices vertex s + traverseNeighbors_ (\theEdge neighborVertex neighborValue -> do + alreadyVisited <- Mutable.verticesURead visited neighborVertex + when (not alreadyVisited) $ Heap.unsafePush + (f value neighborValue s theEdge) + -- Casting from Vertex to Int + (getVertexInternal neighborVertex) + heap + ) vertex g + return False + runMe = do + isDone <- go + if isDone then return () else runMe + runMe + newVerticesFrozen <- verticesFreeze newVertices + return newVerticesFrozen + +lookupVertex :: Eq v => v -> Graph g e v -> Maybe (Vertex g) +lookupVertex val (Graph g) = fmap Vertex (V.elemIndex val (graphVertices g)) + +traverseNeighbors_ :: Applicative m + => (e -> Vertex g -> v -> m a) + -> Vertex g + -> Graph g e v + -> m () +traverseNeighbors_ f (Vertex x) (Graph g) = + let allVertices = graphVertices g + theVertices = graphOutboundNeighborVertices g V.! x + edges = graphOutboundNeighborEdges g V.! x + numNeighbors = U.length theVertices + go !i = if i < numNeighbors + then let vertexNum = theVertices U.! i + vertexVal = allVertices V.! vertexNum + edgeVal = edges V.! i + in f edgeVal (Vertex vertexNum) vertexVal *> go (i + 1) + else pure () + in go 0 + +lookupEdge :: Vertex g -> Vertex g -> Graph g e v -> Maybe e +lookupEdge (Vertex x) (Vertex y) (Graph (SomeGraph _ neighbors edges)) = + case U.elemIndex y (V.unsafeIndex neighbors x) of + Nothing -> Nothing + Just ix -> Just (V.unsafeIndex (V.unsafeIndex edges x) ix) + +mutableIForM_ :: PrimMonad m => MVector (PrimState m) a -> (Int -> a -> m b) -> m () +mutableIForM_ m f = forM_ (take (MV.length m) (enumFrom 0)) $ \i -> do + a <- MV.read m i + f i a + +mutableIFoldM' :: PrimMonad m => (a -> Int -> b -> m a) -> a -> MVector (PrimState m) b -> m a +mutableIFoldM' f x m = go 0 x where + len = MV.length m + go !i !a = if i < len + then do + b <- MV.read m i + aNext <- f a i b + go (i + 1) aNext + else return x + +vertices :: Graph g e v -> Vertices g v +vertices (Graph (SomeGraph v _ _)) = Vertices v + +size :: Graph g e v -> Size g +size (Graph (SomeGraph v _ _)) = Size (V.length v) + +unSize :: Size g -> Int +unSize (Size s) = s + +vertexInt :: Vertex g -> Int +vertexInt (Vertex i) = i + +verticesToVertexList :: Vertices g v -> [Vertex g] +verticesToVertexList (Vertices v) = map Vertex (take (V.length v) [0..]) + +verticesTraverse_ :: Monad m => (Vertex g -> v -> m a) -> Vertices g v -> m () +verticesTraverse_ f (Vertices v) = V.imapM_ (\i -> f (Vertex i)) v + +verticesToVector :: Vertices g v -> Vector v +verticesToVector (Vertices v) = v + +verticesRead :: Vertices g v -> Vertex g -> v +verticesRead (Vertices v) (Vertex i) = V.unsafeIndex v i + +verticesLength :: Vertices g v -> Int +verticesLength (Vertices v) = V.length v + +verticesFreeze :: PrimMonad m => MVertices g (PrimState m) v -> m (Vertices g v) +verticesFreeze (MVertices mvec) = fmap Vertices (V.freeze mvec) + +verticesThaw :: PrimMonad m => Vertices g v -> m (MVertices g (PrimState m) v) +verticesThaw (Vertices vec) = fmap MVertices (V.thaw vec) + +freeze :: PrimMonad m => MGraph g (PrimState m) e v -> m (Graph g e v) +freeze (MGraph vertexIndex currentIdVar edges) = do + let initialArrayListSize = 16 + numberOfVertices <- readMutVar currentIdVar + mvec <- MV.new numberOfVertices + mvecEdgeVals <- MV.replicateM numberOfVertices (ArrayList.new initialArrayListSize) + mvecEdgeNeighbors <- MV.replicateM numberOfVertices (ArrayList.new initialArrayListSize) + flip HashTable.mapM_ vertexIndex $ \vertexValue vertexId -> do + MV.unsafeWrite mvec vertexId vertexValue + flip HashTable.mapM_ edges $ \(IntPair fromVertexId toVertexId) edgeVal -> do + -- This would be better if I used hybrid vectors. + mvecEdgeVal <- MV.unsafeRead mvecEdgeVals fromVertexId + ArrayList.push mvecEdgeVal edgeVal + mvecEdgeNeighbor <- MV.unsafeRead mvecEdgeNeighbors fromVertexId + ArrayList.push mvecEdgeNeighbor toVertexId + vecEdgeVals1 <- V.unsafeFreeze mvecEdgeVals + vecEdgeVals2 <- V.mapM ArrayList.freeze vecEdgeVals1 + vecEdgeNeighbors1 <- V.unsafeFreeze mvecEdgeNeighbors + vecEdgeNeighbors2 <- V.mapM ArrayList.freeze vecEdgeNeighbors1 + vec <- V.unsafeFreeze mvec + return (Graph $ SomeGraph vec vecEdgeNeighbors2 vecEdgeVals2) + +-- | Takes a function that builds on an empty 'MGraph'. After the function +-- mutates the 'MGraph', it is frozen and becomes an immutable 'SomeGraph'. +create :: PrimMonad m => (forall g. MGraph g (PrimState m) e v -> m ()) -> m (SomeGraph e v) +create f = do + mg <- MGraph + <$> HashTable.new + <*> newMutVar 0 + <*> HashTable.new + f mg + Graph g <- freeze mg + return g + +with :: SomeGraph e v -> (forall g. Graph g e v -> a) -> a +with sg f = f (Graph sg) + +-- data Edge g = Edge +-- { edgeVertexA :: !Int +-- , edgeVertexB :: !Int +-- } + +-- instance Functor (Graph g e) where +-- fmap f g = g { graphVertices = Vector.map (graphVertices g) } + +-- visited,allowed,notAllowed :: Word8 +-- visited = 2 +-- allowed = 1 +-- notAllowed = 0 diff --git a/src/Data/Graph/Immutable/Tagged.hs b/src/Data/Graph/Immutable/Tagged.hs deleted file mode 100644 --- a/src/Data/Graph/Immutable/Tagged.hs +++ /dev/null @@ -1,120 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveFunctor #-} - -module Data.Graph.Immutable.Tagged where - -import Control.Monad.Primitive -import Data.Vector (Vector) -import Data.Vector.Mutable (MVector) -import Control.Monad -import Data.Word -import Control.Monad.ST (runST) -import qualified Data.Heap.Mutable.ModelD as Heap -import qualified Data.Vector as V -import qualified Data.Vector.Mutable as MV -import qualified Data.Vector.Unboxed as U -import qualified Data.Vector.Unboxed.Mutable as MU - -newtype Vertex g = Vertex { getVertex :: Int } -newtype Vertices g v = Vertices { getVertices :: Vector v } - deriving (Functor) - -data Edge g = Edge - { edgeVertexA :: !Int - , edgeVertexB :: !Int - } - --- | The neighbor vertices and neighbor edges must have --- equal length. -data Graph g e v = Graph - { graphVertices :: !(Vector v) - , graphOutboundNeighborVertices :: !(Vector (U.Vector Int)) - , graphOutboundNeighborEdges :: !(Vector (Vector e)) - -- , graphEdges :: Int -> Int -> Maybe e - } deriving (Functor) - --- instance Functor (Graph g e) where --- fmap f g = g { graphVertices = Vector.map (graphVertices g) } - --- visited,allowed,notAllowed :: Word8 --- visited = 2 --- allowed = 1 --- notAllowed = 0 - --- | This is a generalization of Dijkstra\'s algorithm. -breadthFirstBy :: (Ord s, Monoid s) - => (v -> v -> s -> e -> s) - -> Vertex g - -> Graph g e v - -> Vertices g s -breadthFirstBy f v0 g@(Graph vertices outNeighbors outEdges) = runST $ do - let vertexCount = V.length vertices - newVertices <- MV.new vertexCount - MV.set newVertices mempty - visited <- MU.new vertexCount - MU.set visited False - heap <- Heap.new vertexCount - Heap.unsafePush mempty (getVertex v0) heap - let keepGoing = do - m <- Heap.pop heap - case m of - Nothing -> return () - Just (s,vertexIx) -> do - MU.write visited vertexIx True - MV.write newVertices vertexIx s - let neighborVertices = outNeighbors V.! vertexIx - neighborEdges = outEdges V.! vertexIx - v1 = vertices V.! vertexIx - runInsert neighborIx neighborVertexIx = do - let edgeVal = neighborEdges V.! neighborIx - v2 = vertices V.! neighborVertexIx - alreadyVisited <- MU.read visited neighborVertexIx - if alreadyVisited - then return () - else Heap.push (f v1 v2 s edgeVal) neighborVertexIx heap - U.imapM_ runInsert neighborVertices - keepGoing - keepGoing - newVerticesFrozen <- V.freeze newVertices - return (Vertices newVerticesFrozen) - -- return (g {graphVertices = newVerticesFrozen}) - -lookupVertex :: Eq v => v -> Graph g e v -> Maybe (Vertex g) -lookupVertex val g = fmap Vertex (V.elemIndex val (graphVertices g)) - -traverseNeighbors_ :: Applicative m - => (e -> Vertex g -> v -> m a) - -> Vertex g - -> Graph g e v - -> m () -traverseNeighbors_ f (Vertex x) g = - let allVertices = graphVertices g - vertices = graphOutboundNeighborVertices g V.! x - edges = graphOutboundNeighborEdges g V.! x - numNeighbors = U.length vertices - go !i = if i < numNeighbors - then let vertexNum = vertices U.! i - vertexVal = allVertices V.! vertexNum - edgeVal = edges V.! i - in f edgeVal (Vertex vertexNum) vertexVal *> go (i + 1) - else pure () - in go 0 - --- lookupEdge :: Vertex g -> Vertex g -> Graph g e v -> Maybe (Edge g) --- lookupEdge (Vertex x) (Vertex y) g = - -mutableIForM_ :: PrimMonad m => MVector (PrimState m) a -> (Int -> a -> m b) -> m () -mutableIForM_ m f = forM_ (take (MV.length m) (enumFrom 0)) $ \i -> do - a <- MV.read m i - f i a - -mutableIFoldM' :: PrimMonad m => (a -> Int -> b -> m a) -> a -> MVector (PrimState m) b -> m a -mutableIFoldM' f x m = go 0 x where - len = MV.length m - go !i !a = if i < len - then do - b <- MV.read m i - aNext <- f a i b - go (i + 1) aNext - else return x - diff --git a/src/Data/Graph/Mutable.hs b/src/Data/Graph/Mutable.hs new file mode 100644 --- /dev/null +++ b/src/Data/Graph/Mutable.hs @@ -0,0 +1,62 @@ +module Data.Graph.Mutable where + +import Data.Graph.Types +import Control.Monad.Primitive +import qualified Data.Vector.Mutable as MV +import qualified Data.Vector.Unboxed.Mutable as MU +import Data.Vector.Unboxed (Unbox) +import Data.Primitive.MutVar +import Data.Hashable (Hashable) +import qualified Data.HashMap.Mutable.Basic as HashTable + +verticesReplicate :: PrimMonad m => Size g -> v -> m (MVertices g (PrimState m) v) +verticesReplicate (Size i) v = fmap MVertices (MV.replicate i v) + +verticesUReplicate :: (PrimMonad m, Unbox v) => Size g -> v -> m (MUVertices g (PrimState m) v) +verticesUReplicate (Size i) v = fmap MUVertices (MU.replicate i v) + +verticesUWrite :: (PrimMonad m, Unbox v) => MUVertices g (PrimState m) v -> Vertex g -> v -> m () +verticesUWrite (MUVertices mvec) (Vertex ix) v = MU.unsafeWrite mvec ix v + +verticesWrite :: PrimMonad m => MVertices g (PrimState m) v -> Vertex g -> v -> m () +verticesWrite (MVertices mvec) (Vertex ix) v = MV.unsafeWrite mvec ix v + +verticesURead :: (PrimMonad m, Unbox v) => MUVertices g (PrimState m) v -> Vertex g -> m v +verticesURead (MUVertices mvec) (Vertex ix) = MU.unsafeRead mvec ix + +verticesRead :: PrimMonad m => MVertices g (PrimState m) v -> Vertex g -> m v +verticesRead (MVertices mvec) (Vertex ix) = MV.unsafeRead mvec ix + +-- | This does two things: +-- +-- * Check to see if a vertex with the provided value already exists +-- * Create a new vertex if it does not exist +-- +-- In either case, the vertex id is returned, regardless or whether it was +-- preexisting or newly created. +insertVertex :: (PrimMonad m, Hashable v, Eq v) => MGraph g (PrimState m) e v -> v -> m (Vertex g) +insertVertex (MGraph vertexIndex currentIdVar _) v = do + m <- HashTable.lookup vertexIndex v + case m of + Nothing -> do + currentId <- readMutVar currentIdVar + writeMutVar currentIdVar (currentId + 1) + HashTable.insert vertexIndex v currentId + return (Vertex currentId) + Just i -> return (Vertex i) + +-- | This replaces the edge if it already exists. If you pass the same vertex +-- as the source and the destination, this function has no effect. +insertEdge :: PrimMonad m => MGraph g (PrimState m) e v -> Vertex g -> Vertex g -> e -> m () +insertEdge (MGraph _ _ edges) (Vertex a) (Vertex b) e = do + HashTable.insert edges (IntPair a b) e + +-- | Insert edge with a function, combining the existing edge value and the old one. +insertEdgeWith :: PrimMonad m => MGraph g (PrimState m) e v -> (e -> e -> e) -> Vertex g -> Vertex g -> e -> m () +insertEdgeWith (MGraph _ _ edges) combine (Vertex a) (Vertex b) e = do + m <- HashTable.lookup edges (IntPair a b) + case m of + Nothing -> HashTable.insert edges (IntPair a b) e + Just eOld -> HashTable.insert edges (IntPair a b) (combine eOld e) + + diff --git a/src/Data/Graph/Types.hs b/src/Data/Graph/Types.hs new file mode 100644 --- /dev/null +++ b/src/Data/Graph/Types.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE BangPatterns #-} +module Data.Graph.Types where + +import Data.HashMap.Mutable.Basic (HashTable) +import Data.Vector (Vector,MVector) +import Data.Primitive.MutVar (MutVar) +import Data.Hashable (Hashable) +import GHC.Generics (Generic) +import qualified Data.Vector.Unboxed as U +import qualified Data.Vector.Unboxed.Mutable as MU + +newtype Graph g e v = Graph { getGraphInternal :: SomeGraph e v } + deriving (Functor) + +-- | The neighbor vertices and neighbor edges must have +-- equal length. +-- +-- TODO: enforce that the inner vectors for the neighbors are +-- ordered. This will make testing for neighbors easier and +-- will make an equality check easier. +data SomeGraph e v = SomeGraph + { graphVertices :: !(Vector v) + , graphOutboundNeighborVertices :: !(Vector (U.Vector Int)) + , graphOutboundNeighborEdges :: !(Vector (Vector e)) + } deriving (Functor) + +newtype Size g = Size { getSizeInternal :: Int } + +newtype Vertex g = Vertex { getVertexInternal :: Int } + deriving (Eq,Ord,Hashable) +newtype Vertices g v = Vertices { getVerticesInternal :: Vector v } + deriving (Functor) +newtype MVertices g s v = MVertices { getMVerticesInternal :: MVector s v } +newtype MUVertices g s v = MUVertices { getMUVerticesInternal :: MU.MVector s v } + +data IntPair = IntPair !Int !Int + deriving (Eq,Ord,Show,Read,Generic) + +instance Hashable IntPair + +data MGraph g s e v = MGraph + { mgraphVertexIndex :: !(HashTable s v Int) + , mgraphCurrentId :: !(MutVar s Int) + , mgraphEdges :: !(HashTable s IntPair e) + } + diff --git a/src/Data/HashMap/Mutable/Basic.hs b/src/Data/HashMap/Mutable/Basic.hs --- a/src/Data/HashMap/Mutable/Basic.hs +++ b/src/Data/HashMap/Mutable/Basic.hs @@ -248,7 +248,7 @@ ------------------------------------------------------------------------------ -- | See the documentation for this function in -- "Data.HashTable.Class#v:mapM_". -mapM_ :: PrimMonad m => ((k,v) -> m b) -> HashTable (PrimState m) k v -> m () +mapM_ :: PrimMonad m => (k -> v -> m b) -> HashTable (PrimState m) k v -> m () mapM_ f htRef = readRef htRef >>= work where work (HashTable sz _ hashes keys values) = go 0 @@ -261,7 +261,7 @@ else do k <- readArray keys i v <- readArray values i - _ <- f (k, v) + _ <- f k v go (i+1) diff --git a/src/Data/Heap/Mutable/ModelC.hs b/src/Data/Heap/Mutable/ModelC.hs --- a/src/Data/Heap/Mutable/ModelC.hs +++ b/src/Data/Heap/Mutable/ModelC.hs @@ -32,7 +32,7 @@ -- causing the priority to increas, the heap becomes invalid (but not in a way that causes -- segfaults). -- --- As a result of the third constraint, the 'Monoid' instance and 'Ord' instance of the priority type +-- As a result of the last constraint, the 'Monoid' instance and 'Ord' instance of the priority type -- must obey these additional laws: -- -- > mappend a b ≤ a diff --git a/src/Lib.hs b/src/Lib.hs deleted file mode 100644 --- a/src/Lib.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Lib - ( someFunc - ) where - -someFunc :: IO () -someFunc = putStrLn "someFunc" diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -2,11 +2,15 @@ module Main (main) where -import Test.QuickCheck (Gen, Arbitrary(..), choose, shrinkIntegral) +import Test.QuickCheck (Gen, Arbitrary(..), choose, shrinkIntegral, + listOf, vectorOf) import Test.Framework (defaultMain, testGroup, Test) import Test.Framework.Providers.QuickCheck2 (testProperty) import Test.Framework.Providers.HUnit (testCase) import Test.HUnit (Assertion,(@?=)) +import Data.Monoid (All(..)) +import Data.Traversable +import Control.Applicative import Data.Coerce import Data.Word @@ -19,7 +23,11 @@ import qualified Data.Map.Strict as Map import Debug.Trace +import qualified Data.Vector as V +import qualified Data.ArrayList.Generic as ArrayList import qualified Data.Heap.Mutable.ModelD as HeapD +import qualified Data.Graph.Mutable as MGraph +import qualified Data.Graph.Immutable as Graph main :: IO () main = defaultMain tests @@ -31,6 +39,13 @@ , testProperty "Model D Push Pop" heapPushPop , testProperty "Model D List" heapMatchesList ] + , testGroup "ArrayList" + [ testProperty "Insertion followed by freezing" arrayListWorks + ] + , testGroup "Graph" + [ testProperty "Building only from vertices" graphBuildingVertices + , testProperty "Trivial case for Dijkstras Algorithm" dijkstraEasyDistance + ] ] testElements :: Int @@ -44,7 +59,7 @@ shrink (Min a) = fmap Min $ filter (>= 0) $ shrinkIntegral a instance Monoid Min where - mempty = Min 0 + mempty = Min maxBound mappend (Min a) (Min b) = Min (min a b) newtype MyElement = MyElement { getMyElement :: Int } @@ -54,6 +69,13 @@ arbitrary = fmap MyElement (choose (0,fromIntegral testElements - 1)) shrink (MyElement a) = fmap MyElement $ filter (>= 0) $ shrinkIntegral a -- fmap MyElement (enumFromTo 0 (a - 1)) +newtype TenElemsOrLessList a = TenElemsOrLessList [a] + deriving (Read,Show,Eq,Ord) + +instance Arbitrary a => Arbitrary (TenElemsOrLessList a) where + arbitrary = fmap TenElemsOrLessList $ flip vectorOf arbitrary =<< choose (0 :: Int,10) + shrink (TenElemsOrLessList a) = fmap TenElemsOrLessList $ shrink a + multipush :: [(Min,MyElement)] -> Bool multipush xs = runST $ do h <- trace "Running Test" (HeapD.new testElements) @@ -82,4 +104,62 @@ heapResSet = map (\pairs@((p,_) : _) -> (p,Set.fromList $ map snd pairs)) $ groupBy (on (==) fst) heapRes in heapResSet == listRes + +arrayListWorks :: [Int] -> Bool +arrayListWorks xs = + let ys = runST $ do + a <- ArrayList.new 1 + forM_ xs $ \x -> ArrayList.push a x + ArrayList.freeze a + in xs == V.toList ys + +-- This makes sure that when you insert a bunch of vertices into +-- a graph, you get the same vertices back out. This does not +-- do anything to check for edges. +graphBuildingVertices :: [Int] -> Bool +graphBuildingVertices xs = + let sg = runST $ Graph.create $ \mg -> do + forM_ xs $ \x -> do + MGraph.insertVertex mg x + ys = Graph.with sg (Graph.verticesToVector . Graph.vertices) + in List.nub (List.sort xs) == List.sort (V.toList ys) + +graphBuildingEdgesEverywhere :: TenElemsOrLessList Int -> Bool +graphBuildingEdgesEverywhere (TenElemsOrLessList xs) = + let onlyEdge = 77 :: Int + sg = runST $ Graph.create $ \mg -> do + vertices <- forM xs $ \x -> do + MGraph.insertVertex mg x + forM_ vertices $ \source -> do + forM_ vertices $ \dest -> do + MGraph.insertEdge mg source dest onlyEdge + in getAll $ getConst $ Graph.with sg $ \g -> + let v = Graph.vertices g -- Graph.vertices g Graph.verticesToVector . Graph.vertices) + vlist = Graph.verticesToVertexList v + in for vlist $ \va -> + for vlist $ \vb -> + Const (All $ Graph.lookupEdge va vb g == Just onlyEdge) + +data Thing = Thing + +-- Every node is connected to at most two other nodes. The end +-- nodes only have one neighbor. Go from one end node to the other. +dijkstraEasyDistance :: [Word32] -> Bool +dijkstraEasyDistance xs = + let sg = runST $ Graph.create $ \mg -> do + start <- MGraph.insertVertex mg (0 :: Int) + let insertNext prevVertex zs i = case zs of + [] -> return () + y : ys -> do + vertex <- MGraph.insertVertex mg i + MGraph.insertEdge mg prevVertex vertex y + insertNext vertex ys (i + 1) + insertNext start xs 1 + in Graph.with sg $ \g -> case (Graph.lookupVertex 0 g, Graph.lookupVertex (List.length xs) g) of + (Nothing,Nothing) -> False + (Nothing,Just _) -> False + (Just _,Nothing) -> False + (Just start, Just end) -> + let expected = Min (sum xs) + in expected == Graph.dijkstra (\_ _ (Min x) distance -> Min (x + distance)) (Min 0) start end g