impure-containers 0.1.1 → 0.2

raw patch · 17 files changed

+1233/−139 lines, 17 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• cbits/Makefile +14/−0
• cbits/check.c +185/−0
• cbits/common.c +83/−0
• cbits/default.c +203/−0
• cbits/defs.h +35/−0
• cbits/sse-42-check.c +38/−0
• cbits/sse-42.c +172/−0
• impure-containers.cabal +64/−5
• src/Data/ArrayList/Generic.hs +41/−0
• src/Data/Graph/Immutable.hs +202/−3
• src/Data/Graph/Immutable/Tagged.hs +0/−120
• src/Data/Graph/Mutable.hs +62/−0
• src/Data/Graph/Types.hs +49/−0
• src/Data/HashMap/Mutable/Basic.hs +2/−2
• src/Data/Heap/Mutable/ModelC.hs +1/−1
• src/Lib.hs +0/−6
• test/Spec.hs +82/−2

@@ -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

@@ -0,0 +1,185 @@+#include <stdlib.h>+#include <stdio.h>+#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);+}

@@ -0,0 +1,83 @@+#include "defs.h"++#ifdef WIN32+#include <windows.h>+#else+#include <signal.h>+#include <unistd.h>+#endif++#include <stdio.h>++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;+    }+}+

@@ -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) {++}

@@ -0,0 +1,35 @@+#ifndef HASHTABLES_DEFS_H+#define HASHTABLES_DEFS_H++#include <stdint.h>+#include <strings.h>++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 */

@@ -0,0 +1,38 @@+#include "defs.h"++#include <smmintrin.h>+#include <stdio.h>++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);+}

@@ -0,0 +1,172 @@+#include "defs.h"++#include <smmintrin.h>+#include <stdio.h>++/* 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);+}

@@ -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 

@@ -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+

@@ -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

@@ -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-

@@ -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)++

@@ -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)+  }+

@@ -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)  

@@ -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

@@ -1,6 +0,0 @@-module Lib-    ( someFunc-    ) where--someFunc :: IO ()-someFunc = putStrLn "someFunc"

@@ -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